teal.reporter coverage - 78.90%

Files
Source

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

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

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

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

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

#' Get document output arguments from the `rmarkdown` package
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Retrieves the arguments for a specified document output type from the `rmarkdown` package.
#'
#' @param output_name (`character`) `rmarkdown` output name.
#' @param default_values (`logical(1)`) if to return a default values for each argument.
#' @export
#' @examples
#' rmd_output_arguments("pdf_document")
#' rmd_output_arguments("pdf_document", TRUE)
rmd_output_arguments <- function(output_name, default_values = FALSE) {
  checkmate::assert_string(output_name)
  checkmate::assert_subset(output_name, rmd_outputs())

  rmarkdown_namespace <- asNamespace("rmarkdown")
  if (default_values) {
    formals(rmarkdown_namespace[[output_name]])
  } else {
    names(formals(rmarkdown_namespace[[output_name]]))
  }
}

#' Parse a named list to `yaml` header for an `Rmd` file
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Converts a named list into a `yaml` header for `Rmd`, handling output types and arguments
#' as defined in the `rmarkdown` package. This function simplifies the process of generating `yaml` headers.
#'
#' @details
#' This function processes a non-nested (flat) named list into a `yaml` header for an `Rmd` document.
#' It supports all standard `Rmd` `yaml` header fields, including `author`, `date`, `title`, `subtitle`,
#'  `abstract`, `keywords`, `subject`, `description`, `category`, and `lang`.
#' Additionally,  it handles `output` field types and arguments as defined in the `rmarkdown` package.
#'
#' @note Only non-nested lists are automatically parsed.
#' Nested lists require direct processing with `yaml::as.yaml`.
#'
#' @param input_list (`named list`) non nested with slots names and their values compatible with `Rmd` `yaml` header.
#' @param as_header (`logical(1)`) optionally wrap with result with the internal `md_header()`, default `TRUE`.
#' @param convert_logi (`logical(1)`) convert a character values to logical,
#'  if they are recognized as quoted `yaml` logical values , default `TRUE`.
#' @param multi_output (`logical(1)`) multi `output` slots in the `input` argument, default `FALSE`.
#' @param silent (`logical(1)`) suppress messages and warnings, default `FALSE`.
#' @return `character` with `rmd_yaml_header` class,
#' result of [`yaml::as.yaml`], optionally wrapped with internal `md_header()`.
#' @export
#' @examples
#' # nested so using yaml::as.yaml directly
#' as_yaml_auto(
#'   list(author = "", output = list(pdf_document = list(toc = TRUE)))
#' )
#'
#' # auto parsing for a flat list, like shiny input
#' input <- list(author = "", output = "pdf_document", toc = TRUE, keep_tex = TRUE)
#' as_yaml_auto(input)
#'
#' as_yaml_auto(list(author = "", output = "pdf_document", toc = TRUE, keep_tex = "TRUE"))
#'
#' as_yaml_auto(list(
#'   author = "", output = "pdf_document", toc = TRUE, keep_tex = TRUE,
#'   wrong = 2
#' ))
#'
#' as_yaml_auto(list(author = "", output = "pdf_document", toc = TRUE, keep_tex = 2),
#'   silent = TRUE
#' )
#'
#' input <- list(author = "", output = "pdf_document", toc = TRUE, keep_tex = "True")
#' as_yaml_auto(input)
#' as_yaml_auto(input, convert_logi = TRUE, silent = TRUE)
#' as_yaml_auto(input, silent = TRUE)
#' as_yaml_auto(input, convert_logi = FALSE, silent = TRUE)
#'
#' as_yaml_auto(
#'   list(
#'     author = "", output = "pdf_document",
#'     output = "html_document", toc = TRUE, keep_tex = TRUE
#'   ),
#'   multi_output = TRUE
#' )
#' as_yaml_auto(
#'   list(
#'     author = "", output = "pdf_document",
#'     output = "html_document", toc = "True", keep_tex = TRUE
#'   ),
#'   multi_output = TRUE
#' )
as_yaml_auto <- function(input_list,
                         as_header = TRUE,
                         convert_logi = TRUE,
                         multi_output = FALSE,
                         silent = FALSE) {
  checkmate::assert_logical(as_header)
  checkmate::assert_logical(convert_logi)
  checkmate::assert_logical(silent)
  checkmate::assert_logical(multi_output)

  if (multi_output) {
    checkmate::assert_list(input_list, names = "named")
  } else {
    checkmate::assert_list(input_list, names = "unique")
  }

  is_nested <- function(x) any(unlist(lapply(x, is.list)))
  if (is_nested(input_list)) {
    result <- input_list
  } else {
    result <- list()
    input_nams <- names(input_list)

    # top fields
    top_fields <- c(
      "author", "date", "title", "subtitle", "abstract",
      "keywords", "subject", "description", "category", "lang"
    )
    for (itop in top_fields) {
      if (itop %in% input_nams) {
        result[[itop]] <- switch(itop,
          date = as.character(input_list[[itop]]),
          input_list[[itop]]
        )
      }
    }

    # output field
    doc_types <- unlist(input_list[input_nams == "output"])
    if (length(doc_types)) {
      for (dtype in doc_types) {
        doc_type_args <- rmd_output_arguments(dtype, TRUE)
        doc_type_args_nams <- names(doc_type_args)
        any_output_arg <- any(input_nams %in% doc_type_args_nams)

        not_found_args <- setdiff(input_nams, c(doc_type_args_nams, top_fields, "output"))
        if (isFALSE(silent) && length(not_found_args) > 0 && isFALSE(multi_output)) {
          warning(sprintf("Not recognized and skipped arguments: %s", paste(not_found_args, collapse = ", ")))
        }

        if (any_output_arg) {
          doc_list <- list()
          doc_list[[dtype]] <- list()
          for (e in intersect(input_nams, doc_type_args_nams)) {
            if (is.logical(doc_type_args[[e]]) && is.character(input_list[[e]])) {
              pos_logi <- c("TRUE", "true", "True", "yes", "y", "Y", "on")
              neg_logi <- c("FALSE", "false", "False", "no", "n", "N", "off")
              all_logi <- c(pos_logi, neg_logi)
              if (input_list[[e]] %in% all_logi && convert_logi) {
                input_list[[e]] <- conv_str_logi(input_list[[e]], e,
                  pos_logi = pos_logi,
                  neg_logi = neg_logi, silent = silent
                )
              }
            }

            doc_list[[dtype]][[e]] <- input_list[[e]]
          }
          result[["output"]] <- append(result[["output"]], doc_list)
        } else {
          result[["output"]] <- append(result[["output"]], input_list[["output"]])
        }
      }
    }
  }

  result <- yaml::as.yaml(result)
  if (as_header) {
    result <- md_header(result)
  }
  structure(result, class = "rmd_yaml_header")
}

#' Print method for the `yaml_header` class
#'
#' `r lifecycle::badge("experimental")`
#'
#' @param x (`rmd_yaml_header`) class object.
#' @param ... optional text.
#' @return `NULL`.
#' @exportS3Method
#' @examples
#' input <- list(author = "", output = "pdf_document", toc = TRUE, keep_tex = TRUE)
#' out <- as_yaml_auto(input)
#' out
#' print(out)
print.rmd_yaml_header <- function(x, ...) {
  cat(x, ...)
}

#' Extract field from `yaml` text
#'
#' Parses `yaml` text, extracting the specified field. Returns list names if it's a list;
#' otherwise, the field itself.
#'
#' @param yaml_text (`rmd_yaml_header` or `character`) vector containing the `yaml` text.
#' @param field_name (`character`) the name of the field to extract.
#'
#' @return If the field is a list, it returns the names of elements in the list; otherwise,
#' it returns the extracted field.
#'
#' @keywords internal
get_yaml_field <- function(yaml_text, field_name) {
  checkmate::assert_multi_class(yaml_text, c("rmd_yaml_header", "character"))
  checkmate::assert_string(field_name)

  yaml_obj <- yaml::yaml.load(yaml_text)

  result <- yaml_obj[[field_name]]
  if (is.list(result)) {
    result <- names(result)
  }
  result
}

