teal.reporter coverage - 84.41%

Files
Source

#' Download Button Reporter User Interface
#' @description `r lifecycle::badge("experimental")`
#' button for downloading the Report.
#'
#' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`.
#' @param id `character(1)` this `shiny` module's id.
#' @return `shiny::tagList`
#' @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")
      )
    )
  )
}

#' Download Button Server
#' @description `r lifecycle::badge("experimental")`
#' server for downloading the Report.
#'
#' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`.
#' @param id `character(1)` this `shiny` module's id.
#' @param reporter [`Reporter`] instance.
#' @inheritParams reporter_download_inputs
#' @return `shiny::moduleServer`
#' @export
download_report_button_srv <- function(id,
                                       reporter,
                                       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(
    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 = 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) {
      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() {
          paste("report_", format(Sys.time(), "%y%m%d%H%M%S"), ".zip", sep = "")
        },
        content = function(file) {
          shiny::showNotification("Rendering and Downloading the document.")
          input_list <- lapply(names(rmd_yaml_args), function(x) input[[x]])
          names(input_list) <- names(rmd_yaml_args)
          global_knitr <- list()
          if (is.logical(input$showrcode)) global_knitr <- list(echo = input$showrcode)
          report_render_and_compress(reporter, input_list, global_knitr, file)
        },
        contentType = "application/zip"
      )
    }
  )
}

#' Render the Report
#' @description 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` 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) {
      shiny::showNotification(
        ui = "Render document warning!",
        action = "Please contact app developer",
        type = "warning"
      )
    },
    error = function(cond) {
      shiny::showNotification(
        ui = "Render document error!",
        action = "Please contact app developer",
        type = "error"
      )
    }
  )

  temp_zip_file <- tempfile(fileext = ".zip")
  tryCatch(
    expr = zip::zipr(temp_zip_file, renderer$get_output_dir()),
    warning = function(cond) {
      shiny::showNotification(
        ui = "Zipping folder warning!",
        action = "Please contact app developer",
        type = "warning"
      )
    },
    error = function(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) {
      shiny::showNotification(
        ui = "Copying file warning!",
        action = "Please contact app developer",
        type = "warning"
      )
    },
    error = function(cond) {
      shiny::showNotification(
        ui = "Copying file error!",
        action = "Please contact app developer",
        type = "error"
      )
    }
  )

  rm(renderer)
  invisible(file)
}

#' Get the custom list of User Interface inputs
#' @param rmd_output `character` vector with `rmarkdown` output types,
#' by default all possible `c("pdf_document", "html_document", "powerpoint_presentation", "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 User Interface 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
      )
    }
  )
}

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

#' @title `ReportCard`
#' @description `r lifecycle::badge("experimental")`
#' R6 class that supports creating a report card containing text, plot, table and
#' meta data 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 Returns a `ReportCard` object.
    #'
    #' @return a `ReportCard` object
    #' @examples
    #' card <- ReportCard$new()
    #'
    initialize = function() {
      private$content <- list()
      private$metadata <- list()
      invisible(self)
    },
    #' @description Appends a table to this `ReportCard`.
    #'
    #' @param table the appended table
    #' @return invisibly self
    #' @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 the appended plot
    #' @param dim `integer vector` width and height in pixels.
    #' @return invisibly self
    #' @examples
    #' card <- ReportCard$new()$append_plot(
    #'   ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::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 paragraph of text to this `ReportCard`.
    #'
    #' @param text (`character(0)` or `character(1)`) the text
    #' @param style (`character(1)`) the style of the paragraph. One of: `default`, `header`, `verbatim`
    #' @return invisibly self
    #' @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 a `rmarkdown` R chunk to this `ReportCard`.
    #'
    #' @param text (`character(0)` or `character(1)`) the text
    #' @param ... any `rmarkdown` R chunk parameter and its value.
    #' @return invisibly self
    #' @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 `ContentBlock` to this `ReportCard`.
    #'
    #' @param content (`ContentBlock`)
    #' @return invisibly self
    #' @examples
    #' card <- ReportCard$new()$append_content(teal.reporter:::NewpageBlock$new())
    #'
    append_content = function(content) {
      checkmate::assert_class(content, "ContentBlock")
      private$content <- append(private$content, content)
      invisible(self)
    },
    #' @description Returns the content of 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 Removes all objects added to this `ReportCard`.
    #'
    #' @return invisibly self
    #'
    reset = function() {
      private$content <- list()
      private$metadata <- list()
      invisible(self)
    },
    #' @description Returns the metadata of this `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)`) name of meta data.
    #' @param value value of meta data.
    #' @return invisibly self
    #' @examples
    #' card <- ReportCard$new()$append_text("Some text")$append_plot(
    #'   ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::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 Card name
    #'
    #' @return `character` a Card name
    #' @examples
    #' ReportCard$new()$set_name("NAME")$get_name()
    get_name = function() {
      private$name
    },
    #' @description set the Card name
    #'
    #' @param name `character` a Card name
    #' @return invisibly self
    #' @examples
    #' ReportCard$new()$set_name("NAME")$get_name()
    set_name = function(name) {
      checkmate::assert_string(name)
      private$name <- name
      invisible(self)
    },
    #' @description Convert the `ReportCard` to a list.
    #' @param output_dir `character` with a path to the directory where files will be copied.
    #' @return `named list` a `ReportCard` representation.
    #' @examples
    #' card <- ReportCard$new()$append_text("Some text")$append_plot(
    #'   ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::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]
        cblock <- if (inherits(block, "FileBlock")) {
          block$to_list(output_dir)
        } else if (inherits(block, "ContentBlock")) {
          block$to_list()
        } else {
          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
    },
    #' @description Create the `ReportCard` from a list.
    #' @param card `named list` a `ReportCard` representation.
    #' @param output_dir `character` with a path to the directory where a file will be copied.
    #' @return invisibly self
    #' @examples
    #' card <- ReportCard$new()$append_text("Some text")$append_plot(
    #'   ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::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
      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]]
        cblock <- eval(str2lang(sprintf("%s$new()", block_class)))
        if (inherits(cblock, "FileBlock")) {
          cblock$from_list(block, output_dir)
        } else if (inherits(cblock, "ContentBlock")) {
          cblock$from_list(block)
        } else {
          NULL
        }
        self$append_content(cblock)
      }
      for (meta in names(metadata)) {
        self$append_metadata(meta, metadata[[meta]])
      }
      invisible(self)
    }
  ),
  private = list(
    content = list(),
    metadata = list(),
    name = character(0),
    # @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 `Reporter`
#' @description `r lifecycle::badge("experimental")`
#' R6 class that stores and manages report cards.
#' @export
#'
Reporter <- R6::R6Class( # nolint: object_name_linter.
  classname = "Reporter",
  public = list(
    #' @description Returns a `Reporter` object.
    #'
    #' @return a `Reporter` object
    #' @examples
    #' reporter <- teal.reporter:::Reporter$new()
    #'
    initialize = function() {
      private$cards <- list()
      private$reactive_add_card <- shiny::reactiveVal(0)
      invisible(self)
    },
    #' @description Appends a table to this `Reporter`.
    #'
    #' @param cards [`ReportCard`] or a list of such objects
    #' @return invisibly self
    #' @examples
    #' card1 <- teal.reporter:::ReportCard$new()
    #'
    #' card1$append_text("Header 2 text", "header2")
    #' card1$append_text("A paragraph of default text", "header2")
    #' card1$append_plot(
    #'  ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()
    #' )
    #'
    #' card2 <- teal.reporter:::ReportCard$new()
    #'
    #' card2$append_text("Header 2 text", "header2")
    #' card2$append_text("A paragraph of default text", "header2")
    #' lyt <- rtables::analyze(rtables::split_rows_by(rtables::basic_table(), "Day"), "Ozone", afun = mean)
    #' table_res2 <- rtables::build_table(lyt, airquality)
    #' card2$append_table(table_res2)
    #' card2$append_table(iris)
    #'
    #' reporter <- teal.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 Returns cards of this `Reporter`.
    #'
    #' @return `list()` list of [`ReportCard`]
    #' @examples
    #' card1 <- teal.reporter:::ReportCard$new()
    #'
    #' card1$append_text("Header 2 text", "header2")
    #' card1$append_text("A paragraph of default text", "header2")
    #' card1$append_plot(
    #'  ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()
    #' )
    #'
    #' card2 <- teal.reporter:::ReportCard$new()
    #'
    #' card2$append_text("Header 2 text", "header2")
    #' card2$append_text("A paragraph of default text", "header2")
    #' lyt <- rtables::analyze(rtables::split_rows_by(rtables::basic_table(), "Day"), "Ozone", afun = mean)
    #' table_res2 <- rtables::build_table(lyt, airquality)
    #' card2$append_table(table_res2)
    #' card2$append_table(iris)
    #'
    #' reporter <- teal.reporter:::Reporter$new()
    #' reporter$append_cards(list(card1, card2))
    #' reporter$get_cards()
    get_cards = function() {
      private$cards
    },
    #' @description Returns blocks of all [`ReportCard`] of this `Reporter`.
    #'
    #' @param sep the element inserted between each content element in this `Reporter`.
    #' Pass `NULL` to return content without any additional elements. Default: `NewpageBlock$new()`
    #' @return `list()` list of `TableBlock`, `TextBlock`, `PictureBlock` and `NewpageBlock`
    #' @examples
    #' card1 <- teal.reporter:::ReportCard$new()
    #'
    #' card1$append_text("Header 2 text", "header2")
    #' card1$append_text("A paragraph of default text", "header2")
    #' card1$append_plot(
    #'  ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()
    #' )
    #'
    #' card2 <- teal.reporter:::ReportCard$new()
    #'
    #' card2$append_text("Header 2 text", "header2")
    #' card2$append_text("A paragraph of default text", "header2")
    #' lyt <- rtables::analyze(rtables::split_rows_by(rtables::basic_table(), "Day"), "Ozone", afun = mean)
    #' table_res2 <- rtables::build_table(lyt, airquality)
    #' card2$append_table(table_res2)
    #' card2$append_table(iris)
    #'
    #' reporter <- teal.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 Removes all [`ReportCard`] objects added to this `Reporter`.
    #' Additionally all metadata are removed.
    #'
    #' @return invisibly self
    #'
    reset = function() {
      private$cards <- list()
      private$metadata <- list()
      private$reactive_add_card(0)
      invisible(self)
    },
    #' @description remove a specific Card in the Reporter
    #'
    #' @param ids `integer` the indexes of cards
    #' @return invisibly self
    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 swap two cards in the Reporter
    #'
    #' @param start `integer` the index of the first card
    #' @param end `integer` the index of the second card
    #' @return invisibly self
    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 get a value for the reactive value for the add card
    #'
    #' @return `reactive_add_card` field value
    #' @note The function has to be used in the shiny reactive context.
    #' @examples
    #' shiny::isolate(Reporter$new()$get_reactive_add_card())
    get_reactive_add_card = function() {
      private$reactive_add_card()
    },
    #' @description get metadata of this `Reporter`.
    #'
    #' @return metadata
    #' @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 (`list`) of metadata.
    #' @return invisibly self
    #' @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 Create/Recreate a Reporter from another Reporter
    #' @param reporter `Reporter` instance.
    #' @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 files
    #' @param output_dir `character(1)` a path to the directory where files will be copied.
    #' @return `named list` `Reporter` representation
    #' @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(version = "1", 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 Create/Recreate a Reporter from a list and directory with files
    #' @param rlist `named list` `Reporter` representation.
    #' @param output_dir `character(1)` a path to the directory from which files will be copied.
    #' @return invisibly self
    #' @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) {
      checkmate::assert_list(rlist)
      checkmate::assert_directory_exists(output_dir)
      if (rlist$version == "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(sprintf("%s$new()", card_class)))
          new_card$from_list(card, output_dir)
          new_cards <- c(new_cards, new_card)
        }
      } else {
        stop("The provided version is not supported")
      }
      self$reset()
      self$append_cards(new_cards)
      self$append_metadata(rlist$metadata)
      invisible(self)
    },
    #' @description Create/Recreate a Reporter to a directory with `JSON` file and static files
    #' @param output_dir `character(1)` a path to the directory where files will be copied, `JSON` and statics.
    #' @return invisibly self
    #' @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 Create/Recreate a Reporter from a directory with `JSON` file and static files
    #' @param output_dir `character(1)` a path to the directory with files, `JSON` and statics.
    #' @return invisibly self
    #' @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)
      checkmate::assert_true(length(list.files(output_dir)) > 0)
      dir_files <- list.files(output_dir)
      which_json <- grep("json$", dir_files)
      json <- jsonlite::read_json(file.path(output_dir, dir_files[which_json]))
      self$reset()
      self$from_list(json, output_dir)
      invisible(self)
    }
  ),
  private = list(
    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
)

#' 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
#' @md
#'
#' @description `r lifecycle::badge("experimental")`
#' @param title (`character`)\cr title of panel
#' @param ... content of panel
#' @param collapsed (`logical`, optional)\cr
#'  whether to initially collapse panel
#' @param input_id (`character`, optional)\cr
#'  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
    )
  })
}

#' @title quoted string for `yaml`
#' @description add quoted attribute for `yaml` package
#' @param x `character`
#' @keywords internal
#' @examples
#' yaml <- list(
#'   author = teal.reporter:::yaml_quoted("NEST"),
#'   title = teal.reporter:::yaml_quoted("Report"),
#'   date = teal.reporter:::yaml_quoted("07/04/2019"),
#'   output = list(pdf_document = list(keep_tex = TRUE))
#' )
#' yaml::as.yaml(yaml)
yaml_quoted <- function(x) {
  attr(x, "quoted") <- TRUE
  x
}

#' @title wrap a `yaml` string to the `markdown` header
#' @description wrap a `yaml` string to the `markdown` header.
#' @param x `character` `yaml` formatted string.
#' @keywords internal
#' @examples
#' yaml <- list(
#'   author = teal.reporter:::yaml_quoted("NEST"),
#'   title = teal.reporter:::yaml_quoted("Report"),
#'   date = teal.reporter:::yaml_quoted("07/04/2019"),
#'   output = list(pdf_document = list(keep_tex = TRUE))
#' )
#' teal.reporter:::md_header(yaml::as.yaml(yaml))
md_header <- function(x) {
  paste0("---\n", x, "---\n")
}

#' @title Convert a character of a `yaml` boolean to a logical value
#' @description convert a character of a `yaml` boolean to a logical value.
#' @param input `character`
#' @param name `charcter`
#' @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` if to suppress the messages and warnings.
#' @return `input` argument or the appropriate `logical` value.
#' @keywords internal
#' @examples
#' teal.reporter:::conv_str_logi("TRUE")
#' teal.reporter:::conv_str_logi("True")
#'
#' teal.reporter:::conv_str_logi("off")
#' teal.reporter:::conv_str_logi("n")
#'
#' teal.reporter:::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
  }
}

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

#' @title Get document output arguments from the `rmarkdown` package
#'
#' @description `r lifecycle::badge("experimental")`
#' get document output arguments from the `rmarkdown` package
#' @param output_name `character` `rmarkdown` output name.
#' @param default_values `logical` 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]]))
  }
}

#' @title Parse a Named List to the `Rmd` `yaml` Header
#' @description `r lifecycle::badge("experimental")`
#' parse a named list to the `Rmd` `yaml` header, so the developer gets automatically tabulated `Rmd` `yaml` header.
#' Only a non nested (flat) list will be processed,
#' where as a nested list is directly processed with the [`yaml::as.yaml`] function.
#' All `Rmd` `yaml` header fields from the vector are supported,
#' `c("author", "date", "title", "subtitle", "abstract", "keywords", "subject", "description", "category", "lang")`.
#' Moreover all `output`field types in the `rmarkdown` package and their arguments are supported.
#' @param input_list `named list` non nested with slots names and their values compatible with `Rmd` `yaml` header.
#' @param as_header `logical` optionally wrap with result with the [md_header()], default `TRUE`.
#' @param convert_logi `logical` convert a character values to logical,
#'  if they are recognized as quoted `yaml` logical values , default `TRUE`.
#' @param multi_output `logical` multi `output` slots in the `input` argument, default `FALSE`.
#' @param silent `logical` suppress messages and warnings, default `FALSE`.
#' @return `character` with `rmd_yaml_header` class,
#' result of [`yaml::as.yaml`], optionally wrapped with [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")
}

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

#' @title `FileBlock`
#' @keywords internal
#'
FileBlock <- R6::R6Class( # nolint: object_name_linter.
  classname = "FileBlock",
  inherit = ContentBlock,
  public = list(
    #' @description finalize of this `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 invisibly self
    #' @examples
    #' block <- teal.reporter:::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
    #' block <- teal.reporter:::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 `Archiver`
#' @keywords internal
Archiver <- R6::R6Class( # nolint: object_name_linter.
  classname = "Archiver",
  public = list(
    #' @description Returns an `Archiver` object.
    #'
    #' @return an `Archiver` object
    #' @examples
    #' archiver <- teal.reporter:::Archiver$new()
    #'
    initialize = function() {
      invisible(self)
    },
    #' @description Finalizes an `Archiver` object.
    finalize = function() {
      # destructor
    },
    #' @description Pure virtual method for reading an `Archiver`.
    read = function() {
      # returns Reporter instance
      stop("Pure virtual method.")
    },
    #' @description Pure virtual method for writing an `Archiver`.
    write = function() {
      stop("Pure virtual method.")
    }
  ),
  lock_objects = TRUE,
  lock_class = TRUE
)

#' @title `RDSArchiver`
#' @keywords internal
FileArchiver <- R6::R6Class( # nolint: object_name_linter.
  classname = "FileArchiver",
  inherit = Archiver,
  public = list(
    #' @description Returns a `FileArchiver` object.
    #'
    #' @return a `FileArchiver` object
    #' @examples
    #' archiver <- teal.reporter:::FileArchiver$new()
    #'
    initialize = function() {
      tmp_dir <- tempdir()
      output_dir <- file.path(tmp_dir, sprintf("archive_%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 `FileArchiver` object.
    finalize = function() {
      unlink(private$output_dir, recursive = TRUE)
    },
    #' @description get `output_dir` field
    #'
    #' @return `character` a `output_dir` field path.
    #' @examples
    #' archiver <- teal.reporter:::FileArchiver$new()
    #' archiver$get_output_dir()
    get_output_dir = function() {
      private$output_dir
    }
  ),
  private = list(
    output_dir = character(0)
  )
)

#' @title `JSONArchiver`
#' @keywords internal
JSONArchiver <- R6::R6Class( # nolint: object_name_linter.
  classname = "JSONArchiver",
  inherit = FileArchiver,
  public = list(
    #' @description write a `Reporter` instance in to this `JSONArchiver` object.
    #'
    #' @param reporter `Reporter` instance.
    #' @return invisibly self
    #' @examples
    #' card1 <- teal.reporter:::ReportCard$new()
    #'
    #' card1$append_text("Header 2 text", "header2")
    #' card1$append_text("A paragraph of default text", "header2")
    #' card1$append_plot(
    #'  ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()
    #' )
    #'
    #' reporter <- teal.reporter:::Reporter$new()
    #' reporter$append_cards(list(card1))
    #'
    #' archiver <- teal.reporter:::JSONArchiver$new()
    #' archiver$write(reporter)
    #' archiver$get_output_dir()
    write = function(reporter) {
      checkmate::assert_class(reporter, "Reporter")
      unlink(list.files(private$output_dir, recursive = TRUE, full.names = TRUE))
      reporter$to_jsondir(private$output_dir)
      self
    },
    #' @description read a `Reporter` instance from a directory with `JSONArchiver`.
    #'
    #' @param path `character(1)` a path to the directory with all proper files.
    #' @return `Reporter` instance.
    #' @examples
    #' card1 <- teal.reporter:::ReportCard$new()
    #'
    #' card1$append_text("Header 2 text", "header2")
    #' card1$append_text("A paragraph of default text", "header2")
    #' card1$append_plot(
    #'  ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()
    #' )
    #'
    #' reporter <- teal.reporter:::Reporter$new()
    #' reporter$append_cards(list(card1))
    #'
    #' archiver <- teal.reporter:::JSONArchiver$new()
    #' archiver$write(reporter)
    #' archiver$get_output_dir()
    #'
    #' archiver$read()$get_cards()[[1]]$get_content()
    #' blocks <- teal.reporter:::Reporter$new()$from_reporter(archiver$read())$get_blocks()
    #' doc <- teal.reporter:::Renderer$new()$render(blocks)
    read = function(path = NULL) {
      checkmate::assert(
        checkmate::check_null(path),
        checkmate::check_directory_exists(path)
      )

      if (!is.null(path) && !identical(path, private$output_dir)) {
        unlink(list.files(private$output_dir, recursive = TRUE, full.names = TRUE))
        file.copy(list.files(path, full.names = TRUE), private$output_dir)
      }

      if (length(list.files(private$output_dir))) {
        Reporter$new()$from_jsondir(private$output_dir)
      } else {
        warning("The directory provided to the Archiver is empty.")
        Reporter$new()
      }
    }
  ),
  lock_objects = TRUE,
  lock_class = TRUE
)

#' Reporter Previewer User Interface
#' @description `r lifecycle::badge("experimental")`
#' reporter previewer user interface to visualize and manipulate the already added report Cards
#' @param id `character(1)` this `shiny` module's id.
#' @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"))
        )
      )
    )
  )
}

#' Reporter Previewer Server
#' @description `r lifecycle::badge("experimental")`
#' server supporting the functionalities of the reporter previewer
#' For more details see the vignette: `vignette("previewerReporter", "teal.reporter")`.
#' @param id `character(1)` this `shiny` module's id.
#' @param reporter `Reporter` instance
#' @inheritParams reporter_download_inputs
#' @export
reporter_previewer_srv <- function(id,
                                   reporter,
                                   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(
    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 = 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) {
      ns <- session$ns

      teal.reporter::reset_report_button_srv("resetButtonPreviewer", reporter)

      output$encoding <- shiny::renderUI({
        reporter$get_reactive_add_card()
        shiny::tagList(
          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
          ),
          htmltools::tagAppendAttributes(
            shiny::tags$a(
              id = ns("download_data_prev"),
              class = "btn btn-primary shiny-download-link",
              href = "",
              target = "_blank",
              download = NA,
              shiny::tags$span("Download Report", shiny::icon("download"))
            ),
            class = if (length(reporter$get_cards())) "" else "disabled"
          ),
          teal.reporter::reset_report_button_ui(ns("resetButtonPreviewer"), label = "Reset Report")
        )
      })

      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$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() {
          paste("report_", format(Sys.time(), "%y%m%d%H%M%S"), ".zip", sep = "")
        },
        content = function(file) {
          shiny::showNotification("Rendering and Downloading the document.")
          input_list <- lapply(names(rmd_yaml_args), function(x) input[[x]])
          names(input_list) <- names(rmd_yaml_args)
          global_knitr <- list()
          if (is.logical(input$showrcode)) global_knitr <- list(echo = input$showrcode)
          report_render_and_compress(reporter, input_list, global_knitr, file)
        },
        contentType = "application/zip"
      )
    }
  )
}

#' @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(
      paste(utils::capture.output(print(b_table)), collapse = "\n")
    )
  } else if (inherits(b, "NewpageBlock")) {
    shiny::tags$br()
  } else {
    stop("Unknown block class")
  }
}

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

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

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

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

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