#' @title `Reporter`: An `R6` class for managing report cards
#' @docType class
#' @description `r lifecycle::badge("experimental")`
#'
#' This `R6` class is designed to store and manage report cards,
#' facilitating the creation, manipulation, and serialization of report-related data.
#'
#' @export
#'
Reporter <- R6::R6Class( # nolint: object_name_linter.
  classname = "Reporter",
  public = list(
    #' @description Initialize a `Reporter` object.
    #'
    #' @return Object of class `Reporter`, invisibly.
    #' @examples
    #' reporter <- Reporter$new()
    #'
    initialize = function() {
      private$cards <- list()
      private$reactive_add_card <- shiny::reactiveVal(0)
      invisible(self)
    },
    #' @description Append one or more `ReportCard` objects to the `Reporter`.
    #'
    #' @param cards (`ReportCard`) or a list of such objects
    #' @return `self`, invisibly.
    #' @examples
    #' library(ggplot2)
    #' library(rtables)
    #'
    #' card1 <- ReportCard$new()
    #'
    #' card1$append_text("Header 2 text", "header2")
    #' card1$append_text("A paragraph of default text", "header2")
    #' card1$append_plot(
    #'   ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
    #' )
    #'
    #' card2 <- ReportCard$new()
    #'
    #' card2$append_text("Header 2 text", "header2")
    #' card2$append_text("A paragraph of default text", "header2")
    #' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean)
    #' table_res2 <- build_table(lyt, airquality)
    #' card2$append_table(table_res2)
    #' card2$append_table(iris)
    #'
    #' reporter <- Reporter$new()
    #' reporter$append_cards(list(card1, card2))
    append_cards = function(cards) {
      checkmate::assert_list(cards, "ReportCard")
      private$cards <- append(private$cards, cards)
      private$reactive_add_card(length(private$cards))
      invisible(self)
    },
    #' @description Retrieves all `ReportCard` objects contained in the `Reporter`.
    #'
    #' @return A (`list`) of [`ReportCard`] objects.
    #' @examples
    #' library(ggplot2)
    #' library(rtables)
    #'
    #' card1 <- ReportCard$new()
    #'
    #' card1$append_text("Header 2 text", "header2")
    #' card1$append_text("A paragraph of default text", "header2")
    #' card1$append_plot(
    #'  ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
    #' )
    #'
    #' card2 <- ReportCard$new()
    #'
    #' card2$append_text("Header 2 text", "header2")
    #' card2$append_text("A paragraph of default text", "header2")
    #' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean)
    #' table_res2 <- build_table(lyt, airquality)
    #' card2$append_table(table_res2)
    #' card2$append_table(iris)
    #'
    #' reporter <- Reporter$new()
    #' reporter$append_cards(list(card1, card2))
    #' reporter$get_cards()
    get_cards = function() {
      private$cards
    },
    #' @description Compiles and returns all content blocks from the [`ReportCard`] in the `Reporter`.
    #'
    #' @param sep An optional separator to insert between each content block.
    #' Default is a `NewpageBlock$new()`object.
    #' @return `list()` list of `TableBlock`, `TextBlock`, `PictureBlock` and `NewpageBlock`.
    #' @examples
    #' library(ggplot2)
    #' library(rtables)
    #'
    #' card1 <- ReportCard$new()
    #'
    #' card1$append_text("Header 2 text", "header2")
    #' card1$append_text("A paragraph of default text", "header2")
    #' card1$append_plot(
    #'  ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
    #' )
    #'
    #' card2 <- ReportCard$new()
    #'
    #' card2$append_text("Header 2 text", "header2")
    #' card2$append_text("A paragraph of default text", "header2")
    #' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean)
    #' table_res2 <- build_table(lyt, airquality)
    #' card2$append_table(table_res2)
    #' card2$append_table(iris)
    #'
    #' reporter <- Reporter$new()
    #' reporter$append_cards(list(card1, card2))
    #' reporter$get_blocks()
    #'
    get_blocks = function(sep = NewpageBlock$new()) {
      blocks <- list()
      if (length(private$cards) > 0) {
        for (card_idx in head(seq_along(private$cards), -1)) {
          blocks <- append(blocks, append(private$cards[[card_idx]]$get_content(), sep))
        }
        blocks <- append(blocks, private$cards[[length(private$cards)]]$get_content())
      }
      blocks
    },
    #' @description Resets the `Reporter`, removing all [`ReportCard`] objects and metadata.
    #'
    #' @return `self`, invisibly.
    #'
    reset = function() {
      private$cards <- list()
      private$metadata <- list()
      private$reactive_add_card(0)
      invisible(self)
    },
    #' @description Removes specific `ReportCard` objects from the `Reporter` by their indices.
    #'
    #' @param ids (`integer(id)`) the indexes of cards
    #' @return `self`, invisibly.
    remove_cards = function(ids = NULL) {
      checkmate::assert(
        checkmate::check_null(ids),
        checkmate::check_integer(ids, min.len = 1, max.len = length(private$cards))
      )
      if (!is.null(ids)) {
        private$cards <- private$cards[-ids]
      }
      private$reactive_add_card(length(private$cards))
      invisible(self)
    },
    #' @description Swaps the positions of two `ReportCard` objects within the `Reporter`.
    #'
    #' @param start (`integer`) the index of the first card
    #' @param end (`integer`) the index of the second card
    #' @return `self`, invisibly.
    swap_cards = function(start, end) {
      checkmate::assert(
        checkmate::check_integer(start,
          min.len = 1, max.len = 1, lower = 1, upper = length(private$cards)
        ),
        checkmate::check_integer(end,
          min.len = 1, max.len = 1, lower = 1, upper = length(private$cards)
        ),
        combine = "and"
      )
      start_val <- private$cards[[start]]$clone()
      end_val <- private$cards[[end]]$clone()
      private$cards[[start]] <- end_val
      private$cards[[end]] <- start_val
      invisible(self)
    },
    #' @description Gets the current value of the reactive variable for adding cards.
    #'
    #' @return `reactive_add_card` current `numeric` value of the reactive variable.
    #' @note The function has to be used in the shiny reactive context.
    #' @examples
    #' library(shiny)
    #'
    #' isolate(Reporter$new()$get_reactive_add_card())
    get_reactive_add_card = function() {
      private$reactive_add_card()
    },
    #' @description Get the metadata associated with this `Reporter`.
    #'
    #' @return `named list` of metadata to be appended.
    #' @examples
    #' reporter <- Reporter$new()$append_metadata(list(sth = "sth"))
    #' reporter$get_metadata()
    #'
    get_metadata = function() {
      private$metadata
    },
    #' @description Appends metadata to this `Reporter`.
    #'
    #' @param meta (`named list`) of metadata to be appended.
    #' @return `self`, invisibly.
    #' @examples
    #' reporter <- Reporter$new()$append_metadata(list(sth = "sth"))
    #' reporter$get_metadata()
    #'
    append_metadata = function(meta) {
      checkmate::assert_list(meta, names = "unique")
      checkmate::assert_true(length(meta) == 0 || all(!names(meta) %in% names(private$metadata)))
      private$metadata <- append(private$metadata, meta)
      invisible(self)
    },
    #' @description
    #' Reinitializes a `Reporter` instance by copying the report cards and metadata from another `Reporter`.
    #' @param reporter (`Reporter`) instance to copy from.
    #' @return 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,
    # @description The copy constructor.
    #
    # @param name the name of the field
    # @param value the value of the field
    # @return the new value of the field
    #
    deep_clone = function(name, value) {
      if (name == "cards") {
        lapply(value, function(card) card$clone(deep = TRUE))
      } else {
        value
      }
    }
  ),
  lock_objects = TRUE,
  lock_class = TRUE
)

#' Report previewer module
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Module offers functionalities to visualize, manipulate,
#' and interact with report cards that have been added to a report.
#' It includes a previewer interface to see the cards and options to modify the report before downloading.
#'
#' Cards are saved by the `shiny` bookmarking mechanism.
#'
#' For more details see the vignette: `vignette("previewerReporter", "teal.reporter")`.
#'
#' @details `r global_knitr_details()`
#'
#' @name reporter_previewer
#'
#' @param id (`character(1)`) `shiny` module instance id.
#' @param reporter (`Reporter`) instance.
#' @param global_knitr (`list`) of `knitr` parameters (passed to `knitr::opts_chunk$set`)
#'  for customizing the rendering process.
#' @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
#' @export
reporter_previewer_ui <- function(id) {
  ns <- shiny::NS(id)

  shiny::fluidRow(
    add_previewer_js(ns),
    add_previewer_css(),
    shiny::tagList(
      shiny::tags$div(
        class = "col-md-3",
        shiny::tags$div(class = "well", shiny::uiOutput(ns("encoding")))
      ),
      shiny::tags$div(
        class = "col-md-9",
        shiny::tags$div(
          id = "reporter_previewer",
          shiny::uiOutput(ns("pcards"))
        )
      )
    )
  )
}