#' @title `ContentBlock`
#' @keywords internal
ContentBlock <- R6::R6Class( # nolint: object_name_linter.
  classname = "ContentBlock",
  public = list(
    #' @description Returns a `ContentBlock` object.
    #'
    #' @details Returns a `ContentBlock` object with no content and the default style.
    #'
    #' @return `ContentBlock`
    #' @examples
    #' block <- 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)`) a string literal or a file path assigned to this `ContentBlock`
    #' @return invisibly self
    #' @examples
    #' block <- teal.reporter:::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 Returns the absolute path to content of this `ContentBlock`
    #'
    #' @return `character` content of this `ContentBlock`
    #' @examples
    #' block <- teal.reporter:::ContentBlock$new()
    #' block$get_content()
    #'
    get_content = function() {
      private$content
    },
    #' @description Create the `ContentBlock` from a list.
    #' @param x `named list` with two fields `c("text", "style")`.
    #' Use the `get_available_styles` method to get all possible styles.
    #' @return invisibly self
    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 `Renderer`
#' @keywords internal
Renderer <- R6::R6Class( # nolint: object_name_linter.
  classname = "Renderer",
  public = list(
    #' @description Returns a `Renderer` object.
    #'
    #' @details Returns a `Renderer` object.
    #'
    #' @return `Renderer` object.
    #' @examples
    #' 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 `c("TextBlock", "PictureBlock", "NewpageBlock")` objects.
    #' @param yaml_header `character` a `rmarkdown` `yaml` header.
    #' @param global_knitr `list` a global `knitr` parameters, like echo.
    #' But if local parameter is set it will have priority.
    #' Defaults to empty `list()`.
    #' @return `character` a `Rmd` text (`yaml` header + body), ready to be rendered.
    #' @examples
    #' card1 <- teal.reporter:::ReportCard$new()
    #'
    #' card1$append_text("Header 2 text", "header2")
    #' card1$append_text("A paragraph of default text")
    #' card1$append_plot(
    #'  ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()
    #' )
    #'
    #' card2 <- teal.reporter:::ReportCard$new()
    #'
    #' card2$append_text("Header 2 text", "header2")
    #' card2$append_text("A paragraph of default text", "header2")
    #' lyt <- rtables::analyze(rtables::split_rows_by(rtables::basic_table(), "Day"), "Ozone", afun = mean)
    #' table_res2 <- rtables::build_table(lyt, airquality)
    #' card2$append_table(table_res2)
    #' card2$append_table(iris)
    #' card2$append_rcode("2+2", echo = FALSE)
    #'
    #' reporter <- teal.reporter:::Reporter$new()
    #' reporter$append_cards(list(card1, card2))
    #'
    #' yaml_l <- list(
    #'   author = teal.reporter:::yaml_quoted("NEST"),
    #'   title = teal.reporter:::yaml_quoted("Report"),
    #'   date = teal.reporter:::yaml_quoted("07/04/2019"),
    #'   output = list(html_document = list(toc = FALSE))
    #' )
    #'
    #' yaml_header <- teal.reporter:::md_header(yaml::as.yaml(yaml_l))
    #' result_path <- teal.reporter:::Renderer$new()$renderRmd(reporter$get_blocks(), yaml_header)
    renderRmd = function(blocks, yaml_header, global_knitr = list()) {
      checkmate::assert_list(blocks, c("TextBlock", "PictureBlock", "NewpageBlock", "TableBlock", "RcodeBlock"))
      if (missing(yaml_header)) {
        yaml_header <- md_header(yaml::as.yaml(list(title = "Report")))
      }
      parsed_yaml <- yaml_header
      parsed_global_knitr <- sprintf(
        "\n```{r setup, include=FALSE}\nknitr::opts_chunk$set(%s)\n```\n",
        capture.output(dput(global_knitr))
      )
      parsed_blocks <- paste(
        unlist(
          lapply(blocks, function(b) private$block2md(b))
        ),
        collapse = "\n\n"
      )

      rmd_text <- paste0(parsed_yaml, "\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 content of this `Report` to the output file
    #'
    #' @param blocks `list` of `c("TextBlock", "PictureBlock", "NewpageBlock")` objects.
    #' @param yaml_header `character` an `rmarkdown` `yaml` header.
    #' @param global_knitr `list` a global `knitr` parameters, like echo.
    #' But if local parameter is set it will have priority.
    #' Defaults to empty `list()`.
    #' @param ... `rmarkdown::render` arguments, `input` and `output_dir` should not be updated.
    #' @return `character` path to the output
    #' @examples
    #' card1 <- teal.reporter:::ReportCard$new()
    #' card1$append_text("Header 2 text", "header2")
    #' card1$append_text("A paragraph of default text")
    #' card1$append_plot(
    #'  ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()
    #' )
    #'
    #' card2 <- teal.reporter:::ReportCard$new()
    #' card2$append_text("Header 2 text", "header2")
    #' card2$append_text("A paragraph of default text", "header2")
    #' lyt <- rtables::analyze(rtables::split_rows_by(rtables::basic_table(), "Day"), "Ozone", afun = mean)
    #' table_res2 <- rtables::build_table(lyt, airquality)
    #' card2$append_table(table_res2)
    #' card2$append_table(iris)
    #' card2$append_rcode("2+2", echo = FALSE)
    #'
    #' reporter <- teal.reporter:::Reporter$new()
    #' reporter$append_cards(list(card1, card2))
    #'
    #' yaml_l <- list(
    #'   author = teal.reporter:::yaml_quoted("NEST"),
    #'   title = teal.reporter:::yaml_quoted("Report"),
    #'   date = teal.reporter:::yaml_quoted("07/04/2019"),
    #'   output = list(html_document = list(toc = FALSE))
    #' )
    #'
    #' yaml_header <- teal.reporter:::md_header(yaml::as.yaml(yaml_l))
    #' result_path <- teal.reporter:::Renderer$new()$render(reporter$get_blocks(), yaml_header)
    render = function(blocks, yaml_header, global_knitr = list(), ...) {
      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 <- teal.reporter:::Renderer$new()
    #' renderer$get_output_dir()
    get_output_dir = function() {
      private$output_dir
    }
  ),
  private = list(
    output_dir = character(0),
    # 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)
      block_content <- block$get_content()
      sprintf(
        "\n```{r, %s}\n%s\n```\n",
        paste(names(params), params, sep = "=", collapse = ", "),
        block_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, %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 User Interface
#' @description `r lifecycle::badge("experimental")`
#' button for adding views/cards to the Report.
#'
#' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`.
#' @param id `character(1)` this `shiny` module's id.
#' @return `shiny::tagList`
#' @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")
      )
    )
  )
}

#' Add Card Button Server
#' @description `r lifecycle::badge("experimental")`
#' server for adding views/cards to the Report.
#'
#' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`.
#'
#' @details
#' This module allows using a child of [`ReportCard`] instead of [`ReportCard`].
#' To properly support this, an instance of the child class must be passed
#' as the default value of the `card` argument in the `card_fun` function.
#' See below:
#' ```{r}
#' CustomReportCard <- R6::R6Class( # nolint: object_name_linter.
#'   classname = "CustomReportCard",
#'   inherit = teal.reporter::ReportCard
#' )
#'
#' custom_function <- function(card = CustomReportCard$new()) {
#'   card
#' }
#' ```
#'
#' @param id `character(1)` this `shiny` module's id.
#' @param reporter [`Reporter`] instance.
#' @param card_fun `function` which returns a [`ReportCard`] instance,
#' the function has optional `card` and  `comment` arguments.
#' If the `card` argument is added then the `ReportCard` instance is automatically created for the user.
#' If the `comment` argument is not specified then it is added automatically at the end of the Card.
#' The card name set by default in `card_fun` will be overcome by the `label` input which will be set automatically
#' when adding a card.
#'
#'
#' @return `shiny::moduleServer`
#' @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"), empty.ok = TRUE)

  shiny::moduleServer(
    id,
    function(input, output, session) {
      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("comment")
              )
            )
          ),
          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

        arg_list <- list()

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

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

#' @title `PictureBlock`
#' @keywords internal
#'
PictureBlock <- R6::R6Class( # nolint: object_name_linter.
  classname = "PictureBlock",
  inherit = FileBlock,
  public = list(
    #' @description Returns a new `PictureBlock` object.
    #'
    #' @param plot (`ggplot`, `grid`) a picture in this `PictureBlock`
    #' @return a `PictureBlock` object
    #'
    initialize = function(plot) {
      if (!missing(plot)) {
        self$set_content(plot)
      }
      invisible(self)
    },
    #' @description Sets the content of this `PictureBlock`.
    #'
    #' @details throws if argument is not a `ggplot`, `grob` or `trellis` plot.
    #'
    #' @param content (`ggplot`, `grob`, `trellis`) a picture in this `PictureBlock`
    #' @return invisibly self
    #' @examples
    #' block <- teal.reporter:::PictureBlock$new()
    #' block$set_content(ggplot2::ggplot(iris))
    #'
    #' block <- teal.reporter:::PictureBlock$new()
    #' block$set_content(lattice::bwplot(1))
    #'
    #' block <- teal.reporter:::PictureBlock$new()
    #' block$set_content(ggplot2::ggplotGrob(ggplot2::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 throws if argument is not `character(1)`.
    #'
    #' @param title (`character(1)`) a string assigned to this `PictureBlock`
    #' @return invisibly self
    #' @examples
    #' block <- teal.reporter:::PictureBlock$new()
    #' block$set_title("Title")
    #'
    set_title = function(title) {
      checkmate::assert_string(title)
      private$title <- title
      invisible(self)
    },
    #' @description Returns the title of this `PictureBlock`
    #'
    #' @return the content of this `PictureBlock`
    #' @examples
    #' block <- teal.reporter:::PictureBlock$new()
    #' block$get_title()
    #'
    get_title = function() {
      private$title
    },
    #' @description Sets the dimensions of this `PictureBlock`
    #'
    #' @param dim `numeric` figure dimensions (width and height) in pixels, length 2.
    #' @return `self`
    #' @examples
    #' block <- teal.reporter:::PictureBlock$new()
    #' block$set_dim(c(800, 600))
    #'
    set_dim = function(dim) {
      checkmate::assert_numeric(dim, len = 2)
      private$dim <- dim
      invisible(self)
    },
    #' @description Returns the dimensions of this `PictureBlock`
    #'
    #' @return `numeric` the array of 2 numeric values representing width and height in pixels.
    #' @examples
    #' block <- teal.reporter:::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
)

#' Simple Reporter User Interface
#' @description `r lifecycle::badge("experimental")`
#' three buttons for adding cards, downloading and resetting the Report.
#'
#' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`.
#' @param id `character(1)` this `shiny` module's id.
#' @return `shiny.tag`
#' @export
#'
#' @examples
#' if (interactive()) {
#'   shiny::shinyApp(
#'     ui = shiny::fluidPage(simple_reporter_ui("simple")),
#'     server = function(input, output, session) {
#'       simple_reporter_srv("simple", Reporter$new(), function(card) card)
#'     }
#'   )
#' }
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")),
        reset_report_button_ui(ns("reset_button_simple"))
      )
    )
  )
}

#' Simple Reporter Server
#' @description `r lifecycle::badge("experimental")`
#' three buttons for adding cards, downloading and resetting the Report.
#' The add module has `add_report_card_simple` id, the download module the `download_button_simple` id
#' and the reset module the `reset_button_simple` id.
#'
#' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`.
#' @param id `character(1)` this `shiny` module's 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.
#' @inheritParams reporter_download_inputs
#' @return `shiny::moduleServer`
#' @export
simple_reporter_srv <- function(id,
                                reporter,
                                card_fun,
                                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,
        rmd_output = rmd_output,
        rmd_yaml_args = rmd_yaml_args
      )
      reset_report_button_srv("reset_button_simple", reporter = reporter)
    }
  )
}

#' Reset Button Reporter User Interface
#' @description `r lifecycle::badge("experimental")`
#' button for resetting the report content.
#'
#' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`.
#' @param id `character(1)` this `shiny` module's id.
#' @param label `character(1)` label before the icon.
#' By default `NULL`.
#' @return `shiny::tagList`
#' @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")
      )
    )
  )
}