#' @rdname reporter_previewer
#' @export
reporter_previewer_srv <- function(id,
                                   reporter,
                                   global_knitr = getOption("teal.reporter.global_knitr"),
                                   rmd_output = c(
                                     "html" = "html_document", "pdf" = "pdf_document",
                                     "powerpoint" = "powerpoint_presentation",
                                     "word" = "word_document"
                                   ),
                                   rmd_yaml_args = list(
                                     author = "NEST", title = "Report",
                                     date = as.character(Sys.Date()), output = "html_document",
                                     toc = FALSE
                                   ),
                                   previewer_buttons = c("download", "load", "reset")) {
  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) {
    shiny::setBookmarkExclude(c(
      "card_remove_id", "card_down_id", "card_up_id", "remove_card_ok", "showrcode", "download_data_prev",
      "load_reporter_previewer", "load_reporter"
    ))

    session$onBookmark(function(state) {
      reporterdir <- file.path(state$dir, "reporter")
      dir.create(reporterdir)
      reporter$to_jsondir(reporterdir)
    })
    session$onRestored(function(state) {
      reporterdir <- file.path(state$dir, "reporter")
      reporter$from_jsondir(reporterdir)
    })

    ns <- session$ns

    reset_report_button_srv("resetButtonPreviewer", reporter)

    output$encoding <- shiny::renderUI({
      reporter$get_reactive_add_card()
      nr_cards <- length(reporter$get_cards())

      previewer_buttons_list <- list(
        download = htmltools::tagAppendAttributes(
          shiny::tags$a(
            id = ns("download_data_prev"),
            class = "btn btn-primary shiny-download-link simple_report_button",
            href = "",
            target = "_blank",
            download = NA,
            shiny::tags$span("Download Report", shiny::icon("download"))
          ),
          class = if (nr_cards) "" else "disabled"
        ),
        load = shiny::tags$button(
          id = ns("load_reporter_previewer"),
          type = "button",
          class = "btn btn-primary action-button simple_report_button",
          `data-val` = shiny::restoreInput(id = ns("load_reporter_previewer"), default = NULL),
          NULL,
          shiny::tags$span(
            "Load Report", shiny::icon("upload")
          )
        ),
        reset = reset_report_button_ui(ns("resetButtonPreviewer"), label = "Reset Report")
      )

      shiny::tags$div(
        id = "previewer_reporter_encoding",
        shiny::tags$h3("Download the Report"),
        shiny::tags$hr(),
        reporter_download_inputs(
          rmd_yaml_args = rmd_yaml_args,
          rmd_output = rmd_output,
          showrcode = any_rcode_block(reporter),
          session = session
        ),
        shiny::tags$div(
          id = "previewer_reporter_buttons",
          class = "previewer_buttons_line",
          previewer_buttons_list[previewer_buttons]
        )
      )
    })

    output$pcards <- shiny::renderUI({
      reporter$get_reactive_add_card()
      input$card_remove_id
      input$card_down_id
      input$card_up_id

      cards <- reporter$get_cards()

      if (length(cards)) {
        shiny::tags$div(
          class = "panel-group accordion",
          id = "reporter_previewer_panel",
          lapply(seq_along(cards), function(ic) {
            previewer_collapse_item(ic, cards[[ic]]$get_name(), cards[[ic]]$get_content())
          })
        )
      } else {
        shiny::tags$div(
          id = "reporter_previewer_panel_no_cards",
          shiny::tags$p(
            class = "text-danger mt-4",
            shiny::tags$strong("No Cards added")
          )
        )
      }
    })

    shiny::observeEvent(input$load_reporter_previewer, {
      nr_cards <- length(reporter$get_cards())
      shiny::showModal(
        shiny::modalDialog(
          easyClose = TRUE,
          shiny::tags$h3("Load the Reporter"),
          shiny::tags$hr(),
          shiny::fileInput(ns("archiver_zip"), "Choose Reporter File to Load (a zip file)",
            multiple = FALSE,
            accept = c(".zip")
          ),
          footer = shiny::div(
            shiny::tags$button(
              type = "button",
              class = "btn btn-danger",
              `data-dismiss` = "modal",
              `data-bs-dismiss` = "modal",
              NULL,
              "Cancel"
            ),
            shiny::tags$button(
              id = ns("load_reporter"),
              type = "button",
              class = "btn btn-primary action-button",
              `data-val` = shiny::restoreInput(id = ns("load_reporter"), default = NULL),
              NULL,
              "Load"
            )
          )
        )
      )
    })

    shiny::observeEvent(input$load_reporter, {
      switch("JSON",
        JSON = load_json_report(reporter, input$archiver_zip[["datapath"]], input$archiver_zip[["name"]]),
        stop("The provided Reporter file format is not supported")
      )

      shiny::removeModal()
    })

    shiny::observeEvent(input$card_remove_id, {
      shiny::showModal(
        shiny::modalDialog(
          title = "Remove the Report Card",
          shiny::tags$p(
            shiny::HTML(
              sprintf(
                "Do you really want to remove <strong>the card %s</strong> from the Report?",
                input$card_remove_id
              )
            )
          ),
          footer = shiny::tagList(
            shiny::tags$button(
              type = "button",
              class = "btn btn-secondary",
              `data-dismiss` = "modal",
              `data-bs-dismiss` = "modal",
              NULL,
              "Cancel"
            ),
            shiny::actionButton(ns("remove_card_ok"), "OK", class = "btn-danger")
          )
        )
      )
    })

    shiny::observeEvent(input$remove_card_ok, {
      reporter$remove_cards(input$card_remove_id)
      shiny::removeModal()
    })

    shiny::observeEvent(input$card_up_id, {
      if (input$card_up_id > 1) {
        reporter$swap_cards(
          as.integer(input$card_up_id),
          as.integer(input$card_up_id - 1)
        )
      }
    })

    shiny::observeEvent(input$card_down_id, {
      if (input$card_down_id < length(reporter$get_cards())) {
        reporter$swap_cards(
          as.integer(input$card_down_id),
          as.integer(input$card_down_id + 1)
        )
      }
    })

    output$download_data_prev <- shiny::downloadHandler(
      filename = function() {
        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_prev"), text = "", type = "dots")
        input_list <- lapply(names(rmd_yaml_args), function(x) input[[x]])
        names(input_list) <- names(rmd_yaml_args)
        if (is.logical(input$showrcode)) global_knitr[["echo"]] <- input$showrcode
        report_render_and_compress(reporter, input_list, global_knitr, file)
        shinybusy::unblock(id = ns("download_data_prev"))
      },
      contentType = "application/zip"
    )
  })
}

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

#' @noRd
#' @keywords internal
add_previewer_css <- function() {
  shiny::tagList(
    shiny::singleton(
      shiny::tags$head(shiny::includeCSS(system.file("css/Previewer.css", package = "teal.reporter")))
    ),
    shiny::singleton(
      shiny::tags$head(shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter")))
    )
  )
}

#' @noRd
#' @keywords internal
add_previewer_js <- function(ns) {
  shiny::singleton(
    shiny::tags$head(shiny::tags$script(
      shiny::HTML(sprintf('
          $(document).ready(function(event) {
            $("body").on("click", "span.card_remove_id", function() {
              let val = $(this).data("cardid");
              Shiny.setInputValue("%s", val, {priority: "event"});
            });

            $("body").on("click", "span.card_up_id", function() {
              let val = $(this).data("cardid");
              Shiny.setInputValue("%s", val, {priority: "event"});
            });

             $("body").on("click", "span.card_down_id", function() {
              let val = $(this).data("cardid");
              Shiny.setInputValue("%s", val, {priority: "event"});
             });
          });
         ', ns("card_remove_id"), ns("card_up_id"), ns("card_down_id")))
    ))
  )
}

#' @noRd
#' @keywords internal
nav_previewer_icon <- function(name, icon_name, idx, size = 1L) {
  checkmate::assert_string(name)
  checkmate::assert_string(icon_name)
  checkmate::assert_int(size)

  shiny::tags$span(
    class = paste(name, "icon_previewer"),
    # data field needed to record clicked card on the js side
    `data-cardid` = idx,
    shiny::icon(icon_name, sprintf("fa-%sx", size))
  )
}

#' @noRd
#' @keywords internal
nav_previewer_icons <- function(idx, size = 1L) {
  shiny::tags$span(
    class = "preview_card_control",
    nav_previewer_icon(name = "card_remove_id", icon_name = "xmark", idx = idx, size = size),
    nav_previewer_icon(name = "card_up_id", icon_name = "arrow-up", idx = idx, size = size),
    nav_previewer_icon(name = "card_down_id", icon_name = "arrow-down", idx = idx, size = size)
  )
}

#' @noRd
#' @keywords internal
previewer_collapse_item <- function(idx, card_name, card_blocks) {
  shiny::tags$div(.renderHook = function(x) {
    # get bs version
    version <- get_bs_version()

    if (version == "3") {
      shiny::tags$div(
        id = paste0("panel_card_", idx),
        class = "panel panel-default",
        shiny::tags$div(
          class = "panel-heading overflow-auto",
          shiny::tags$div(
            class = "panel-title",
            shiny::tags$span(
              nav_previewer_icons(idx = idx),
              shiny::tags$a(
                class = "accordion-toggle block py-3 px-4 -my-3 -mx-4",
                `data-toggle` = "collapse",
                `data-parent` = "#reporter_previewer_panel",
                href = paste0("#collapse", idx),
                shiny::tags$h4(paste0("Card ", idx, ": ", card_name), shiny::icon("caret-down"))
              )
            )
          )
        ),
        shiny::tags$div(
          id = paste0("collapse", idx), class = "collapse out",
          shiny::tags$div(
            class = "panel-body",
            shiny::tags$div(
              id = paste0("card", idx),
              lapply(
                card_blocks,
                function(b) {
                  block_to_html(b)
                }
              )
            )
          )
        )
      )
    } else {
      shiny::tags$div(
        id = paste0("panel_card_", idx),
        class = "card",
        shiny::tags$div(
          class = "overflow-auto",
          shiny::tags$div(
            class = "card-header",
            shiny::tags$span(
              nav_previewer_icons(idx = idx),
              shiny::tags$a(
                class = "accordion-toggle block py-3 px-4 -my-3 -mx-4",
                # bs4
                `data-toggle` = "collapse",
                # bs5
                `data-bs-toggle` = "collapse",
                href = paste0("#collapse", idx),
                shiny::tags$h4(
                  paste0("Card ", idx, ": ", card_name),
                  shiny::icon("caret-down")
                )
              )
            )
          )
        ),
        shiny::tags$div(
          id = paste0("collapse", idx),
          class = "collapse out",
          # bs4
          `data-parent` = "#reporter_previewer_panel",
          # bs5
          `data-bs-parent` = "#reporter_previewer_panel",
          shiny::tags$div(
            class = "card-body",
            shiny::tags$div(
              id = paste0("card", idx),
              lapply(
                card_blocks,
                function(b) {
                  block_to_html(b)
                }
              )
            )
          )
        )
      )
    }
  })
}

#' Simple reporter module
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Module provides compact UI and server functions for managing a report in a `shiny` app.
#' This module combines functionalities for [adding cards to a report][add_card_button],
#'  [downloading the report][download_report_button], and [resetting report content][reset_report_button].
#'
#' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`.
#'
#' @details `r global_knitr_details()`
#'
#' @name simple_reporter
#'
#' @param id (`character(1)`) `shiny` module instance id.
#' @param reporter (`Reporter`) instance.
#' @param card_fun (`function`) which returns a [`ReportCard`] instance,
#' the function has a `card` argument and an optional `comment` argument.
#' @param global_knitr (`list`) a global `knitr` parameters for customizing the rendering process.
#' @inheritParams reporter_download_inputs
#'
#' @return `NULL`.
#'
#' @examples
#' 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(
    shiny::singleton(
      shiny::tags$head(shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter")))
    ),
    shiny::tags$div(
      class = "block mb-4 p-1",
      shiny::tags$label(class = "text-primary block -ml-1", shiny::tags$strong("Reporter")),
      shiny::tags$div(
        class = "simple_reporter_container",
        add_card_button_ui(ns("add_report_card_simple")),
        download_report_button_ui(ns("download_button_simple")),
        report_load_ui(ns("archive_load_simple")),
        reset_report_button_ui(ns("reset_button_simple"))
      )
    )
  )
}

#' @rdname simple_reporter
#' @export
simple_reporter_srv <- function(
    id,
    reporter,
    card_fun,
    global_knitr = getOption("teal.reporter.global_knitr"),
    rmd_output = c(
      "html" = "html_document", "pdf" = "pdf_document",
      "powerpoint" = "powerpoint_presentation", "word" = "word_document"
    ),
    rmd_yaml_args = list(
      author = "NEST", title = "Report",
      date = as.character(Sys.Date()), output = "html_document",
      toc = FALSE
    )) {
  shiny::moduleServer(
    id,
    function(input, output, session) {
      add_card_button_srv("add_report_card_simple", reporter = reporter, card_fun = card_fun)
      download_report_button_srv(
        "download_button_simple",
        reporter = reporter,
        global_knitr = global_knitr,
        rmd_output = rmd_output,
        rmd_yaml_args = rmd_yaml_args
      )
      report_load_srv("archive_load_simple", reporter = reporter)
      reset_report_button_srv("reset_button_simple", reporter = reporter)
    }
  )
}

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

#' @rdname reset_report_button
#' @export
reset_report_button_ui <- function(id, label = NULL) {
  checkmate::assert_string(label, null.ok = TRUE)

  ns <- shiny::NS(id)
  shiny::tagList(
    shiny::singleton(
      shiny::tags$head(shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter")))
    ),
    shiny::tags$button(
      id = ns("reset_reporter"),
      type = "button",
      class = "simple_report_button btn btn-warning action-button",
      title = "Reset",
      `data-val` = shiny::restoreInput(id = ns("reset_reporter"), default = NULL),
      NULL,
      shiny::tags$span(
        if (!is.null(label)) label,
        shiny::icon("xmark")
      )
    )
  )
}

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

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

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


    shiny::observeEvent(input$reset_reporter, {
      shiny::showModal(
        shiny::modalDialog(
          shiny::tags$h3("Reset the Report"),
          shiny::tags$hr(),
          shiny::tags$strong(
            shiny::tags$p(
              "Are you sure you want to reset the report? (This will remove ALL previously added cards)."
            )
          ),
          footer = shiny::tagList(
            shiny::tags$button(
              type = "button",
              class = "btn btn-secondary",
              `data-dismiss` = "modal",
              `data-bs-dismiss` = "modal",
              NULL,
              "Cancel"
            ),
            shiny::actionButton(ns("reset_reporter_ok"), "Reset", class = "btn-danger")
          )
        )
      )
    })

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

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

      if (missing(yaml_header)) {
        yaml_header <- md_header(yaml::as.yaml(list(title = "Report")))
      }

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

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

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

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

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

#' @rdname add_card_button
#' @export
add_card_button_ui <- function(id) {
  ns <- shiny::NS(id)

  # Buttons with custom css and
  # js code to disable the add card button when clicked to prevent multi-clicks
  shiny::tagList(
    shiny::singleton(
      shiny::tags$head(shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter")))
    ),
    shiny::singleton(
      shiny::tags$head(
        shiny::tags$script(
          shiny::HTML(
            sprintf(
              '
              $(document).ready(function(event) {
                $("body").on("click", "#%s", function() {
                  $(this).addClass("disabled");
                })
              })',
              ns("add_card_ok")
            )
          )
        )
      )
    ),
    shiny::tags$button(
      id = ns("add_report_card_button"),
      type = "button",
      class = "simple_report_button btn btn-primary action-button",
      title = "Add Card",
      `data-val` = shiny::restoreInput(id = ns("add_report_card_button"), default = NULL),
      NULL,
      shiny::tags$span(
        shiny::icon("plus")
      )
    )
  )
}

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

  shiny::moduleServer(id, function(input, output, session) {
    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::modalDialog(
        easyClose = TRUE,
        shiny::tags$h3("Add a Card to the Report"),
        shiny::tags$hr(),
        shiny::textInput(
          ns("label"),
          "Card Name",
          value = "",
          placeholder = "Add the card title here",
          width = "100%"
        ),
        shiny::textAreaInput(
          ns("comment"),
          "Comment",
          value = "",
          placeholder = "Add a comment here...",
          width = "100%"
        ),
        shiny::tags$script(
          shiny::HTML(
            sprintf(
              "
                $('#shiny-modal').on('shown.bs.modal', () => {
                  $('#%s').focus()
                })
                ",
              ns("label")
            )
          )
        ),
        footer = shiny::div(
          shiny::tags$button(
            type = "button",
            class = "btn btn-secondary",
            `data-dismiss` = "modal",
            `data-bs-dismiss` = "modal",
            NULL,
            "Cancel"
          ),
          shiny::tags$button(
            id = ns("add_card_ok"),
            type = "button",
            class = "btn btn-primary action-button",
            `data-val` = shiny::restoreInput(id = ns("add_card_ok"), default = NULL),
            NULL,
            "Add Card"
          )
        )
      )
    }

    shiny::observeEvent(input$add_report_card_button, {
      shiny::showModal(add_modal())
    })

    # the add card button is disabled when clicked to prevent multi-clicks
    # please check the ui part for more information
    shiny::observeEvent(input$add_card_ok, {
      card_fun_args_nams <- names(formals(card_fun))
      has_card_arg <- "card" %in% card_fun_args_nams
      has_comment_arg <- "comment" %in% card_fun_args_nams
      has_label_arg <- "label" %in% card_fun_args_nams

      arg_list <- list()

      if (has_comment_arg) {
        arg_list <- c(arg_list, list(comment = input$comment))
      }
      if (has_label_arg) {
        arg_list <- c(arg_list, list(label = input$label))
      }

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

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

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

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

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

.onLoad <- function(libname, pkgname) {
  op <- options()
  default_global_knitr <- list(teal.reporter.global_knitr = list(
    echo = TRUE,
    tidy.opts = list(width.cutoff = 60),
    tidy = requireNamespace("formatR", quietly = TRUE)
  ))

  if (!("teal.reporter.global_knitr" %in% names(op))) {
    options(default_global_knitr)
  }

  invisible()
}

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

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

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

#' @rdname download_report_button
#' @export
download_report_button_ui <- function(id) {
  ns <- shiny::NS(id)
  shiny::tagList(
    shiny::singleton(
      shiny::tags$head(shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter")))
    ),
    shiny::tags$button(
      id = ns("download_button"),
      type = "button",
      class = "simple_report_button btn btn-primary action-button",
      title = "Download",
      `data-val` = shiny::restoreInput(id = ns("download_button"), default = NULL),
      NULL,
      shiny::tags$span(
        shiny::icon("download")
      )
    )
  )
}

#' @rdname download_report_button
#' @export
download_report_button_srv <- function(id,
                                       reporter,
                                       global_knitr = getOption("teal.reporter.global_knitr"),
                                       rmd_output = c(
                                         "html" = "html_document", "pdf" = "pdf_document",
                                         "powerpoint" = "powerpoint_presentation", "word" = "word_document"
                                       ),
                                       rmd_yaml_args = list(
                                         author = "NEST", title = "Report",
                                         date = as.character(Sys.Date()), output = "html_document",
                                         toc = FALSE
                                       )) {
  checkmate::assert_class(reporter, "Reporter")
  checkmate::assert_subset(names(global_knitr), names(knitr::opts_chunk$get()))
  checkmate::assert_subset(
    rmd_output,
    c(
      "html_document", "pdf_document",
      "powerpoint_presentation", "word_document"
    ),
    empty.ok = FALSE
  )
  checkmate::assert_list(rmd_yaml_args, names = "named")
  checkmate::assert_names(
    names(rmd_yaml_args),
    subset.of = c("author", "title", "date", "output", "toc"),
    must.include = "output"
  )
  checkmate::assert_true(rmd_yaml_args[["output"]] %in% rmd_output)

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

    ns <- session$ns

    download_modal <- function() {
      nr_cards <- length(reporter$get_cards())
      downb <- shiny::tags$a(
        id = ns("download_data"),
        class = paste("btn btn-primary shiny-download-link", if (nr_cards) NULL else "disabled"),
        style = if (nr_cards) NULL else "pointer-events: none;",
        href = "",
        target = "_blank",
        download = NA,
        shiny::icon("download"),
        "Download"
      )
      shiny::modalDialog(
        easyClose = TRUE,
        shiny::tags$h3("Download the Report"),
        shiny::tags$hr(),
        if (length(reporter$get_cards()) == 0) {
          shiny::tags$div(
            class = "mb-4",
            shiny::tags$p(
              class = "text-danger",
              shiny::tags$strong("No Cards Added")
            )
          )
        } else {
          shiny::tags$div(
            class = "mb-4",
            shiny::tags$p(
              class = "text-success",
              shiny::tags$strong(paste("Number of cards: ", nr_cards))
            ),
          )
        },
        reporter_download_inputs(
          rmd_yaml_args = rmd_yaml_args,
          rmd_output = rmd_output,
          showrcode = any_rcode_block(reporter),
          session = session
        ),
        footer = shiny::tagList(
          shiny::tags$button(
            type = "button",
            class = "btn btn-secondary",
            `data-dismiss` = "modal",
            `data-bs-dismiss` = "modal",
            NULL,
            "Cancel"
          ),
          downb
        )
      )
    }

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

    output$download_data <- shiny::downloadHandler(
      filename = function() {
        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 `FileBlock`
#' @docType class
#' @description
#' `FileBlock` manages file-based content in a report,
#'  ensuring appropriate handling of content files.
#'
#' @keywords internal
FileBlock <- R6::R6Class( # nolint: object_name_linter.
  classname = "FileBlock",
  inherit = ContentBlock,
  public = list(
    #' @description Finalize the `FileBlock`.
    #'
    #' @details Removes the temporary file created in the constructor.
    finalize = function() {
      try(unlink(super$get_content()))
    },
    #' @description Create the `FileBlock` from a list.
    #' The list should contain one named field, `"basename"`.
    #'
    #' @param x (`named list`) with one field `"basename"`, a name of the file.
    #' @param output_dir (`character`) with a path to the directory where a file will be copied.
    #'
    #' @return `self`, invisibly.
    #' @examples
    #' FileBlock <- getFromNamespace("FileBlock", "teal.reporter")
    #' block <- FileBlock$new()
    #' file_path <- tempfile(fileext = ".png")
    #' saveRDS(iris, file_path)
    #' block$from_list(list(basename = basename(file_path)), dirname(file_path))
    #'
    from_list = function(x, output_dir) {
      checkmate::assert_list(x)
      checkmate::assert_names(names(x), must.include = "basename")
      path <- file.path(output_dir, x$basename)
      file_type <- paste0(".", tools::file_ext(path))
      checkmate::assert_file_exists(path, extension = file_type)
      new_file_path <- tempfile(fileext = file_type)
      file.copy(path, new_file_path)
      super$set_content(new_file_path)
      invisible(self)
    },
    #' @description Convert the `FileBlock` to a list.
    #'
    #' @param output_dir (`character`) with a path to the directory where a file will be copied.
    #'
    #' @return `named list` with a `basename` of the file.
    #' @examples
    #' FileBlock <- getFromNamespace("FileBlock", "teal.reporter")
    #' block <- FileBlock$new()
    #' block$to_list(tempdir())
    #'
    to_list = function(output_dir) {
      base_name <- basename(super$get_content())
      file.copy(super$get_content(), file.path(output_dir, base_name))
      list(basename = base_name)
    }
  ),
  lock_objects = TRUE,
  lock_class = TRUE
)

#' @title `ReportCard`: An `R6` class for building report elements
#' @docType class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This `R6` class that supports creating a report card containing text, plot, table and
#' metadata blocks that can be appended and rendered to form a report output from a `shiny` app.
#'
#' @export
#'
ReportCard <- R6::R6Class( # nolint: object_name_linter.
  classname = "ReportCard",
  public = list(
    #' @description Initialize a `ReportCard` object.
    #'
    #' @return Object of class `ReportCard`, invisibly.
    #' @examples
    #' card <- ReportCard$new()
    #'
    initialize = function() {
      private$content <- list()
      private$metadata <- list()
      invisible(self)
    },
    #' @description Appends a table to this `ReportCard`.
    #'
    #' @param table A (`data.frame` or `rtables` or `TableTree` or `ElementaryTable` or `listing_df`)
    #' that can be coerced into a table.
    #' @return `self`, invisibly.
    #' @examples
    #' card <- ReportCard$new()$append_table(iris)
    #'
    append_table = function(table) {
      self$append_content(TableBlock$new(table))
      invisible(self)
    },
    #' @description Appends a plot to this `ReportCard`.
    #'
    #' @param plot (`ggplot` or `grob` or `trellis`) plot object.
    #' @param dim (`numeric(2)`) width and height in pixels.
    #' @return `self`, invisibly.
    #' @examples
    #' library(ggplot2)
    #'
    #' card <- ReportCard$new()$append_plot(
    #'   ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
    #' )
    #'
    append_plot = function(plot, dim = NULL) {
      pb <- PictureBlock$new()
      if (!is.null(dim) && length(dim) == 2) {
        pb$set_dim(dim)
      }
      pb$set_content(plot)
      self$append_content(pb)
      invisible(self)
    },
    #' @description Appends a text paragraph to this `ReportCard`.
    #'
    #' @param text (`character`) The text content to add.
    #' @param style (`character(1)`) the style of the paragraph. One of: `default`, `header`, `verbatim`
    #' @return `self`, invisibly.
    #' @examples
    #' card <- ReportCard$new()$append_text("A paragraph of default text")
    #'
    append_text = function(text, style = TextBlock$new()$get_available_styles()[1]) {
      self$append_content(TextBlock$new(text, style))
      invisible(self)
    },
    #' @description Appends an `R` code chunk to `ReportCard`.
    #'
    #' @param text (`character`) The `R` code to include.
    #' @param ... Additional  `rmarkdown` parameters for formatting the `R` code chunk.
    #' @return `self`, invisibly.
    #' @examples
    #' card <- ReportCard$new()$append_rcode("2+2", echo = FALSE)
    #'
    append_rcode = function(text, ...) {
      self$append_content(RcodeBlock$new(text, ...))
      invisible(self)
    },
    #' @description Appends a generic `ContentBlock` to this `ReportCard`.
    #'
    #' @param content (`ContentBlock`) object.
    #' @return `self`, invisibly.
    #' @examples
    #' NewpageBlock <- getFromNamespace("NewpageBlock", "teal.reporter")
    #' card <- ReportCard$new()$append_content(NewpageBlock$new())
    #'
    append_content = function(content) {
      checkmate::assert_class(content, "ContentBlock")
      private$content <- append(private$content, content)
      invisible(self)
    },
    #' @description Get all content blocks from this `ReportCard`.
    #'
    #' @return `list()` list of `TableBlock`, `TextBlock` and `PictureBlock`.
    #' @examples
    #' card <- ReportCard$new()$append_text("Some text")$append_metadata("rc", "a <- 2 + 2")
    #'
    #' card$get_content()
    #'
    #'
    get_content = function() {
      private$content
    },
    #' @description Clears all content and metadata from `ReportCard`.
    #'
    #' @return `self`, invisibly.
    #'
    reset = function() {
      private$content <- list()
      private$metadata <- list()
      invisible(self)
    },
    #' @description Get the metadata associated with `ReportCard`.
    #'
    #' @return `named list` list of elements.
    #' @examples
    #' card <- ReportCard$new()$append_text("Some text")$append_metadata("rc", "a <- 2 + 2")
    #'
    #' card$get_metadata()
    #'
    get_metadata = function() {
      private$metadata
    },
    #' @description Appends metadata to this `ReportCard`.
    #'
    #' @param key (`character(1)`) string specifying the metadata key.
    #' @param value value associated with the metadata key.
    #' @return `self`, invisibly.
    #' @examples
    #' library(ggplot2)
    #'
    #' card <- ReportCard$new()$append_text("Some text")$append_plot(
    #'   ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
    #' )$append_text("Some text")$append_metadata(key = "lm",
    #'                   value = lm(Ozone ~ Solar.R, airquality))
    #' card$get_content()
    #' card$get_metadata()
    #'
    append_metadata = function(key, value) {
      checkmate::assert_character(key, min.len = 0, max.len = 1)
      checkmate::assert_false(key %in% names(private$metadata))
      meta_list <- list()
      meta_list[[key]] <- value
      private$metadata <- append(private$metadata, meta_list)
      invisible(self)
    },
    #' @description Get the name of the `ReportCard`.
    #'
    #' @return `character` a card name.
    #' @examples
    #' ReportCard$new()$set_name("NAME")$get_name()
    get_name = function() {
      private$name
    },
    #' @description Set the name of the `ReportCard`.
    #'
    #' @param name (`character(1)`) a card name.
    #' @return `self`, invisibly.
    #' @examples
    #' ReportCard$new()$set_name("NAME")$get_name()
    set_name = function(name) {
      checkmate::assert_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.
    #' @examples
    #' library(ggplot2)
    #'
    #' card <- ReportCard$new()$append_text("Some text")$append_plot(
    #'   ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
    #' )$append_text("Some text")$append_metadata(key = "lm",
    #'                   value = lm(Ozone ~ Solar.R, airquality))
    #' card$get_content()
    #'
    #' card$to_list(tempdir())
    #'
    to_list = function(output_dir) {
      new_blocks <- list()
      for (block in self$get_content()) {
        block_class <- class(block)[1]
        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.
    #' @examples
    #' library(ggplot2)
    #'
    #' card <- ReportCard$new()$append_text("Some text")$append_plot(
    #'   ggplot(iris, aes(x = Petal.Length)) + geom_histogram()
    #' )$append_text("Some text")$append_metadata(key = "lm",
    #'                   value = lm(Ozone ~ Solar.R, airquality))
    #' card$get_content()
    #'
    #' ReportCard$new()$from_list(card$to_list(tempdir()), tempdir())
    #'
    from_list = function(card, output_dir) {
      self$reset()
      blocks <- card$blocks
      metadata <- card$metadata
      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
)

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

#' Get bootstrap current version
#' @note will work properly mainly inside a tag `.renderHook`
#' @keywords internal
get_bs_version <- function() {
  theme <- bslib::bs_current_theme()
  if (bslib::is_bs_theme(theme)) {
    bslib::theme_version(theme)
  } else {
    "3"
  }
}

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

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


  shiny::tags$div(.renderHook = function(res_tag) {
    bs_version <- get_bs_version()

    # alter tag structure
    if (bs_version == "3") {
      res_tag$children <- list(
        shiny::tags$div(
          class = "panel panel-default",
          shiny::tags$div(
            id = div_id,
            class = paste("panel-heading", ifelse(collapsed, "collapsed", "")),
            `data-toggle` = "collapse",
            href = paste0("#", panel_id),
            `aria-expanded` = ifelse(collapsed, "false", "true"),
            shiny::icon("angle-down", class = "dropdown-icon"),
            shiny::tags$label(
              class = "panel-title inline",
              title,
            )
          ),
          shiny::tags$div(
            class = paste("panel-collapse collapse", ifelse(collapsed, "", "in")),
            id = panel_id,
            shiny::tags$div(
              class = "panel-body",
              ...
            )
          )
        )
      )
    } else if (bs_version %in% c("4", "5")) {
      res_tag$children <- list(
        shiny::tags$div(
          class = "card my-2",
          shiny::tags$div(
            class = "card-header",
            shiny::tags$div(
              class = ifelse(collapsed, "collapsed", ""),
              # bs4
              `data-toggle` = "collapse",
              # bs5
              `data-bs-toggle` = "collapse",
              href = paste0("#", panel_id),
              `aria-expanded` = ifelse(collapsed, "false", "true"),
              shiny::icon("angle-down", class = "dropdown-icon"),
              shiny::tags$label(
                class = "card-title inline",
                title,
              )
            )
          ),
          shiny::tags$div(
            id = panel_id,
            class = paste("collapse", ifelse(collapsed, "", "show")),
            shiny::tags$div(
              class = "card-body",
              ...
            )
          )
        )
      )
    } else {
      stop("Bootstrap 3, 4, and 5 are supported.")
    }

    shiny::tagList(
      shiny::singleton(
        shiny::tags$head(
          shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter"))
        )
      ),
      res_tag
    )
  })
}

#' Convert content into a `flextable`
#'
#' Converts supported table formats into a `flextable` for enhanced formatting and presentation.
#'
#' Function merges cells with `colspan` > 1,
#' aligns columns to the center and row names to the left,
#' indents the row names by 10 times indentation.
#'
#' @param content Supported formats: `data.frame`, `rtables`, `TableTree`, `ElementaryTable`, `listing_df`
#'
#' @return `flextable`.
#'
#' @keywords internal
to_flextable <- function(content) {
  if (inherits(content, c("rtables", "TableTree", "ElementaryTable"))) {
    ft <- rtables::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::tt_to_flextable(ft, total_width = c(grDevices::pdf.options()$width - 1))
  } else if (inherits(content, "data.frame")) {
    ft <- rtables::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]
  }
  return(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"
  )
}

#' User Interface to Load `Reporter`
#' @description `r lifecycle::badge("experimental")`
#' Button to upload `ReporterCard`(s) to the `Reporter`.
#'
#' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`.
#' @param id `character(1)` this `shiny` module's id.
#' @return `shiny::tagList`
#' @export
report_load_ui <- function(id) {
  ns <- shiny::NS(id)

  shiny::tagList(
    shiny::singleton(
      shiny::tags$head(shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter")))
    ),
    shiny::tags$button(
      id = ns("reporter_load"),
      type = "button",
      class = "simple_report_button btn btn-primary action-button",
      title = "Load",
      NULL,
      shiny::tags$span(
        shiny::icon("upload")
      )
    )
  )
}

#' Server to Load `Reporter`
#' @description `r lifecycle::badge("experimental")`
#' Server to load `ReporterCard`(s) to the `Reporter`
#'
#' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`.
#'
#' @param id `character(1)` this `shiny` module's id.
#' @param reporter [`Reporter`] instance.
#'
#' @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::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-danger",
              `data-dismiss` = "modal",
              `data-bs-dismiss` = "modal",
              NULL,
              "Cancel"
            ),
            shiny::tags$button(
              id = ns("reporter_load_main"),
              type = "button",
              class = "btn btn-primary action-button",
              NULL,
              "Load"
            )
          )
        )
      }

      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("Failed to load the Reporter file.", type = "error")
  }
}

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

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

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

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

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

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

1		#' User Interface to Load `Reporter`
2		#' @description `r lifecycle::badge("experimental")`
3		#' Button to upload `ReporterCard`(s) to the `Reporter`.
4		#'
5		#' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`.
6		#' @param id `character(1)` this `shiny` module's id.
7		#' @return `shiny::tagList`
8		#' @export
9		report_load_ui <- function(id) {
10	2x	ns <- shiny::NS(id)
11
12	2x	shiny::tagList(
13	2x	shiny::singleton(
14	2x	shiny::tags$head(shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter")))
15		),
16	2x	shiny::tags$button(
17	2x	id = ns("reporter_load"),
18	2x	type = "button",
19	2x	class = "simple_report_button btn btn-primary action-button",
20	2x	title = "Load",
21	2x	NULL,
22	2x	shiny::tags$span(
23	2x	shiny::icon("upload")
24		)
25		)
26		)
27		}
28
29		#' Server to Load `Reporter`
30		#' @description `r lifecycle::badge("experimental")`
31		#' Server to load `ReporterCard`(s) to the `Reporter`
32		#'
33		#' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`.
34		#'
35		#' @param id `character(1)` this `shiny` module's id.
36		#' @param reporter [`Reporter`] instance.
37		#'
38		#' @return `shiny::moduleServer`
39		#' @export
40		report_load_srv <- function(id, reporter) {
41	5x	checkmate::assert_class(reporter, "Reporter")
42
43	5x	shiny::moduleServer(
44	5x	id,
45	5x	function(input, output, session) {
46	5x	shiny::setBookmarkExclude(c("reporter_load_main", "reporter_load"))
47	5x	ns <- session$ns
48
49	5x	archiver_modal <- function() {
50	2x	nr_cards <- length(reporter$get_cards())
51	2x	shiny::modalDialog(
52	2x	easyClose = TRUE,
53	2x	shiny::tags$h3("Load the Report"),
54	2x	shiny::tags$hr(),
55	2x	shiny::fileInput(ns("archiver_zip"), "Choose saved Reporter file to Load (a zip file)",
56	2x	multiple = FALSE,
57	2x	accept = c(".zip")
58		),
59	2x	footer = shiny::div(
60	2x	shiny::tags$button(
61	2x	type = "button",
62	2x	class = "btn btn-danger",
63	2x	`data-dismiss` = "modal",
64	2x	`data-bs-dismiss` = "modal",
65	2x	NULL,
66	2x	"Cancel"
67		),
68	2x	shiny::tags$button(
69	2x	id = ns("reporter_load_main"),
70	2x	type = "button",
71	2x	class = "btn btn-primary action-button",
72	2x	NULL,
73	2x	"Load"
74		)
75		)
76		)
77		}
78
79	5x	shiny::observeEvent(input$reporter_load, {
80	2x	shiny::showModal(archiver_modal())
81		})
82
83	5x	shiny::observeEvent(input$reporter_load_main, {
84	2x	load_json_report(reporter, input$archiver_zip[["datapath"]], input$archiver_zip[["name"]])
85	2x	shiny::removeModal()
86		})
87		}
88		)
89		}
90
91		#' @keywords internal
92		load_json_report <- function(reporter, zip_path, filename) {
93	2x	tmp_dir <- tempdir()
94	2x	output_dir <- file.path(tmp_dir, sprintf("report_load_%s", gsub("[.]", "", format(Sys.time(), "%Y%m%d%H%M%OS4"))))
95	2x	dir.create(path = output_dir)
96	2x	if (!is.null(zip_path) && grepl("report_", filename)) {
97	2x	tryCatch(
98	2x	expr = zip::unzip(zip_path, exdir = output_dir, junkpaths = TRUE),
99	2x	warning = function(cond) {
100	!	print(cond)
101	!	shiny::showNotification(
102	!	ui = "Unzipping folder warning!",
103	!	action = "Please contact app developer",
104	!	type = "warning"
105		)
106		},
107	2x	error = function(cond) {
108	!	print(cond)
109	!	shiny::showNotification(
110	!	ui = "Unzipping folder error!",
111	!	action = "Please contact app developer",
112	!	type = "error"
113		)
114		}
115		)
116	2x	tryCatch(
117	2x	reporter$from_jsondir(output_dir),
118	2x	warning = function(cond) {
119	!	print(cond)
120	!	shiny::showNotification(
121	!	ui = "Loading reporter warning!",
122	!	action = "Please contact app developer",
123	!	type = "warning"
124		)
125		},
126	2x	error = function(cond) {
127	1x	print(cond)
128	1x	shiny::showNotification(
129	1x	ui = "Loading reporter error!",
130	1x	action = "Please contact app developer",
131	1x	type = "error"
132		)
133		}
134		)
135		} else {
136	!	shiny::showNotification("Failed to load the Reporter file.", type = "error")
137		}
138		}

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 `r lifecycle::badge("experimental")`
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	18x	rmarkdown_namespace <- asNamespace("rmarkdown")
99	18x	ls(rmarkdown_namespace)[grep("_document\|_presentation", ls(rmarkdown_namespace))]
100		}
101
102		#' Get document output arguments from the `rmarkdown` package
103		#'
104		#' @description `r lifecycle::badge("experimental")`
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	17x	checkmate::assert_string(output_name)
116	17x	checkmate::assert_subset(output_name, rmd_outputs())
117
118	16x	rmarkdown_namespace <- asNamespace("rmarkdown")
119	16x	if (default_values) {
120	14x	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 `r lifecycle::badge("experimental")`
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	11x	for (dtype in doc_types) {
233	12x	doc_type_args <- rmd_output_arguments(dtype, TRUE)
234	12x	doc_type_args_nams <- names(doc_type_args)
235	12x	any_output_arg <- any(input_nams %in% doc_type_args_nams)
236
237	12x	not_found_args <- setdiff(input_nams, c(doc_type_args_nams, top_fields, "output"))
238	12x	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	12x	if (any_output_arg) {
243	11x	doc_list <- list()
244	11x	doc_list[[dtype]] <- list()
245	11x	for (e in intersect(input_nams, doc_type_args_nams)) {
246	17x	if (is.logical(doc_type_args[[e]]) && is.character(input_list[[e]])) {
247	1x	pos_logi <- c("TRUE", "true", "True", "yes", "y", "Y", "on")
248	1x	neg_logi <- c("FALSE", "false", "False", "no", "n", "N", "off")
249	1x	all_logi <- c(pos_logi, neg_logi)
250	1x	if (input_list[[e]] %in% all_logi && convert_logi) {
251	1x	input_list[[e]] <- conv_str_logi(input_list[[e]], e,
252	1x	pos_logi = pos_logi,
253	1x	neg_logi = neg_logi, silent = silent
254		)
255		}
256		}
257
258	17x	doc_list[[dtype]][[e]] <- input_list[[e]]
259		}
260	11x	result[["output"]] <- append(result[["output"]], doc_list)
261		} else {
262	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		#' `r lifecycle::badge("experimental")`
278		#'
279		#' @param x (`rmd_yaml_header`) class object.
280		#' @param ... optional text.
281		#' @return `NULL`.
282		#' @exportS3Method
283		#' @examples
284		#' input <- list(author = "", output = "pdf_document", toc = TRUE, keep_tex = TRUE)
285		#' out <- as_yaml_auto(input)
286		#' out
287		#' print(out)
288		print.rmd_yaml_header <- function(x, ...) {
289	!	cat(x, ...)
290		}
291
292		#' Extract field from `yaml` text
293		#'
294		#' Parses `yaml` text, extracting the specified field. Returns list names if it's a list;
295		#' otherwise, the field itself.
296		#'
297		#' @param yaml_text (`rmd_yaml_header` or `character`) vector containing the `yaml` text.
298		#' @param field_name (`character`) the name of the field to extract.
299		#'
300		#' @return If the field is a list, it returns the names of elements in the list; otherwise,
301		#' it returns the extracted field.
302		#'
303		#' @keywords internal
304		get_yaml_field <- function(yaml_text, field_name) {
305	8x	checkmate::assert_multi_class(yaml_text, c("rmd_yaml_header", "character"))
306	8x	checkmate::assert_string(field_name)
307
308	8x	yaml_obj <- yaml::yaml.load(yaml_text)
309
310	8x	result <- yaml_obj[[field_name]]
311	8x	if (is.list(result)) {
312	5x	result <- names(result)
313		}
314	8x	result
315		}

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

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

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

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

1		.onLoad <- function(libname, pkgname) {
2	!	op <- options()
3	!	default_global_knitr <- list(teal.reporter.global_knitr = list(
4	!	echo = TRUE,
5	!	tidy.opts = list(width.cutoff = 60),
6	!	tidy = requireNamespace("formatR", quietly = TRUE)
7		))
8
9	!	if (!("teal.reporter.global_knitr" %in% names(op))) {
10	!	options(default_global_knitr)
11		}
12
13	!	invisible()
14		}
15
16		.onAttach <- function(libname, pkgname) {
17	2x	packageStartupMessage(
18	2x	if (!requireNamespace("formatR", quietly = TRUE)) {
19	!	"For better code formatting, consider installing the formatR package."
20		}
21		)
22		}

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

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

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

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	118x	super$set_content(content)
27	118x	self$set_style(style)
28	118x	invisible(self)
29		},
30		#' @description Sets the style of this `TextBlock`.
31		#'
32		#' @details The style has bearing on the rendering of this block.
33		#'
34		#' @param style (`character(1)`) one of: `"default"`, `"header2"`, `"header3"` `"verbatim"`
35		#'
36		#' @return `self`, invisibly.
37		#' @examples
38		#' TextBlock <- getFromNamespace("TextBlock", "teal.reporter")
39		#' block <- TextBlock$new()
40		#' block$set_style("header2")
41		#'
42		set_style = function(style) {
43	140x	private$style <- match.arg(style, private$styles)
44	139x	invisible(self)
45		},
46		#' @description Get the style of this `TextBlock`.
47		#'
48		#' @return `character(1)` the style of this `TextBlock`.
49		#' @examples
50		#' TextBlock <- getFromNamespace("TextBlock", "teal.reporter")
51		#' block <- TextBlock$new()
52		#' block$get_style()
53		#'
54		get_style = function() {
55	67x	private$style
56		},
57		#' @description Get available an array of styles available to this `TextBlock`.
58		#'
59		#' @return A `character` array of styles.
60		#' @examples
61		#' TextBlock <- getFromNamespace("TextBlock", "teal.reporter")
62		#' block <- TextBlock$new()
63		#' block$get_available_styles()
64		#'
65		get_available_styles = function() {
66	23x	private$styles
67		},
68		#' @description Create the `TextBlock` from a list.
69		#'
70		#' @param x (`named list`) with two fields `text` and `style`.
71		#' Use the `get_available_styles` method to get all possible styles.
72		#'
73		#' @return `self`, invisibly.
74		#' @examples
75		#' TextBlock <- getFromNamespace("TextBlock", "teal.reporter")
76		#' block <- TextBlock$new()
77		#' block$from_list(list(text = "sth", style = "default"))
78		#'
79		from_list = function(x) {
80	14x	checkmate::assert_list(x)
81	14x	checkmate::assert_names(names(x), must.include = c("text", "style"))
82	14x	self$set_content(x$text)
83	14x	self$set_style(x$style)
84	14x	invisible(self)
85		},
86		#' @description Convert the `TextBlock` to a list.
87		#'
88		#' @return `named list` with a text and style.
89		#' @examples
90		#' TextBlock <- getFromNamespace("TextBlock", "teal.reporter")
91		#' block <- TextBlock$new()
92		#' block$to_list()
93		#'
94		to_list = function() {
95	24x	list(text = self$get_content(), style = self$get_style())
96		}
97		),
98		private = list(
99		style = character(0),
100		styles = c("default", "header2", "header3", "verbatim")
101		),
102		lock_objects = TRUE,
103		lock_class = TRUE
104		)

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

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

1		#' @title `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	super$set_content(content)
25	75x	self$set_params(list(...))
26	75x	invisible(self)
27		},
28		#' @description Sets the parameters of this `RcodeBlock`.
29		#'
30		#' @details Configures `rmarkdown` chunk parameters for the `R` code block,
31		#' influencing its rendering and execution behavior.
32		#'
33		#' @param params (`list`) any `rmarkdown` R chunk parameter and its value.
34		#'
35		#' @return `self`, invisibly.
36		#' @examples
37		#' RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter")
38		#' block <- RcodeBlock$new()
39		#' block$set_params(list(echo = TRUE))
40		#'
41		set_params = function(params) {
42	133x	checkmate::assert_list(params, names = "named")
43	133x	checkmate::assert_subset(names(params), self$get_available_params())
44	133x	private$params <- params
45	133x	invisible(self)
46		},
47		#' @description Get the parameters of this `RcodeBlock`.
48		#'
49		#' @return `character` the parameters of this `RcodeBlock`.
50		#' @examples
51		#' RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter")
52		#' block <- RcodeBlock$new()
53		#' block$get_params()
54		#'
55		get_params = function() {
56	3x	private$params
57		},
58		#' @description Get available array of parameters available to this `RcodeBlock`.
59		#'
60		#' @return A `character` array of parameters.
61		#' @examples
62		#' RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter")
63		#' block <- RcodeBlock$new()
64		#' block$get_available_params()
65		#'
66		get_available_params = function() {
67	5x	names(knitr::opts_chunk$get())
68		},
69		#' @description Create the `RcodeBlock` from a list.
70		#'
71		#' @param x (`named list`) with two fields `text` and `params`.
72		#' Use the `get_available_params` method to get all possible parameters.
73		#'
74		#' @return `self`, invisibly.
75		#' @examples
76		#' RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter")
77		#' block <- RcodeBlock$new()
78		#' block$from_list(list(text = "sth", params = list()))
79		#'
80		from_list = function(x) {
81	3x	checkmate::assert_list(x)
82	3x	checkmate::assert_names(names(x), must.include = c("text", "params"))
83	3x	self$set_content(x$text)
84	3x	self$set_params(x$params)
85	3x	invisible(self)
86		},
87		#' @description Convert the `RcodeBlock` to a list.
88		#'
89		#' @return `named list` with a text and `params`.
90		#' @examples
91		#' RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter")
92		#' block <- RcodeBlock$new()
93		#' block$to_list()
94		#'
95		to_list = function() {
96	3x	list(text = self$get_content(), params = self$get_params())
97		}
98		),
99		private = list(
100		params = list()
101		),
102		lock_objects = TRUE,
103		lock_class = TRUE
104		)

1		#' @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	14x	super$set_content("\n\\newpage\n")
22	14x	invisible(self)
23		}
24		),
25		lock_objects = TRUE,
26		lock_class = TRUE
27		)

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		)