#' Reset Button Server
#' @description `r lifecycle::badge("experimental")`
#' server for resetting the Report content.
#'
#' 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
reset_report_button_srv <- function(id, reporter) {
  checkmate::assert_class(reporter, "Reporter")

  shiny::moduleServer(
    id,
    function(input, output, session) {
      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 `TextBlock`
#' @keywords internal
TextBlock <- R6::R6Class( # nolint: object_name_linter.
  classname = "TextBlock",
  inherit = ContentBlock,
  public = list(
    #' @description Returns a `TextBlock` object.
    #'
    #' @details Returns a `TextBlock` object with no content and the default style.
    #'
    #' @param content (`character(1)` or `character(0)`) a string assigned to this `TextBlock`
    #' @param style (`character(1)`) one of: `"default"`, `"header2"`, `"header3"` `"verbatim"`
    #'
    #' @return `TextBlock`
    #' @examples
    #' block <- teal.reporter:::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 invisibly self
    #' @examples
    #' block <- teal.reporter:::TextBlock$new()
    #' block$set_style("header2")
    #'
    set_style = function(style) {
      private$style <- match.arg(style, private$styles)
      invisible(self)
    },
    #' @description Returns the style of this `TextBlock`.
    #'
    #' @return `character(1)` the style of this `TextBlock`
    #' @examples
    #' block <- teal.reporter:::TextBlock$new()
    #' block$get_style()
    #'
    get_style = function() {
      private$style
    },
    #' @description Returns an array of styles available to this `TextBlock`.
    #'
    #' @return a `character` array of styles
    #' @examples
    #' block <- teal.reporter:::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 `c("text", "style")`.
    #' Use the `get_available_styles` method to get all possible styles.
    #' @return invisibly self
    #' @examples
    #' block <- teal.reporter:::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
    #' block <- teal.reporter:::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
)

#' @title `RcodeBlock`
#' @keywords internal
RcodeBlock <- R6::R6Class( # nolint: object_name_linter.
  classname = "RcodeBlock",
  inherit = ContentBlock,
  public = list(
    #' @description Returns 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 `RcodeBlock`
    #' @examples
    #' block <- teal.reporter:::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 The parameters has bearing on the rendering of this block.
    #'
    #' @param params (`list`) any `rmarkdown` R chunk parameter and its value.
    #' @return invisibly self
    #' @examples
    #' block <- teal.reporter:::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 Returns the parameters of this `RcodeBlock`.
    #'
    #' @return `character` the parameters of this `RcodeBlock`
    #' @examples
    #' block <- teal.reporter:::RcodeBlock$new()
    #' block$get_params()
    #'
    get_params = function() {
      private$params
    },
    #' @description Returns an array of parameters available to this `RcodeBlock`.
    #'
    #' @return a `character` array of parameters
    #' @examples
    #' block <- teal.reporter:::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 `c("text", "params")`.
    #' Use the `get_available_params` method to get all possible parameters.
    #' @return invisibly self
    #' @examples
    #' block <- teal.reporter:::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
    #' block <- teal.reporter:::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 `TableBlock`
#' @keywords internal
#'
TableBlock <- R6::R6Class( # nolint: object_name_linter.
  classname = "TableBlock",
  inherit = FileBlock,
  public = list(
    #' @description Returns a new `TableBlock` object
    #'
    #' @param table (`data.frame`, `rtables`, `TableTree`, `ElementaryTable`) a table assigned to this `TableBlock`
    #' @return a `TableBlock` object
    #'
    initialize = function(table) {
      if (!missing(table)) {
        self$set_content(table)
      }
      invisible(self)
    },
    #' @description Sets content of this `TableBlock`.
    #'
    #' @details throws if argument is not a table-like object.
    #'
    #' @param content (`data.frame`, `rtables`, `TableTree`, `ElementaryTable`) a table assigned to this `TableBlock`
    #' @return invisibly self
    #' @examples
    #' block <- teal.reporter:::TableBlock$new()
    #' block$set_content(iris)
    #'
    set_content = function(content) {
      checkmate::assert_multi_class(content, private$supported_tables)
      path <- tempfile(fileext = ".rds")
      saveRDS(content, file = path)
      super$set_content(path)
      invisible(self)
    }
  ),
  private = list(
    supported_tables = c("data.frame", "rtables", "TableTree", "ElementaryTable")
  ),
  lock_objects = TRUE,
  lock_class = TRUE
)

#' @title `NewpageBlock`
#' @keywords internal
#'
NewpageBlock <- R6::R6Class( # nolint: object_name_linter.
  classname = "NewpageBlock",
  inherit = ContentBlock,
  public = list(
    #' @description Returns a `NewpageBlock` object.
    #'
    #' @details Returns a `NewpageBlock` object with no content and the default style.
    #'
    #' @return `NewpageBlock`
    #' @examples
    #' block <- teal.reporter:::NewpageBlock$new()
    #'
    initialize = function() {
      super$set_content("\n\\newpage\n")
      invisible(self)
    }
  ),
  lock_objects = TRUE,
  lock_class = TRUE
)

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		#' @md
15		#'
16		#' @description `r lifecycle::badge("experimental")`
17		#' @param title (`character`)\cr title of panel
18		#' @param ... content of panel
19		#' @param collapsed (`logical`, optional)\cr
20		#' whether to initially collapse panel
21		#' @param input_id (`character`, optional)\cr
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		}

1		#' @title `Archiver`
2		#' @keywords internal
3		Archiver <- R6::R6Class( # nolint: object_name_linter.
4		classname = "Archiver",
5		public = list(
6		#' @description Returns an `Archiver` object.
7		#'
8		#' @return an `Archiver` object
9		#' @examples
10		#' archiver <- teal.reporter:::Archiver$new()
11		#'
12		initialize = function() {
13	3x	invisible(self)
14		},
15		#' @description Finalizes an `Archiver` object.
16		finalize = function() {
17		# destructor
18		},
19		#' @description Pure virtual method for reading an `Archiver`.
20		read = function() {
21		# returns Reporter instance
22	1x	stop("Pure virtual method.")
23		},
24		#' @description Pure virtual method for writing an `Archiver`.
25		write = function() {
26	1x	stop("Pure virtual method.")
27		}
28		),
29		lock_objects = TRUE,
30		lock_class = TRUE
31		)
32
33		#' @title `RDSArchiver`
34		#' @keywords internal
35		FileArchiver <- R6::R6Class( # nolint: object_name_linter.
36		classname = "FileArchiver",
37		inherit = Archiver,
38		public = list(
39		#' @description Returns a `FileArchiver` object.
40		#'
41		#' @return a `FileArchiver` object
42		#' @examples
43		#' archiver <- teal.reporter:::FileArchiver$new()
44		#'
45		initialize = function() {
46	10x	tmp_dir <- tempdir()
47	10x	output_dir <- file.path(tmp_dir, sprintf("archive_%s", gsub("[.]", "", format(Sys.time(), "%Y%m%d%H%M%OS4"))))
48	10x	dir.create(path = output_dir)
49	10x	private$output_dir <- output_dir
50	10x	invisible(self)
51		},
52		#' @description Finalizes a `FileArchiver` object.
53		finalize = function() {
54	10x	unlink(private$output_dir, recursive = TRUE)
55		},
56		#' @description get `output_dir` field
57		#'
58		#' @return `character` a `output_dir` field path.
59		#' @examples
60		#' archiver <- teal.reporter:::FileArchiver$new()
61		#' archiver$get_output_dir()
62		get_output_dir = function() {
63	9x	private$output_dir
64		}
65		),
66		private = list(
67		output_dir = character(0)
68		)
69		)
70
71		#' @title `JSONArchiver`
72		#' @keywords internal
73		JSONArchiver <- R6::R6Class( # nolint: object_name_linter.
74		classname = "JSONArchiver",
75		inherit = FileArchiver,
76		public = list(
77		#' @description write a `Reporter` instance in to this `JSONArchiver` object.
78		#'
79		#' @param reporter `Reporter` instance.
80		#' @return invisibly self
81		#' @examples
82		#' card1 <- teal.reporter:::ReportCard$new()
83		#'
84		#' card1$append_text("Header 2 text", "header2")
85		#' card1$append_text("A paragraph of default text", "header2")
86		#' card1$append_plot(
87		#' ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()
88		#' )
89		#'
90		#' reporter <- teal.reporter:::Reporter$new()
91		#' reporter$append_cards(list(card1))
92		#'
93		#' archiver <- teal.reporter:::JSONArchiver$new()
94		#' archiver$write(reporter)
95		#' archiver$get_output_dir()
96		write = function(reporter) {
97	1x	checkmate::assert_class(reporter, "Reporter")
98	1x	unlink(list.files(private$output_dir, recursive = TRUE, full.names = TRUE))
99	1x	reporter$to_jsondir(private$output_dir)
100	1x	self
101		},
102		#' @description read a `Reporter` instance from a directory with `JSONArchiver`.
103		#'
104		#' @param path `character(1)` a path to the directory with all proper files.
105		#' @return `Reporter` instance.
106		#' @examples
107		#' card1 <- teal.reporter:::ReportCard$new()
108		#'
109		#' card1$append_text("Header 2 text", "header2")
110		#' card1$append_text("A paragraph of default text", "header2")
111		#' card1$append_plot(
112		#' ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()
113		#' )
114		#'
115		#' reporter <- teal.reporter:::Reporter$new()
116		#' reporter$append_cards(list(card1))
117		#'
118		#' archiver <- teal.reporter:::JSONArchiver$new()
119		#' archiver$write(reporter)
120		#' archiver$get_output_dir()
121		#'
122		#' archiver$read()$get_cards()[[1]]$get_content()
123		#' blocks <- teal.reporter:::Reporter$new()$from_reporter(archiver$read())$get_blocks()
124		#' doc <- teal.reporter:::Renderer$new()$render(blocks)
125		read = function(path = NULL) {
126	7x	checkmate::assert(
127	7x	checkmate::check_null(path),
128	7x	checkmate::check_directory_exists(path)
129		)
130
131	7x	if (!is.null(path) && !identical(path, private$output_dir)) {
132	3x	unlink(list.files(private$output_dir, recursive = TRUE, full.names = TRUE))
133	3x	file.copy(list.files(path, full.names = TRUE), private$output_dir)
134		}
135
136	7x	if (length(list.files(private$output_dir))) {
137	6x	Reporter$new()$from_jsondir(private$output_dir)
138		} else {
139	1x	warning("The directory provided to the Archiver is empty.")
140	1x	Reporter$new()
141		}
142		}
143		),
144		lock_objects = TRUE,
145		lock_class = TRUE
146		)

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

1		#' Simple Reporter User Interface
2		#' @description `r lifecycle::badge("experimental")`
3		#' three buttons for adding cards, downloading and resetting the Report.
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.tag`
8		#' @export
9		#'
10		#' @examples
11		#' if (interactive()) {
12		#' shiny::shinyApp(
13		#' ui = shiny::fluidPage(simple_reporter_ui("simple")),
14		#' server = function(input, output, session) {
15		#' simple_reporter_srv("simple", Reporter$new(), function(card) card)
16		#' }
17		#' )
18		#' }
19		simple_reporter_ui <- function(id) {
20	1x	ns <- shiny::NS(id)
21	1x	shiny::tagList(
22	1x	shiny::singleton(
23	1x	shiny::tags$head(shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter")))
24		),
25	1x	shiny::tags$div(
26	1x	class = "block mb-4 p-1",
27	1x	shiny::tags$label(class = "text-primary block -ml-1", shiny::tags$strong("Reporter")),
28	1x	shiny::tags$div(
29	1x	class = "simple_reporter_container",
30	1x	add_card_button_ui(ns("add_report_card_simple")),
31	1x	download_report_button_ui(ns("download_button_simple")),
32	1x	reset_report_button_ui(ns("reset_button_simple"))
33		)
34		)
35		)
36		}
37
38		#' Simple Reporter Server
39		#' @description `r lifecycle::badge("experimental")`
40		#' three buttons for adding cards, downloading and resetting the Report.
41		#' The add module has `add_report_card_simple` id, the download module the `download_button_simple` id
42		#' and the reset module the `reset_button_simple` id.
43		#'
44		#' For more details see the vignette: `vignette("simpleReporter", "teal.reporter")`.
45		#' @param id `character(1)` this `shiny` module's id.
46		#' @param reporter [`Reporter`] instance.
47		#' @param card_fun `function` which returns a [`ReportCard`] instance,
48		#' the function has a `card` argument and an optional `comment` argument.
49		#' @inheritParams reporter_download_inputs
50		#' @return `shiny::moduleServer`
51		#' @export
52		simple_reporter_srv <- function(id,
53		reporter,
54		card_fun,
55		rmd_output = c(
56		"html" = "html_document", "pdf" = "pdf_document",
57		"powerpoint" = "powerpoint_presentation", "word" = "word_document"
58		),
59		rmd_yaml_args = list(
60		author = "NEST", title = "Report",
61		date = as.character(Sys.Date()), output = "html_document",
62		toc = FALSE
63		)) {
64	3x	shiny::moduleServer(
65	3x	id,
66	3x	function(input, output, session) {
67	3x	add_card_button_srv("add_report_card_simple", reporter = reporter, card_fun = card_fun)
68	3x	download_report_button_srv(
69	3x	"download_button_simple",
70	3x	reporter = reporter,
71	3x	rmd_output = rmd_output,
72	3x	rmd_yaml_args = rmd_yaml_args
73		)
74	3x	reset_report_button_srv("reset_button_simple", reporter = reporter)
75		}
76		)
77		}

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

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

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

1		#' @title `Reporter`
2		#' @description `r lifecycle::badge("experimental")`
3		#' R6 class that stores and manages report cards.
4		#' @export
5		#'
6		Reporter <- R6::R6Class( # nolint: object_name_linter.
7		classname = "Reporter",
8		public = list(
9		#' @description Returns a `Reporter` object.
10		#'
11		#' @return a `Reporter` object
12		#' @examples
13		#' reporter <- teal.reporter:::Reporter$new()
14		#'
15		initialize = function() {
16	44x	private$cards <- list()
17	44x	private$reactive_add_card <- shiny::reactiveVal(0)
18	44x	invisible(self)
19		},
20		#' @description Appends a table to this `Reporter`.
21		#'
22		#' @param cards [`ReportCard`] or a list of such objects
23		#' @return invisibly self
24		#' @examples
25		#' card1 <- teal.reporter:::ReportCard$new()
26		#'
27		#' card1$append_text("Header 2 text", "header2")
28		#' card1$append_text("A paragraph of default text", "header2")
29		#' card1$append_plot(
30		#' ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()
31		#' )
32		#'
33		#' card2 <- teal.reporter:::ReportCard$new()
34		#'
35		#' card2$append_text("Header 2 text", "header2")
36		#' card2$append_text("A paragraph of default text", "header2")
37		#' lyt <- rtables::analyze(rtables::split_rows_by(rtables::basic_table(), "Day"), "Ozone", afun = mean)
38		#' table_res2 <- rtables::build_table(lyt, airquality)
39		#' card2$append_table(table_res2)
40		#' card2$append_table(iris)
41		#'
42		#' reporter <- teal.reporter:::Reporter$new()
43		#' reporter$append_cards(list(card1, card2))
44		#'
45		append_cards = function(cards) {
46	41x	checkmate::assert_list(cards, "ReportCard")
47	41x	private$cards <- append(private$cards, cards)
48	41x	private$reactive_add_card(length(private$cards))
49	41x	invisible(self)
50		},
51		#' @description Returns cards of this `Reporter`.
52		#'
53		#' @return `list()` list of [`ReportCard`]
54		#' @examples
55		#' card1 <- teal.reporter:::ReportCard$new()
56		#'
57		#' card1$append_text("Header 2 text", "header2")
58		#' card1$append_text("A paragraph of default text", "header2")
59		#' card1$append_plot(
60		#' ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()
61		#' )
62		#'
63		#' card2 <- teal.reporter:::ReportCard$new()
64		#'
65		#' card2$append_text("Header 2 text", "header2")
66		#' card2$append_text("A paragraph of default text", "header2")
67		#' lyt <- rtables::analyze(rtables::split_rows_by(rtables::basic_table(), "Day"), "Ozone", afun = mean)
68		#' table_res2 <- rtables::build_table(lyt, airquality)
69		#' card2$append_table(table_res2)
70		#' card2$append_table(iris)
71		#'
72		#' reporter <- teal.reporter:::Reporter$new()
73		#' reporter$append_cards(list(card1, card2))
74		#' reporter$get_cards()
75		get_cards = function() {
76	72x	private$cards
77		},
78		#' @description Returns blocks of all [`ReportCard`] of this `Reporter`.
79		#'
80		#' @param sep the element inserted between each content element in this `Reporter`.
81		#' Pass `NULL` to return content without any additional elements. Default: `NewpageBlock$new()`
82		#' @return `list()` list of `TableBlock`, `TextBlock`, `PictureBlock` and `NewpageBlock`
83		#' @examples
84		#' card1 <- teal.reporter:::ReportCard$new()
85		#'
86		#' card1$append_text("Header 2 text", "header2")
87		#' card1$append_text("A paragraph of default text", "header2")
88		#' card1$append_plot(
89		#' ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()
90		#' )
91		#'
92		#' card2 <- teal.reporter:::ReportCard$new()
93		#'
94		#' card2$append_text("Header 2 text", "header2")
95		#' card2$append_text("A paragraph of default text", "header2")
96		#' lyt <- rtables::analyze(rtables::split_rows_by(rtables::basic_table(), "Day"), "Ozone", afun = mean)
97		#' table_res2 <- rtables::build_table(lyt, airquality)
98		#' card2$append_table(table_res2)
99		#' card2$append_table(iris)
100		#'
101		#' reporter <- teal.reporter:::Reporter$new()
102		#' reporter$append_cards(list(card1, card2))
103		#' reporter$get_blocks()
104		#'
105		get_blocks = function(sep = NewpageBlock$new()) {
106	36x	blocks <- list()
107	36x	if (length(private$cards) > 0) {
108	33x	for (card_idx in head(seq_along(private$cards), -1)) {
109	14x	blocks <- append(blocks, append(private$cards[[card_idx]]$get_content(), sep))
110		}
111	33x	blocks <- append(blocks, private$cards[[length(private$cards)]]$get_content())
112		}
113	36x	blocks
114		},
115		#' @description Removes all [`ReportCard`] objects added to this `Reporter`.
116		#' Additionally all metadata are removed.
117		#'
118		#' @return invisibly self
119		#'
120		reset = function() {
121	27x	private$cards <- list()
122	27x	private$metadata <- list()
123	27x	private$reactive_add_card(0)
124	27x	invisible(self)
125		},
126		#' @description remove a specific Card in the Reporter
127		#'
128		#' @param ids `integer` the indexes of cards
129		#' @return invisibly self
130		remove_cards = function(ids = NULL) {
131	1x	checkmate::assert(
132	1x	checkmate::check_null(ids),
133	1x	checkmate::check_integer(ids, min.len = 1, max.len = length(private$cards))
134		)
135	1x	if (!is.null(ids)) {
136	1x	private$cards <- private$cards[-ids]
137		}
138	1x	private$reactive_add_card(length(private$cards))
139	1x	invisible(self)
140		},
141		#' @description swap two cards in the Reporter
142		#'
143		#' @param start `integer` the index of the first card
144		#' @param end `integer` the index of the second card
145		#' @return invisibly self
146		swap_cards = function(start, end) {
147	6x	checkmate::assert(
148	6x	checkmate::check_integer(start,
149	6x	min.len = 1, max.len = 1, lower = 1, upper = length(private$cards)
150		),
151	6x	checkmate::check_integer(end,
152	6x	min.len = 1, max.len = 1, lower = 1, upper = length(private$cards)
153		),
154	6x	combine = "and"
155		)
156	6x	start_val <- private$cards[[start]]$clone()
157	6x	end_val <- private$cards[[end]]$clone()
158	6x	private$cards[[start]] <- end_val
159	6x	private$cards[[end]] <- start_val
160	6x	invisible(self)
161		},
162		#' @description get a value for the reactive value for the add card
163		#'
164		#' @return `reactive_add_card` field value
165		#' @note The function has to be used in the shiny reactive context.
166		#' @examples
167		#' shiny::isolate(Reporter$new()$get_reactive_add_card())
168		get_reactive_add_card = function() {
169	23x	private$reactive_add_card()
170		},
171		#' @description get metadata of this `Reporter`.
172		#'
173		#' @return metadata
174		#' @examples
175		#' reporter <- Reporter$new()$append_metadata(list(sth = "sth"))
176		#' reporter$get_metadata()
177		#'
178		get_metadata = function() {
179	17x	private$metadata
180		},
181		#' @description Appends metadata to this `Reporter`.
182		#'
183		#' @param meta (`list`) of metadata.
184		#' @return invisibly self
185		#' @examples
186		#' reporter <- Reporter$new()$append_metadata(list(sth = "sth"))
187		#' reporter$get_metadata()
188		#'
189		append_metadata = function(meta) {
190	25x	checkmate::assert_list(meta, names = "unique")
191	22x	checkmate::assert_true(length(meta) == 0 \|\| all(!names(meta) %in% names(private$metadata)))
192	21x	private$metadata <- append(private$metadata, meta)
193	21x	invisible(self)
194		},
195		#' @description Create/Recreate a Reporter from another Reporter
196		#' @param reporter `Reporter` instance.
197		#' @return invisibly self
198		#' @examples
199		#' reporter <- Reporter$new()
200		#' reporter$from_reporter(reporter)
201		from_reporter = function(reporter) {
202	8x	checkmate::assert_class(reporter, "Reporter")
203	8x	self$reset()
204	8x	self$append_cards(reporter$get_cards())
205	8x	self$append_metadata(reporter$get_metadata())
206	8x	invisible(self)
207		},
208		#' @description Convert a Reporter to a list and transfer files
209		#' @param output_dir `character(1)` a path to the directory where files will be copied.
210		#' @return `named list` `Reporter` representation
211		#' @examples
212		#' reporter <- Reporter$new()
213		#' tmp_dir <- file.path(tempdir(), "testdir")
214		#' dir.create(tmp_dir)
215		#' reporter$to_list(tmp_dir)
216		to_list = function(output_dir) {
217	8x	checkmate::assert_directory_exists(output_dir)
218	6x	rlist <- list(version = "1", cards = list())
219	6x	rlist[["metadata"]] <- self$get_metadata()
220	6x	for (card in self$get_cards()) {
221		# we want to have list names being a class names to indicate the class for $from_list
222	6x	card_class <- class(card)[1]
223	6x	u_card <- list()
224	6x	u_card[[card_class]] <- card$to_list(output_dir)
225	6x	rlist$cards <- c(rlist$cards, u_card)
226		}
227	6x	rlist
228		},
229		#' @description Create/Recreate a Reporter from a list and directory with files
230		#' @param rlist `named list` `Reporter` representation.
231		#' @param output_dir `character(1)` a path to the directory from which files will be copied.
232		#' @return invisibly self
233		#' @examples
234		#' reporter <- Reporter$new()
235		#' tmp_dir <- file.path(tempdir(), "testdir")
236		#' unlink(tmp_dir, recursive = TRUE)
237		#' dir.create(tmp_dir)
238		#' reporter$from_list(reporter$to_list(tmp_dir), tmp_dir)
239		from_list = function(rlist, output_dir) {
240	10x	checkmate::assert_list(rlist)
241	10x	checkmate::assert_directory_exists(output_dir)
242	10x	if (rlist$version == "1") {
243	10x	new_cards <- list()
244	10x	cards_names <- names(rlist$cards)
245	10x	cards_names <- gsub("[.][0-9]*$", "", cards_names)
246	10x	for (iter_c in seq_along(rlist$cards)) {
247	16x	card_class <- cards_names[iter_c]
248	16x	card <- rlist$cards[[iter_c]]
249	16x	new_card <- eval(str2lang(sprintf("%s$new()", card_class)))
250	16x	new_card$from_list(card, output_dir)
251	16x	new_cards <- c(new_cards, new_card)
252		}
253		} else {
254	!	stop("The provided version is not supported")
255		}
256	10x	self$reset()
257	10x	self$append_cards(new_cards)
258	10x	self$append_metadata(rlist$metadata)
259	10x	invisible(self)
260		},
261		#' @description Create/Recreate a Reporter to a directory with `JSON` file and static files
262		#' @param output_dir `character(1)` a path to the directory where files will be copied, `JSON` and statics.
263		#' @return invisibly self
264		#' @examples
265		#' reporter <- Reporter$new()
266		#' tmp_dir <- file.path(tempdir(), "jsondir")
267		#' dir.create(tmp_dir)
268		#' reporter$to_jsondir(tmp_dir)
269		to_jsondir = function(output_dir) {
270	5x	checkmate::assert_directory_exists(output_dir)
271	3x	json <- self$to_list(output_dir)
272	3x	cat(jsonlite::toJSON(json, auto_unbox = TRUE, force = TRUE),
273	3x	file = file.path(output_dir, "Report.json")
274		)
275	3x	output_dir
276		},
277		#' @description Create/Recreate a Reporter from a directory with `JSON` file and static files
278		#' @param output_dir `character(1)` a path to the directory with files, `JSON` and statics.
279		#' @return invisibly self
280		#' @examples
281		#' reporter <- Reporter$new()
282		#' tmp_dir <- file.path(tempdir(), "jsondir")
283		#' dir.create(tmp_dir)
284		#' unlink(list.files(tmp_dir, recursive = TRUE))
285		#' reporter$to_jsondir(tmp_dir)
286		#' reporter$from_jsondir(tmp_dir)
287		from_jsondir = function(output_dir) {
288	8x	checkmate::assert_directory_exists(output_dir)
289	8x	checkmate::assert_true(length(list.files(output_dir)) > 0)
290	8x	dir_files <- list.files(output_dir)
291	8x	which_json <- grep("json$", dir_files)
292	8x	json <- jsonlite::read_json(file.path(output_dir, dir_files[which_json]))
293	8x	self$reset()
294	8x	self$from_list(json, output_dir)
295	8x	invisible(self)
296		}
297		),
298		private = list(
299		cards = list(),
300		metadata = list(),
301		reactive_add_card = NULL,
302		# @description The copy constructor.
303		#
304		# @param name the name of the field
305		# @param value the value of the field
306		# @return the new value of the field
307		#
308		deep_clone = function(name, value) {
309	20x	if (name == "cards") {
310	1x	lapply(value, function(card) card$clone(deep = TRUE))
311		} else {
312	19x	value
313		}
314		}
315		),
316		lock_objects = TRUE,
317		lock_class = TRUE
318		)

1		#' @title quoted string for `yaml`
2		#' @description add quoted attribute for `yaml` package
3		#' @param x `character`
4		#' @keywords internal
5		#' @examples
6		#' yaml <- list(
7		#' author = teal.reporter:::yaml_quoted("NEST"),
8		#' title = teal.reporter:::yaml_quoted("Report"),
9		#' date = teal.reporter:::yaml_quoted("07/04/2019"),
10		#' output = list(pdf_document = list(keep_tex = TRUE))
11		#' )
12		#' yaml::as.yaml(yaml)
13		yaml_quoted <- function(x) {
14	2x	attr(x, "quoted") <- TRUE
15	2x	x
16		}
17
18		#' @title wrap a `yaml` string to the `markdown` header
19		#' @description wrap a `yaml` string to the `markdown` header.
20		#' @param x `character` `yaml` formatted string.
21		#' @keywords internal
22		#' @examples
23		#' yaml <- list(
24		#' author = teal.reporter:::yaml_quoted("NEST"),
25		#' title = teal.reporter:::yaml_quoted("Report"),
26		#' date = teal.reporter:::yaml_quoted("07/04/2019"),
27		#' output = list(pdf_document = list(keep_tex = TRUE))
28		#' )
29		#' teal.reporter:::md_header(yaml::as.yaml(yaml))
30		md_header <- function(x) {
31	14x	paste0("---\n", x, "---\n")
32		}
33
34		#' @title Convert a character of a `yaml` boolean to a logical value
35		#' @description convert a character of a `yaml` boolean to a logical value.
36		#' @param input `character`
37		#' @param name `charcter`
38		#' @param pos_logi `character` vector of `yaml` values which should be treated as `TRUE`.
39		#' @param neg_logi `character` vector of `yaml` values which should be treated as `FALSE`.
40		#' @param silent `logical` if to suppress the messages and warnings.
41		#' @return `input` argument or the appropriate `logical` value.
42		#' @keywords internal
43		#' @examples
44		#' teal.reporter:::conv_str_logi("TRUE")
45		#' teal.reporter:::conv_str_logi("True")
46		#'
47		#' teal.reporter:::conv_str_logi("off")
48		#' teal.reporter:::conv_str_logi("n")
49		#'
50		#' teal.reporter:::conv_str_logi("sth")
51		conv_str_logi <- function(input,
52		name = "",
53		pos_logi = c("TRUE", "true", "True", "yes", "y", "Y", "on"),
54		neg_logi = c("FALSE", "false", "False", "no", "n", "N", "off"),
55		silent = TRUE) {
56	18x	checkmate::assert_string(input)
57	17x	checkmate::assert_string(name)
58	17x	checkmate::assert_character(pos_logi)
59	17x	checkmate::assert_character(neg_logi)
60	17x	checkmate::assert_flag(silent)
61
62	17x	all_logi <- c(pos_logi, neg_logi)
63	17x	if (input %in% all_logi) {
64	15x	if (isFALSE(silent)) {
65	!	message(sprintf("The '%s' value should be a logical, so it is automatically converted.", input))
66		}
67	15x	input %in% pos_logi
68		} else {
69	2x	input
70		}
71		}
72
73		#' @title Get document output types from the `rmarkdown` package
74		#'
75		#' @description `r lifecycle::badge("experimental")`
76		#' get document output types from the `rmarkdown` package.
77		#' @return `character` vector.
78		#' @export
79		#' @examples
80		#' rmd_outputs()
81		rmd_outputs <- function() {
82	18x	rmarkdown_namespace <- asNamespace("rmarkdown")
83	18x	ls(rmarkdown_namespace)[grep("_document\|_presentation", ls(rmarkdown_namespace))]
84		}
85
86		#' @title Get document output arguments from the `rmarkdown` package
87		#'
88		#' @description `r lifecycle::badge("experimental")`
89		#' get document output arguments from the `rmarkdown` package
90		#' @param output_name `character` `rmarkdown` output name.
91		#' @param default_values `logical` if to return a default values for each argument.
92		#' @export
93		#' @examples
94		#' rmd_output_arguments("pdf_document")
95		#' rmd_output_arguments("pdf_document", TRUE)
96		rmd_output_arguments <- function(output_name, default_values = FALSE) {
97	17x	checkmate::assert_string(output_name)
98	17x	checkmate::assert_subset(output_name, rmd_outputs())
99
100	16x	rmarkdown_namespace <- asNamespace("rmarkdown")
101	16x	if (default_values) {
102	14x	formals(rmarkdown_namespace[[output_name]])
103		} else {
104	2x	names(formals(rmarkdown_namespace[[output_name]]))
105		}
106		}
107
108		#' @title Parse a Named List to the `Rmd` `yaml` Header
109		#' @description `r lifecycle::badge("experimental")`
110		#' parse a named list to the `Rmd` `yaml` header, so the developer gets automatically tabulated `Rmd` `yaml` header.
111		#' Only a non nested (flat) list will be processed,
112		#' where as a nested list is directly processed with the [`yaml::as.yaml`] function.
113		#' All `Rmd` `yaml` header fields from the vector are supported,
114		#' `c("author", "date", "title", "subtitle", "abstract", "keywords", "subject", "description", "category", "lang")`.
115		#' Moreover all `output`field types in the `rmarkdown` package and their arguments are supported.
116		#' @param input_list `named list` non nested with slots names and their values compatible with `Rmd` `yaml` header.
117		#' @param as_header `logical` optionally wrap with result with the [md_header()], default `TRUE`.
118		#' @param convert_logi `logical` convert a character values to logical,
119		#' if they are recognized as quoted `yaml` logical values , default `TRUE`.
120		#' @param multi_output `logical` multi `output` slots in the `input` argument, default `FALSE`.
121		#' @param silent `logical` suppress messages and warnings, default `FALSE`.
122		#' @return `character` with `rmd_yaml_header` class,
123		#' result of [`yaml::as.yaml`], optionally wrapped with [md_header()].
124		#' @export
125		#' @examples
126		#' # nested so using yaml::as.yaml directly
127		#' as_yaml_auto(
128		#' list(author = "", output = list(pdf_document = list(toc = TRUE)))
129		#' )
130		#'
131		#' # auto parsing for a flat list, like shiny input
132		#' input <- list(author = "", output = "pdf_document", toc = TRUE, keep_tex = TRUE)
133		#' as_yaml_auto(input)
134		#'
135		#' as_yaml_auto(list(author = "", output = "pdf_document", toc = TRUE, keep_tex = "TRUE"))
136		#'
137		#' as_yaml_auto(list(
138		#' author = "", output = "pdf_document", toc = TRUE, keep_tex = TRUE,
139		#' wrong = 2
140		#' ))
141		#'
142		#' as_yaml_auto(list(author = "", output = "pdf_document", toc = TRUE, keep_tex = 2),
143		#' silent = TRUE
144		#' )
145		#'
146		#' input <- list(author = "", output = "pdf_document", toc = TRUE, keep_tex = "True")
147		#' as_yaml_auto(input)
148		#' as_yaml_auto(input, convert_logi = TRUE, silent = TRUE)
149		#' as_yaml_auto(input, silent = TRUE)
150		#' as_yaml_auto(input, convert_logi = FALSE, silent = TRUE)
151		#'
152		#' as_yaml_auto(
153		#' list(
154		#' author = "", output = "pdf_document",
155		#' output = "html_document", toc = TRUE, keep_tex = TRUE
156		#' ),
157		#' multi_output = TRUE
158		#' )
159		#' as_yaml_auto(
160		#' list(
161		#' author = "", output = "pdf_document",
162		#' output = "html_document", toc = "True", keep_tex = TRUE
163		#' ),
164		#' multi_output = TRUE
165		#' )
166		as_yaml_auto <- function(input_list,
167		as_header = TRUE,
168		convert_logi = TRUE,
169		multi_output = FALSE,
170		silent = FALSE) {
171	16x	checkmate::assert_logical(as_header)
172	16x	checkmate::assert_logical(convert_logi)
173	16x	checkmate::assert_logical(silent)
174	16x	checkmate::assert_logical(multi_output)
175
176	16x	if (multi_output) {
177	1x	checkmate::assert_list(input_list, names = "named")
178		} else {
179	15x	checkmate::assert_list(input_list, names = "unique")
180		}
181
182	13x	is_nested <- function(x) any(unlist(lapply(x, is.list)))
183	13x	if (is_nested(input_list)) {
184	2x	result <- input_list
185		} else {
186	11x	result <- list()
187	11x	input_nams <- names(input_list)
188
189		# top fields
190	11x	top_fields <- c(
191	11x	"author", "date", "title", "subtitle", "abstract",
192	11x	"keywords", "subject", "description", "category", "lang"
193		)
194	11x	for (itop in top_fields) {
195	110x	if (itop %in% input_nams) {
196	20x	result[[itop]] <- switch(itop,
197	20x	date = as.character(input_list[[itop]]),
198	20x	input_list[[itop]]
199		)
200		}
201		}
202
203		# output field
204	11x	doc_types <- unlist(input_list[input_nams == "output"])
205	11x	if (length(doc_types)) {
206	11x	for (dtype in doc_types) {
207	12x	doc_type_args <- rmd_output_arguments(dtype, TRUE)
208	12x	doc_type_args_nams <- names(doc_type_args)
209	12x	any_output_arg <- any(input_nams %in% doc_type_args_nams)
210
211	12x	not_found_args <- setdiff(input_nams, c(doc_type_args_nams, top_fields, "output"))
212	12x	if (isFALSE(silent) && length(not_found_args) > 0 && isFALSE(multi_output)) {
213	1x	warning(sprintf("Not recognized and skipped arguments: %s", paste(not_found_args, collapse = ", ")))
214		}
215
216	12x	if (any_output_arg) {
217	11x	doc_list <- list()
218	11x	doc_list[[dtype]] <- list()
219	11x	for (e in intersect(input_nams, doc_type_args_nams)) {
220	17x	if (is.logical(doc_type_args[[e]]) && is.character(input_list[[e]])) {
221	1x	pos_logi <- c("TRUE", "true", "True", "yes", "y", "Y", "on")
222	1x	neg_logi <- c("FALSE", "false", "False", "no", "n", "N", "off")
223	1x	all_logi <- c(pos_logi, neg_logi)
224	1x	if (input_list[[e]] %in% all_logi && convert_logi) {
225	1x	input_list[[e]] <- conv_str_logi(input_list[[e]], e,
226	1x	pos_logi = pos_logi,
227	1x	neg_logi = neg_logi, silent = silent
228		)
229		}
230		}
231
232	17x	doc_list[[dtype]][[e]] <- input_list[[e]]
233		}
234	11x	result[["output"]] <- append(result[["output"]], doc_list)
235		} else {
236	1x	result[["output"]] <- append(result[["output"]], input_list[["output"]])
237		}
238		}
239		}
240		}
241
242	13x	result <- yaml::as.yaml(result)
243	13x	if (as_header) {
244	12x	result <- md_header(result)
245		}
246	13x	structure(result, class = "rmd_yaml_header")
247		}
248
249		#' @title Print method for the `yaml_header` class
250		#'
251		#' @description `r lifecycle::badge("experimental")`
252		#' Print method for the `yaml_header` class.
253		#' @param x `rmd_yaml_header` class object.
254		#' @param ... optional text.
255		#' @return NULL
256		#' @exportS3Method
257		#' @examples
258		#' input <- list(author = "", output = "pdf_document", toc = TRUE, keep_tex = TRUE)
259		#' out <- as_yaml_auto(input)
260		#' out
261		#' print(out)
262		print.rmd_yaml_header <- function(x, ...) {
263	!	cat(x, ...)
264		}

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

1		#' Reporter Previewer User Interface
2		#' @description `r lifecycle::badge("experimental")`
3		#' reporter previewer user interface to visualize and manipulate the already added report Cards
4		#' @param id `character(1)` this `shiny` module's id.
5		#' @export
6		reporter_previewer_ui <- function(id) {
7	1x	ns <- shiny::NS(id)
8
9	1x	shiny::fluidRow(
10	1x	add_previewer_js(ns),
11	1x	add_previewer_css(),
12	1x	shiny::tagList(
13	1x	shiny::tags$div(
14	1x	class = "col-md-3",
15	1x	shiny::tags$div(class = "well", shiny::uiOutput(ns("encoding")))
16		),
17	1x	shiny::tags$div(
18	1x	class = "col-md-9",
19	1x	shiny::tags$div(
20	1x	id = "reporter_previewer",
21	1x	shiny::uiOutput(ns("pcards"))
22		)
23		)
24		)
25		)
26		}
27
28		#' Reporter Previewer Server
29		#' @description `r lifecycle::badge("experimental")`
30		#' server supporting the functionalities of the reporter previewer
31		#' For more details see the vignette: `vignette("previewerReporter", "teal.reporter")`.
32		#' @param id `character(1)` this `shiny` module's id.
33		#' @param reporter `Reporter` instance
34		#' @inheritParams reporter_download_inputs
35		#' @export
36		reporter_previewer_srv <- function(id,
37		reporter,
38		rmd_output = c(
39		"html" = "html_document", "pdf" = "pdf_document",
40		"powerpoint" = "powerpoint_presentation",
41		"word" = "word_document"
42		), rmd_yaml_args = list(
43		author = "NEST", title = "Report",
44		date = as.character(Sys.Date()), output = "html_document",
45		toc = FALSE
46		)) {
47	12x	checkmate::assert_class(reporter, "Reporter")
48	12x	checkmate::assert_subset(
49	12x	rmd_output,
50	12x	c(
51	12x	"html_document", "pdf_document",
52	12x	"powerpoint_presentation", "word_document"
53		),
54	12x	empty.ok = FALSE
55		)
56	12x	checkmate::assert_list(rmd_yaml_args, names = "named")
57	12x	checkmate::assert_names(
58	12x	names(rmd_yaml_args),
59	12x	subset = c("author", "title", "date", "output", "toc"),
60	12x	must.include = "output"
61		)
62	10x	checkmate::assert_true(rmd_yaml_args[["output"]] %in% rmd_output)
63
64	9x	shiny::moduleServer(
65	9x	id,
66	9x	function(input, output, session) {
67	9x	ns <- session$ns
68
69	9x	teal.reporter::reset_report_button_srv("resetButtonPreviewer", reporter)
70
71	9x	output$encoding <- shiny::renderUI({
72	7x	reporter$get_reactive_add_card()
73	7x	shiny::tagList(
74	7x	shiny::tags$h3("Download the Report"),
75	7x	shiny::tags$hr(),
76	7x	reporter_download_inputs(
77	7x	rmd_yaml_args = rmd_yaml_args,
78	7x	rmd_output = rmd_output,
79	7x	showrcode = any_rcode_block(reporter),
80	7x	session = session
81		),
82	7x	htmltools::tagAppendAttributes(
83	7x	shiny::tags$a(
84	7x	id = ns("download_data_prev"),
85	7x	class = "btn btn-primary shiny-download-link",
86	7x	href = "",
87	7x	target = "_blank",
88	7x	download = NA,
89	7x	shiny::tags$span("Download Report", shiny::icon("download"))
90		),
91	7x	class = if (length(reporter$get_cards())) "" else "disabled"
92		),
93	7x	teal.reporter::reset_report_button_ui(ns("resetButtonPreviewer"), label = "Reset Report")
94		)
95		})
96
97	9x	output$pcards <- shiny::renderUI({
98	9x	reporter$get_reactive_add_card()
99	9x	input$card_remove_id
100	9x	input$card_down_id
101	9x	input$card_up_id
102
103	9x	cards <- reporter$get_cards()
104
105	9x	if (length(cards)) {
106	8x	shiny::tags$div(
107	8x	class = "panel-group accordion",
108	8x	id = "reporter_previewer_panel",
109	8x	lapply(seq_along(cards), function(ic) {
110	14x	previewer_collapse_item(ic, cards[[ic]]$get_name(), cards[[ic]]$get_content())
111		})
112		)
113		} else {
114	1x	shiny::tags$div(
115	1x	id = "reporter_previewer_panel_no_cards",
116	1x	shiny::tags$p(
117	1x	class = "text-danger mt-4",
118	1x	shiny::tags$strong("No Cards added")
119		)
120		)
121		}
122		})
123
124	9x	shiny::observeEvent(input$card_remove_id, {
125	1x	shiny::showModal(
126	1x	shiny::modalDialog(
127	1x	title = "Remove the Report Card",
128	1x	shiny::tags$p(
129	1x	shiny::HTML(
130	1x	sprintf(
131	1x	"Do you really want to remove <strong>the card %s</strong> from the Report?",
132	1x	input$card_remove_id
133		)
134		)
135		),
136	1x	footer = shiny::tagList(
137	1x	shiny::tags$button(
138	1x	type = "button",
139	1x	class = "btn btn-secondary",
140	1x	`data-dismiss` = "modal",
141	1x	`data-bs-dismiss` = "modal",
142	1x	NULL,
143	1x	"Cancel"
144		),
145	1x	shiny::actionButton(ns("remove_card_ok"), "OK", class = "btn-danger")
146		)
147		)
148		)
149		})
150
151	9x	shiny::observeEvent(input$remove_card_ok, {
152	1x	reporter$remove_cards(input$card_remove_id)
153	1x	shiny::removeModal()
154		})
155
156	9x	shiny::observeEvent(input$card_up_id, {
157	3x	if (input$card_up_id > 1) {
158	2x	reporter$swap_cards(
159	2x	as.integer(input$card_up_id),
160	2x	as.integer(input$card_up_id - 1)
161		)
162		}
163		})
164
165	9x	shiny::observeEvent(input$card_down_id, {
166	3x	if (input$card_down_id < length(reporter$get_cards())) {
167	2x	reporter$swap_cards(
168	2x	as.integer(input$card_down_id),
169	2x	as.integer(input$card_down_id + 1)
170		)
171		}
172		})
173
174	9x	output$download_data_prev <- shiny::downloadHandler(
175	9x	filename = function() {
176	1x	paste("report_", format(Sys.time(), "%y%m%d%H%M%S"), ".zip", sep = "")
177		},
178	9x	content = function(file) {
179	1x	shiny::showNotification("Rendering and Downloading the document.")
180	1x	input_list <- lapply(names(rmd_yaml_args), function(x) input[[x]])
181	1x	names(input_list) <- names(rmd_yaml_args)
182	1x	global_knitr <- list()
183	!	if (is.logical(input$showrcode)) global_knitr <- list(echo = input$showrcode)
184	1x	report_render_and_compress(reporter, input_list, global_knitr, file)
185		},
186	9x	contentType = "application/zip"
187		)
188		}
189		)
190		}
191
192		#' @keywords internal
193		block_to_html <- function(b) {
194	42x	b_content <- b$get_content()
195	42x	if (inherits(b, "TextBlock")) {
196	28x	switch(b$get_style(),
197	!	header1 = shiny::tags$h1(b_content),
198	28x	header2 = shiny::tags$h2(b_content),
199	!	header3 = shiny::tags$h3(b_content),
200	!	header4 = shiny::tags$h4(b_content),
201	!	verbatim = shiny::tags$pre(b_content),
202	!	shiny::tags$pre(b_content)
203		)
204	14x	} else if (inherits(b, "RcodeBlock")) {
205	!	panel_item("R Code", shiny::tags$pre(b_content))
206	14x	} else if (inherits(b, "PictureBlock")) {
207	14x	shiny::tags$img(src = knitr::image_uri(b_content))
208	!	} else if (inherits(b, "TableBlock")) {
209	!	b_table <- readRDS(b_content)
210	!	shiny::tags$pre(
211	!	paste(utils::capture.output(print(b_table)), collapse = "\n")
212		)
213	!	} else if (inherits(b, "NewpageBlock")) {
214	!	shiny::tags$br()
215		} else {
216	!	stop("Unknown block class")
217		}
218		}
219
220		#' @keywords internal
221		add_previewer_css <- function() {
222	1x	shiny::tagList(
223	1x	shiny::singleton(
224	1x	shiny::tags$head(shiny::includeCSS(system.file("css/Previewer.css", package = "teal.reporter")))
225		),
226	1x	shiny::singleton(
227	1x	shiny::tags$head(shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter")))
228		)
229		)
230		}
231
232		#' @keywords internal
233		add_previewer_js <- function(ns) {
234	1x	shiny::singleton(
235	1x	shiny::tags$head(shiny::tags$script(
236	1x	shiny::HTML(sprintf('
237	1x	$(document).ready(function(event) {
238	1x	$("body").on("click", "span.card_remove_id", function() {
239	1x	let val = $(this).data("cardid");
240	1x	Shiny.setInputValue("%s", val, {priority: "event"});
241		});
242
243	1x	$("body").on("click", "span.card_up_id", function() {
244	1x	let val = $(this).data("cardid");
245	1x	Shiny.setInputValue("%s", val, {priority: "event"});
246		});
247
248	1x	$("body").on("click", "span.card_down_id", function() {
249	1x	let val = $(this).data("cardid");
250	1x	Shiny.setInputValue("%s", val, {priority: "event"});
251		});
252		});
253	1x	', ns("card_remove_id"), ns("card_up_id"), ns("card_down_id")))
254		))
255		)
256		}
257
258		#' @keywords internal
259		nav_previewer_icon <- function(name, icon_name, idx, size = 1L) {
260	42x	checkmate::assert_string(name)
261	42x	checkmate::assert_string(icon_name)
262	42x	checkmate::assert_int(size)
263
264	42x	shiny::tags$span(
265	42x	class = paste(name, "icon_previewer"),
266		# data field needed to record clicked card on the js side
267	42x	`data-cardid` = idx,
268	42x	shiny::icon(icon_name, sprintf("fa-%sx", size))
269		)
270		}
271
272		#' @keywords internal
273		nav_previewer_icons <- function(idx, size = 1L) {
274	14x	shiny::tags$span(
275	14x	class = "preview_card_control",
276	14x	nav_previewer_icon(name = "card_remove_id", icon_name = "xmark", idx = idx, size = size),
277	14x	nav_previewer_icon(name = "card_up_id", icon_name = "arrow-up", idx = idx, size = size),
278	14x	nav_previewer_icon(name = "card_down_id", icon_name = "arrow-down", idx = idx, size = size)
279		)
280		}
281
282		#' @keywords internal
283		previewer_collapse_item <- function(idx, card_name, card_blocks) {
284	14x	shiny::tags$div(.renderHook = function(x) {
285		# get bs version
286	14x	version <- get_bs_version()
287
288	14x	if (version == "3") {
289	14x	shiny::tags$div(
290	14x	id = paste0("panel_card_", idx),
291	14x	class = "panel panel-default",
292	14x	shiny::tags$div(
293	14x	class = "panel-heading overflow-auto",
294	14x	shiny::tags$div(
295	14x	class = "panel-title",
296	14x	shiny::tags$span(
297	14x	nav_previewer_icons(idx = idx),
298	14x	shiny::tags$a(
299	14x	class = "accordion-toggle block py-3 px-4 -my-3 -mx-4",
300	14x	`data-toggle` = "collapse",
301	14x	`data-parent` = "#reporter_previewer_panel",
302	14x	href = paste0("#collapse", idx),
303	14x	shiny::tags$h4(paste0("Card ", idx, ": ", card_name), shiny::icon("caret-down"))
304		)
305		)
306		)
307		),
308	14x	shiny::tags$div(
309	14x	id = paste0("collapse", idx), class = "collapse out",
310	14x	shiny::tags$div(
311	14x	class = "panel-body",
312	14x	shiny::tags$div(
313	14x	id = paste0("card", idx),
314	14x	lapply(
315	14x	card_blocks,
316	14x	function(b) {
317	42x	block_to_html(b)
318		}
319		)
320		)
321		)
322		)
323		)
324		} else {
325	!	shiny::tags$div(
326	!	id = paste0("panel_card_", idx),
327	!	class = "card",
328	!	shiny::tags$div(
329	!	class = "overflow-auto",
330	!	shiny::tags$div(
331	!	class = "card-header",
332	!	shiny::tags$span(
333	!	nav_previewer_icons(idx = idx),
334	!	shiny::tags$a(
335	!	class = "accordion-toggle block py-3 px-4 -my-3 -mx-4",
336		# bs4
337	!	`data-toggle` = "collapse",
338		# bs5
339	!	`data-bs-toggle` = "collapse",
340	!	href = paste0("#collapse", idx),
341	!	shiny::tags$h4(
342	!	paste0("Card ", idx, ": ", card_name),
343	!	shiny::icon("caret-down")
344		)
345		)
346		)
347		)
348		),
349	!	shiny::tags$div(
350	!	id = paste0("collapse", idx),
351	!	class = "collapse out",
352		# bs4
353	!	`data-parent` = "#reporter_previewer_panel",
354		# bs5
355	!	`data-bs-parent` = "#reporter_previewer_panel",
356	!	shiny::tags$div(
357	!	class = "card-body",
358	!	shiny::tags$div(
359	!	id = paste0("card", idx),
360	!	lapply(
361	!	card_blocks,
362	!	function(b) {
363	!	block_to_html(b)
364		}
365		)
366		)
367		)
368		)
369		)
370		}
371		})
372		}

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

1		#' @title `Renderer`
2		#' @keywords internal
3		Renderer <- R6::R6Class( # nolint: object_name_linter.
4		classname = "Renderer",
5		public = list(
6		#' @description Returns a `Renderer` object.
7		#'
8		#' @details Returns a `Renderer` object.
9		#'
10		#' @return `Renderer` object.
11		#' @examples
12		#' renderer <- teal.reporter:::Renderer$new()
13		initialize = function() {
14	10x	tmp_dir <- tempdir()
15	10x	output_dir <- file.path(tmp_dir, sprintf("report_%s", gsub("[.]", "", format(Sys.time(), "%Y%m%d%H%M%OS4"))))
16	10x	dir.create(path = output_dir)
17	10x	private$output_dir <- output_dir
18	10x	invisible(self)
19		},
20		#' @description Finalizes a `Renderer` object.
21		finalize = function() {
22	10x	unlink(private$output_dir, recursive = TRUE)
23		},
24		#' @description getting the `Rmd` text which could be easily rendered later.
25		#'
26		#' @param blocks `list` of `c("TextBlock", "PictureBlock", "NewpageBlock")` objects.
27		#' @param yaml_header `character` a `rmarkdown` `yaml` header.
28		#' @param global_knitr `list` a global `knitr` parameters, like echo.
29		#' But if local parameter is set it will have priority.
30		#' Defaults to empty `list()`.
31		#' @return `character` a `Rmd` text (`yaml` header + body), ready to be rendered.
32		#' @examples
33		#' card1 <- teal.reporter:::ReportCard$new()
34		#'
35		#' card1$append_text("Header 2 text", "header2")
36		#' card1$append_text("A paragraph of default text")
37		#' card1$append_plot(
38		#' ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()
39		#' )
40		#'
41		#' card2 <- teal.reporter:::ReportCard$new()
42		#'
43		#' card2$append_text("Header 2 text", "header2")
44		#' card2$append_text("A paragraph of default text", "header2")
45		#' lyt <- rtables::analyze(rtables::split_rows_by(rtables::basic_table(), "Day"), "Ozone", afun = mean)
46		#' table_res2 <- rtables::build_table(lyt, airquality)
47		#' card2$append_table(table_res2)
48		#' card2$append_table(iris)
49		#' card2$append_rcode("2+2", echo = FALSE)
50		#'
51		#' reporter <- teal.reporter:::Reporter$new()
52		#' reporter$append_cards(list(card1, card2))
53		#'
54		#' yaml_l <- list(
55		#' author = teal.reporter:::yaml_quoted("NEST"),
56		#' title = teal.reporter:::yaml_quoted("Report"),
57		#' date = teal.reporter:::yaml_quoted("07/04/2019"),
58		#' output = list(html_document = list(toc = FALSE))
59		#' )
60		#'
61		#' yaml_header <- teal.reporter:::md_header(yaml::as.yaml(yaml_l))
62		#' result_path <- teal.reporter:::Renderer$new()$renderRmd(reporter$get_blocks(), yaml_header)
63		renderRmd = function(blocks, yaml_header, global_knitr = list()) {
64	8x	checkmate::assert_list(blocks, c("TextBlock", "PictureBlock", "NewpageBlock", "TableBlock", "RcodeBlock"))
65	7x	if (missing(yaml_header)) {
66	2x	yaml_header <- md_header(yaml::as.yaml(list(title = "Report")))
67		}
68	7x	parsed_yaml <- yaml_header
69	7x	parsed_global_knitr <- sprintf(
70	7x	"\n```{r setup, include=FALSE}\nknitr::opts_chunk$set(%s)\n```\n",
71	7x	capture.output(dput(global_knitr))
72		)
73	7x	parsed_blocks <- paste(
74	7x	unlist(
75	7x	lapply(blocks, function(b) private$block2md(b))
76		),
77	7x	collapse = "\n\n"
78		)
79
80	7x	rmd_text <- paste0(parsed_yaml, "\n", parsed_global_knitr, "\n", parsed_blocks, "\n")
81	7x	tmp <- tempfile(fileext = ".Rmd")
82	7x	input_path <- file.path(
83	7x	private$output_dir,
84	7x	sprintf("input_%s.Rmd", gsub("[.]", "", format(Sys.time(), "%Y%m%d%H%M%OS3")))
85		)
86	7x	cat(rmd_text, file = input_path)
87	7x	input_path
88		},
89		#' @description Renders the content of this `Report` to the output file
90		#'
91		#' @param blocks `list` of `c("TextBlock", "PictureBlock", "NewpageBlock")` objects.
92		#' @param yaml_header `character` an `rmarkdown` `yaml` header.
93		#' @param global_knitr `list` a global `knitr` parameters, like echo.
94		#' But if local parameter is set it will have priority.
95		#' Defaults to empty `list()`.
96		#' @param ... `rmarkdown::render` arguments, `input` and `output_dir` should not be updated.
97		#' @return `character` path to the output
98		#' @examples
99		#' card1 <- teal.reporter:::ReportCard$new()
100		#' card1$append_text("Header 2 text", "header2")
101		#' card1$append_text("A paragraph of default text")
102		#' card1$append_plot(
103		#' ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()
104		#' )
105		#'
106		#' card2 <- teal.reporter:::ReportCard$new()
107		#' card2$append_text("Header 2 text", "header2")
108		#' card2$append_text("A paragraph of default text", "header2")
109		#' lyt <- rtables::analyze(rtables::split_rows_by(rtables::basic_table(), "Day"), "Ozone", afun = mean)
110		#' table_res2 <- rtables::build_table(lyt, airquality)
111		#' card2$append_table(table_res2)
112		#' card2$append_table(iris)
113		#' card2$append_rcode("2+2", echo = FALSE)
114		#'
115		#' reporter <- teal.reporter:::Reporter$new()
116		#' reporter$append_cards(list(card1, card2))
117		#'
118		#' yaml_l <- list(
119		#' author = teal.reporter:::yaml_quoted("NEST"),
120		#' title = teal.reporter:::yaml_quoted("Report"),
121		#' date = teal.reporter:::yaml_quoted("07/04/2019"),
122		#' output = list(html_document = list(toc = FALSE))
123		#' )
124		#'
125		#' yaml_header <- teal.reporter:::md_header(yaml::as.yaml(yaml_l))
126		#' result_path <- teal.reporter:::Renderer$new()$render(reporter$get_blocks(), yaml_header)
127		render = function(blocks, yaml_header, global_knitr = list(), ...) {
128	6x	args <- list(...)
129	6x	input_path <- self$renderRmd(blocks, yaml_header, global_knitr)
130	6x	args <- append(args, list(
131	6x	input = input_path,
132	6x	output_dir = private$output_dir,
133	6x	output_format = "all",
134	6x	quiet = TRUE
135		))
136	6x	args_nams <- unique(names(args))
137	6x	args <- lapply(args_nams, function(x) args[[x]])
138	6x	names(args) <- args_nams
139	6x	do.call(rmarkdown::render, args)
140		},
141		#' @description get `output_dir` field
142		#'
143		#' @return `character` a `output_dir` field path.
144		#' @examples
145		#' renderer <- teal.reporter:::Renderer$new()
146		#' renderer$get_output_dir()
147		get_output_dir = function() {
148	7x	private$output_dir
149		}
150		),
151		private = list(
152		output_dir = character(0),
153		# factory method
154		block2md = function(block) {
155	25x	if (inherits(block, "TextBlock")) {
156	14x	private$textBlock2md(block)
157	11x	} else if (inherits(block, "RcodeBlock")) {
158	!	private$rcodeBlock2md(block)
159	11x	} else if (inherits(block, "PictureBlock")) {
160	7x	private$pictureBlock2md(block)
161	4x	} else if (inherits(block, "TableBlock")) {
162	2x	private$tableBlock2md(block)
163	2x	} else if (inherits(block, "NewpageBlock")) {
164	2x	block$get_content()
165		} else {
166	!	stop("Unknown block class")
167		}
168		},
169		# card specific methods
170		textBlock2md = function(block) {
171	14x	text_style <- block$get_style()
172	14x	block_content <- block$get_content()
173	14x	switch(text_style,
174	2x	"default" = block_content,
175	!	"verbatim" = sprintf("\n```\n%s\n```\n", block_content),
176	12x	"header2" = paste0("## ", block_content),
177	!	"header3" = paste0("### ", block_content),
178	!	block_content
179		)
180		},
181		rcodeBlock2md = function(block) {
182	!	params <- block$get_params()
183	!	params <- lapply(params, function(l) if (is.character(l)) shQuote(l) else l)
184	!	block_content <- block$get_content()
185	!	sprintf(
186	!	"\n```{r, %s}\n%s\n```\n",
187	!	paste(names(params), params, sep = "=", collapse = ", "),
188	!	block_content
189		)
190		},
191		pictureBlock2md = function(block) {
192	7x	basename_pic <- basename(block$get_content())
193	7x	file.copy(block$get_content(), file.path(private$output_dir, basename_pic))
194	7x	params <- c(
195	7x	`out.width` = "'100%'",
196	7x	`out.height` = "'100%'"
197		)
198	7x	title <- block$get_title()
199	7x	if (length(title)) params["fig.cap"] <- shQuote(title)
200	7x	sprintf(
201	7x	"\n```{r, %s}\nknitr::include_graphics(path = '%s')\n```\n",
202	7x	paste(names(params), params, sep = "=", collapse = ", "),
203	7x	basename_pic
204		)
205		},
206		tableBlock2md = function(block) {
207	2x	basename_table <- basename(block$get_content())
208	2x	file.copy(block$get_content(), file.path(private$output_dir, basename_table))
209	2x	sprintf("```{r echo = FALSE}\nreadRDS('%s')\n```", basename_table)
210		}
211		),
212		lock_objects = TRUE,
213		lock_class = TRUE
214		)

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

1		#' @title `TextBlock`
2		#' @keywords internal
3		TextBlock <- R6::R6Class( # nolint: object_name_linter.
4		classname = "TextBlock",
5		inherit = ContentBlock,
6		public = list(
7		#' @description Returns a `TextBlock` object.
8		#'
9		#' @details Returns a `TextBlock` object with no content and the default style.
10		#'
11		#' @param content (`character(1)` or `character(0)`) a string assigned to this `TextBlock`
12		#' @param style (`character(1)`) one of: `"default"`, `"header2"`, `"header3"` `"verbatim"`
13		#'
14		#' @return `TextBlock`
15		#' @examples
16		#' block <- teal.reporter:::TextBlock$new()
17		#'
18		initialize = function(content = character(0), style = private$styles[1]) {
19	130x	super$set_content(content)
20	130x	self$set_style(style)
21	130x	invisible(self)
22		},
23		#' @description Sets the style of this `TextBlock`.
24		#'
25		#' @details The style has bearing on the rendering of this block.
26		#'
27		#' @param style (`character(1)`) one of: `"default"`, `"header2"`, `"header3"` `"verbatim"`
28		#' @return invisibly self
29		#' @examples
30		#' block <- teal.reporter:::TextBlock$new()
31		#' block$set_style("header2")
32		#'
33		set_style = function(style) {
34	174x	private$style <- match.arg(style, private$styles)
35	173x	invisible(self)
36		},
37		#' @description Returns the style of this `TextBlock`.
38		#'
39		#' @return `character(1)` the style of this `TextBlock`
40		#' @examples
41		#' block <- teal.reporter:::TextBlock$new()
42		#' block$get_style()
43		#'
44		get_style = function() {
45	59x	private$style
46		},
47		#' @description Returns an array of styles available to this `TextBlock`.
48		#'
49		#' @return a `character` array of styles
50		#' @examples
51		#' block <- teal.reporter:::TextBlock$new()
52		#' block$get_available_styles()
53		#'
54		get_available_styles = function() {
55	23x	private$styles
56		},
57		#' @description Create the `TextBlock` from a list.
58		#' @param x `named list` with two fields `c("text", "style")`.
59		#' Use the `get_available_styles` method to get all possible styles.
60		#' @return invisibly self
61		#' @examples
62		#' block <- teal.reporter:::TextBlock$new()
63		#' block$from_list(list(text = "sth", style = "default"))
64		from_list = function(x) {
65	36x	checkmate::assert_list(x)
66	36x	checkmate::assert_names(names(x), must.include = c("text", "style"))
67	36x	self$set_content(x$text)
68	36x	self$set_style(x$style)
69	36x	invisible(self)
70		},
71		#' @description Convert the `TextBlock` to a list.
72		#' @return `named list` with a text and style.
73		#' @examples
74		#' block <- teal.reporter:::TextBlock$new()
75		#' block$to_list()
76		to_list = function() {
77	16x	list(text = self$get_content(), style = self$get_style())
78		}
79		),
80		private = list(
81		style = character(0),
82		styles = c("default", "header2", "header3", "verbatim")
83		),
84		lock_objects = TRUE,
85		lock_class = TRUE
86		)

1		#' @title `RcodeBlock`
2		#' @keywords internal
3		RcodeBlock <- R6::R6Class( # nolint: object_name_linter.
4		classname = "RcodeBlock",
5		inherit = ContentBlock,
6		public = list(
7		#' @description Returns a `RcodeBlock` object.
8		#'
9		#' @details Returns a `RcodeBlock` object with no content and no parameters.
10		#'
11		#' @param content (`character(1)` or `character(0)`) a string assigned to this `RcodeBlock`
12		#' @param ... any `rmarkdown` R chunk parameter and it value.
13		#'
14		#' @return `RcodeBlock`
15		#' @examples
16		#' block <- teal.reporter:::RcodeBlock$new()
17		#'
18		initialize = function(content = character(0), ...) {
19	74x	super$set_content(content)
20	74x	self$set_params(list(...))
21	74x	invisible(self)
22		},
23		#' @description Sets the parameters of this `RcodeBlock`.
24		#'
25		#' @details The parameters has bearing on the rendering of this block.
26		#'
27		#' @param params (`list`) any `rmarkdown` R chunk parameter and its value.
28		#' @return invisibly self
29		#' @examples
30		#' block <- teal.reporter:::RcodeBlock$new()
31		#' block$set_params(list(echo = TRUE))
32		#'
33		set_params = function(params) {
34	132x	checkmate::assert_list(params, names = "named")
35	132x	checkmate::assert_subset(names(params), self$get_available_params())
36	132x	private$params <- params
37	132x	invisible(self)
38		},
39		#' @description Returns the parameters of this `RcodeBlock`.
40		#'
41		#' @return `character` the parameters of this `RcodeBlock`
42		#' @examples
43		#' block <- teal.reporter:::RcodeBlock$new()
44		#' block$get_params()
45		#'
46		get_params = function() {
47	3x	private$params
48		},
49		#' @description Returns an array of parameters available to this `RcodeBlock`.
50		#'
51		#' @return a `character` array of parameters
52		#' @examples
53		#' block <- teal.reporter:::RcodeBlock$new()
54		#' block$get_available_params()
55		#'
56		get_available_params = function() {
57	5x	names(knitr::opts_chunk$get())
58		},
59		#' @description Create the `RcodeBlock` from a list.
60		#' @param x `named list` with two fields `c("text", "params")`.
61		#' Use the `get_available_params` method to get all possible parameters.
62		#' @return invisibly self
63		#' @examples
64		#' block <- teal.reporter:::RcodeBlock$new()
65		#' block$from_list(list(text = "sth", params = list()))
66		from_list = function(x) {
67	3x	checkmate::assert_list(x)
68	3x	checkmate::assert_names(names(x), must.include = c("text", "params"))
69	3x	self$set_content(x$text)
70	3x	self$set_params(x$params)
71	3x	invisible(self)
72		},
73		#' @description Convert the `RcodeBlock` to a list.
74		#' @return `named list` with a text and `params`.
75		#' @examples
76		#' block <- teal.reporter:::RcodeBlock$new()
77		#' block$to_list()
78		to_list = function() {
79	3x	list(text = self$get_content(), params = self$get_params())
80		}
81		),
82		private = list(
83		params = list()
84		),
85		lock_objects = TRUE,
86		lock_class = TRUE
87		)

1		#' @title `TableBlock`
2		#' @keywords internal
3		#'
4		TableBlock <- R6::R6Class( # nolint: object_name_linter.
5		classname = "TableBlock",
6		inherit = FileBlock,
7		public = list(
8		#' @description Returns a new `TableBlock` object
9		#'
10		#' @param table (`data.frame`, `rtables`, `TableTree`, `ElementaryTable`) a table assigned to this `TableBlock`
11		#' @return a `TableBlock` object
12		#'
13		initialize = function(table) {
14	36x	if (!missing(table)) {
15	6x	self$set_content(table)
16		}
17	36x	invisible(self)
18		},
19		#' @description Sets content of this `TableBlock`.
20		#'
21		#' @details throws if argument is not a table-like object.
22		#'
23		#' @param content (`data.frame`, `rtables`, `TableTree`, `ElementaryTable`) a table assigned to this `TableBlock`
24		#' @return invisibly self
25		#' @examples
26		#' block <- teal.reporter:::TableBlock$new()
27		#' block$set_content(iris)
28		#'
29		set_content = function(content) {
30	15x	checkmate::assert_multi_class(content, private$supported_tables)
31	14x	path <- tempfile(fileext = ".rds")
32	14x	saveRDS(content, file = path)
33	14x	super$set_content(path)
34	14x	invisible(self)
35		}
36		),
37		private = list(
38		supported_tables = c("data.frame", "rtables", "TableTree", "ElementaryTable")
39		),
40		lock_objects = TRUE,
41		lock_class = TRUE
42		)

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