teal.reporter coverage - 84.41%

Files
Source

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

#' @title quoted string for `yaml`
#' @description add quoted attribute for `yaml` package
#' @param x `character`
#' @keywords internal
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
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
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 internal `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 internal `md_header()`.
#' @export
#' @examples
#' # nested so using yaml::as.yaml directly
#' as_yaml_auto(
#'   list(author = "", output = list(pdf_document = list(toc = TRUE)))
#' )
#'
#' # auto parsing for a flat list, like shiny input
#' input <- list(author = "", output = "pdf_document", toc = TRUE, keep_tex = TRUE)
#' as_yaml_auto(input)
#'
#' as_yaml_auto(list(author = "", output = "pdf_document", toc = TRUE, keep_tex = "TRUE"))
#'
#' as_yaml_auto(list(
#'   author = "", output = "pdf_document", toc = TRUE, keep_tex = TRUE,
#'   wrong = 2
#' ))
#'
#' as_yaml_auto(list(author = "", output = "pdf_document", toc = TRUE, keep_tex = 2),
#'   silent = TRUE
#' )
#'
#' input <- list(author = "", output = "pdf_document", toc = TRUE, keep_tex = "True")
#' as_yaml_auto(input)
#' as_yaml_auto(input, convert_logi = TRUE, silent = TRUE)
#' as_yaml_auto(input, silent = TRUE)
#' as_yaml_auto(input, convert_logi = FALSE, silent = TRUE)
#'
#' as_yaml_auto(
#'   list(
#'     author = "", output = "pdf_document",
#'     output = "html_document", toc = TRUE, keep_tex = TRUE
#'   ),
#'   multi_output = TRUE
#' )
#' as_yaml_auto(
#'   list(
#'     author = "", output = "pdf_document",
#'     output = "html_document", toc = "True", keep_tex = TRUE
#'   ),
#'   multi_output = TRUE
#' )
as_yaml_auto <- function(input_list,
                         as_header = TRUE,
                         convert_logi = TRUE,
                         multi_output = FALSE,
                         silent = FALSE) {
  checkmate::assert_logical(as_header)
  checkmate::assert_logical(convert_logi)
  checkmate::assert_logical(silent)
  checkmate::assert_logical(multi_output)

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

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

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

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

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

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

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

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

#' @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 `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
    #'
    append_content = function(content) {
      # example: # nolint
      # card <- ReportCard$new()$append_content(teal.reporter:::NewpageBlock$new()) # nolint
      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 `PictureBlock`
#' @keywords internal
#' @noRd
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
    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
    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`
    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`
    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.
    get_dim = function() {
      private$dim
    }
  ),
  private = list(
    supported_plots = c("ggplot", "grob", "trellis", "Heatmap"),
    type = character(0),
    title = "",
    dim = c(800, 600)
  ),
  lock_objects = TRUE,
  lock_class = TRUE
)

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

#' 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 `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.
    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.
    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.z
    #'
    #' @return `character` path to the output
    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.
    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
)

#' @title `Archiver`
#' @keywords internal
Archiver <- R6::R6Class( # nolint: object_name_linter.
  classname = "Archiver",
  public = list(
    #' @description Returns an `Archiver` object.
    #'
    #' @return an `Archiver` object
    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
    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.
    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
    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.
    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
)

#' @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`
    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
    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`
    get_params = function() {
      private$params
    },
    #' @description Returns an array of parameters available to this `RcodeBlock`.
    #'
    #' @return a `character` array of parameters
    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
    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`.
    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
    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
)

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

#' 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 `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`
    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
    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`
    get_style = function() {
      private$style
    },
    #' @description Returns an array of styles available to this `TextBlock`.
    #'
    #' @return a `character` array of 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
    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.
    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 `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`
    initialize = function() {
      super$set_content("\n\\newpage\n")
      invisible(self)
    }
  ),
  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)
    }
  )
}

1		#' @title `PictureBlock`
2		#' @keywords internal
3		#' @noRd
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		#'
12		#' @return a `PictureBlock` object
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		#'
25		#' @return invisibly self
26		set_content = function(content) {
27	31x	checkmate::assert_multi_class(content, private$supported_plots)
28	29x	path <- tempfile(fileext = ".png")
29	29x	grDevices::png(filename = path, width = private$dim[1], height = private$dim[2])
30	29x	tryCatch(
31	29x	expr = {
32	29x	if (inherits(content, "grob")) {
33	1x	grid::grid.newpage()
34	1x	grid::grid.draw(content)
35	28x	} else if (inherits(content, c("gg", "Heatmap"))) { # "Heatmap" S4 from ComplexHeatmap
36	27x	print(content)
37	1x	} else if (inherits(content, "trellis")) {
38	1x	grid::grid.newpage()
39	1x	grid::grid.draw(grid::grid.grabExpr(print(content), warn = 0, wrap.grobs = TRUE))
40		}
41	29x	super$set_content(path)
42		},
43	29x	finally = grDevices::dev.off()
44		)
45	29x	invisible(self)
46		},
47		#' @description Sets the title of this `PictureBlock`.
48		#'
49		#' @details throws if argument is not `character(1)`.
50		#'
51		#' @param title (`character(1)`) a string assigned to this `PictureBlock`
52		#'
53		#' @return invisibly self
54		set_title = function(title) {
55	5x	checkmate::assert_string(title)
56	4x	private$title <- title
57	4x	invisible(self)
58		},
59		#' @description Returns the title of this `PictureBlock`
60		#'
61		#' @return the content of this `PictureBlock`
62		get_title = function() {
63	9x	private$title
64		},
65		#' @description Sets the dimensions of this `PictureBlock`
66		#'
67		#' @param dim `numeric` figure dimensions (width and height) in pixels, length 2.
68		#'
69		#' @return `self`
70		set_dim = function(dim) {
71	6x	checkmate::assert_numeric(dim, len = 2)
72	4x	private$dim <- dim
73	4x	invisible(self)
74		},
75		#' @description Returns the dimensions of this `PictureBlock`
76		#'
77		#' @return `numeric` the array of 2 numeric values representing width and height in pixels.
78		get_dim = function() {
79	!	private$dim
80		}
81		),
82		private = list(
83		supported_plots = c("ggplot", "grob", "trellis", "Heatmap"),
84		type = character(0),
85		title = "",
86		dim = c(800, 600)
87		),
88		lock_objects = TRUE,
89		lock_class = TRUE
90		)

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		#' @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		initialize = function() {
12	10x	tmp_dir <- tempdir()
13	10x	output_dir <- file.path(tmp_dir, sprintf("report_%s", gsub("[.]", "", format(Sys.time(), "%Y%m%d%H%M%OS4"))))
14	10x	dir.create(path = output_dir)
15	10x	private$output_dir <- output_dir
16	10x	invisible(self)
17		},
18		#' @description Finalizes a `Renderer` object.
19		finalize = function() {
20	10x	unlink(private$output_dir, recursive = TRUE)
21		},
22		#' @description getting the `Rmd` text which could be easily rendered later.
23		#'
24		#' @param blocks `list` of `c("TextBlock", "PictureBlock", "NewpageBlock")` objects.
25		#' @param yaml_header `character` a `rmarkdown` `yaml` header.
26		#' @param global_knitr `list` a global `knitr` parameters, like echo.
27		#' But if local parameter is set it will have priority.
28		#' Defaults to empty `list()`.
29		#'
30		#' @return `character` a `Rmd` text (`yaml` header + body), ready to be rendered.
31		renderRmd = function(blocks, yaml_header, global_knitr = list()) {
32	8x	checkmate::assert_list(blocks, c("TextBlock", "PictureBlock", "NewpageBlock", "TableBlock", "RcodeBlock"))
33	7x	if (missing(yaml_header)) {
34	2x	yaml_header <- md_header(yaml::as.yaml(list(title = "Report")))
35		}
36	7x	parsed_yaml <- yaml_header
37	7x	parsed_global_knitr <- sprintf(
38	7x	"\n```{r setup, include=FALSE}\nknitr::opts_chunk$set(%s)\n```\n",
39	7x	capture.output(dput(global_knitr))
40		)
41	7x	parsed_blocks <- paste(
42	7x	unlist(
43	7x	lapply(blocks, function(b) private$block2md(b))
44		),
45	7x	collapse = "\n\n"
46		)
47
48	7x	rmd_text <- paste0(parsed_yaml, "\n", parsed_global_knitr, "\n", parsed_blocks, "\n")
49	7x	tmp <- tempfile(fileext = ".Rmd")
50	7x	input_path <- file.path(
51	7x	private$output_dir,
52	7x	sprintf("input_%s.Rmd", gsub("[.]", "", format(Sys.time(), "%Y%m%d%H%M%OS3")))
53		)
54	7x	cat(rmd_text, file = input_path)
55	7x	input_path
56		},
57		#' @description Renders the content of this `Report` to the output file
58		#'
59		#' @param blocks `list` of `c("TextBlock", "PictureBlock", "NewpageBlock")` objects.
60		#' @param yaml_header `character` an `rmarkdown` `yaml` header.
61		#' @param global_knitr `list` a global `knitr` parameters, like echo.
62		#' But if local parameter is set it will have priority.
63		#' Defaults to empty `list()`.
64		#' @param ... `rmarkdown::render` arguments, `input` and `output_dir` should not be updated.z
65		#'
66		#' @return `character` path to the output
67		render = function(blocks, yaml_header, global_knitr = list(), ...) {
68	6x	args <- list(...)
69	6x	input_path <- self$renderRmd(blocks, yaml_header, global_knitr)
70	6x	args <- append(args, list(
71	6x	input = input_path,
72	6x	output_dir = private$output_dir,
73	6x	output_format = "all",
74	6x	quiet = TRUE
75		))
76	6x	args_nams <- unique(names(args))
77	6x	args <- lapply(args_nams, function(x) args[[x]])
78	6x	names(args) <- args_nams
79	6x	do.call(rmarkdown::render, args)
80		},
81		#' @description get `output_dir` field
82		#'
83		#' @return `character` a `output_dir` field path.
84		get_output_dir = function() {
85	7x	private$output_dir
86		}
87		),
88		private = list(
89		output_dir = character(0),
90		# factory method
91		block2md = function(block) {
92	25x	if (inherits(block, "TextBlock")) {
93	14x	private$textBlock2md(block)
94	11x	} else if (inherits(block, "RcodeBlock")) {
95	!	private$rcodeBlock2md(block)
96	11x	} else if (inherits(block, "PictureBlock")) {
97	7x	private$pictureBlock2md(block)
98	4x	} else if (inherits(block, "TableBlock")) {
99	2x	private$tableBlock2md(block)
100	2x	} else if (inherits(block, "NewpageBlock")) {
101	2x	block$get_content()
102		} else {
103	!	stop("Unknown block class")
104		}
105		},
106		# card specific methods
107		textBlock2md = function(block) {
108	14x	text_style <- block$get_style()
109	14x	block_content <- block$get_content()
110	14x	switch(text_style,
111	2x	"default" = block_content,
112	!	"verbatim" = sprintf("\n```\n%s\n```\n", block_content),
113	12x	"header2" = paste0("## ", block_content),
114	!	"header3" = paste0("### ", block_content),
115	!	block_content
116		)
117		},
118		rcodeBlock2md = function(block) {
119	!	params <- block$get_params()
120	!	params <- lapply(params, function(l) if (is.character(l)) shQuote(l) else l)
121	!	block_content <- block$get_content()
122	!	sprintf(
123	!	"\n```{r, %s}\n%s\n```\n",
124	!	paste(names(params), params, sep = "=", collapse = ", "),
125	!	block_content
126		)
127		},
128		pictureBlock2md = function(block) {
129	7x	basename_pic <- basename(block$get_content())
130	7x	file.copy(block$get_content(), file.path(private$output_dir, basename_pic))
131	7x	params <- c(
132	7x	`out.width` = "'100%'",
133	7x	`out.height` = "'100%'"
134		)
135	7x	title <- block$get_title()
136	7x	if (length(title)) params["fig.cap"] <- shQuote(title)
137	7x	sprintf(
138	7x	"\n```{r, %s}\nknitr::include_graphics(path = '%s')\n```\n",
139	7x	paste(names(params), params, sep = "=", collapse = ", "),
140	7x	basename_pic
141		)
142		},
143		tableBlock2md = function(block) {
144	2x	basename_table <- basename(block$get_content())
145	2x	file.copy(block$get_content(), file.path(private$output_dir, basename_table))
146	2x	sprintf("```{r echo = FALSE}\nreadRDS('%s')\n```", basename_table)
147		}
148		),
149		lock_objects = TRUE,
150		lock_class = TRUE
151		)

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		initialize = function() {
10	3x	invisible(self)
11		},
12		#' @description Finalizes an `Archiver` object.
13		finalize = function() {
14		# destructor
15		},
16		#' @description Pure virtual method for reading an `Archiver`.
17		read = function() {
18		# returns Reporter instance
19	1x	stop("Pure virtual method.")
20		},
21		#' @description Pure virtual method for writing an `Archiver`.
22		write = function() {
23	1x	stop("Pure virtual method.")
24		}
25		),
26		lock_objects = TRUE,
27		lock_class = TRUE
28		)
29
30		#' @title `RDSArchiver`
31		#' @keywords internal
32		FileArchiver <- R6::R6Class( # nolint: object_name_linter.
33		classname = "FileArchiver",
34		inherit = Archiver,
35		public = list(
36		#' @description Returns a `FileArchiver` object.
37		#'
38		#' @return a `FileArchiver` object
39		initialize = function() {
40	10x	tmp_dir <- tempdir()
41	10x	output_dir <- file.path(tmp_dir, sprintf("archive_%s", gsub("[.]", "", format(Sys.time(), "%Y%m%d%H%M%OS4"))))
42	10x	dir.create(path = output_dir)
43	10x	private$output_dir <- output_dir
44	10x	invisible(self)
45		},
46		#' @description Finalizes a `FileArchiver` object.
47		finalize = function() {
48	10x	unlink(private$output_dir, recursive = TRUE)
49		},
50		#' @description get `output_dir` field
51		#'
52		#' @return `character` a `output_dir` field path.
53		get_output_dir = function() {
54	9x	private$output_dir
55		}
56		),
57		private = list(
58		output_dir = character(0)
59		)
60		)
61
62		#' @title `JSONArchiver`
63		#' @keywords internal
64		JSONArchiver <- R6::R6Class( # nolint: object_name_linter.
65		classname = "JSONArchiver",
66		inherit = FileArchiver,
67		public = list(
68		#' @description write a `Reporter` instance in to this `JSONArchiver` object.
69		#'
70		#' @param reporter `Reporter` instance.
71		#'
72		#' @return invisibly self
73		write = function(reporter) {
74	1x	checkmate::assert_class(reporter, "Reporter")
75	1x	unlink(list.files(private$output_dir, recursive = TRUE, full.names = TRUE))
76	1x	reporter$to_jsondir(private$output_dir)
77	1x	self
78		},
79		#' @description read a `Reporter` instance from a directory with `JSONArchiver`.
80		#'
81		#' @param path `character(1)` a path to the directory with all proper files.
82		#'
83		#' @return `Reporter` instance.
84		read = function(path = NULL) {
85	7x	checkmate::assert(
86	7x	checkmate::check_null(path),
87	7x	checkmate::check_directory_exists(path)
88		)
89
90	7x	if (!is.null(path) && !identical(path, private$output_dir)) {
91	3x	unlink(list.files(private$output_dir, recursive = TRUE, full.names = TRUE))
92	3x	file.copy(list.files(path, full.names = TRUE), private$output_dir)
93		}
94
95	7x	if (length(list.files(private$output_dir))) {
96	6x	Reporter$new()$from_jsondir(private$output_dir)
97		} else {
98	1x	warning("The directory provided to the Archiver is empty.")
99	1x	Reporter$new()
100		}
101		}
102		),
103		lock_objects = TRUE,
104		lock_class = TRUE
105		)

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		initialize = function(content = character(0), ...) {
16	74x	super$set_content(content)
17	74x	self$set_params(list(...))
18	74x	invisible(self)
19		},
20		#' @description Sets the parameters of this `RcodeBlock`.
21		#'
22		#' @details The parameters has bearing on the rendering of this block.
23		#'
24		#' @param params (`list`) any `rmarkdown` R chunk parameter and its value.
25		#'
26		#' @return invisibly self
27		set_params = function(params) {
28	132x	checkmate::assert_list(params, names = "named")
29	132x	checkmate::assert_subset(names(params), self$get_available_params())
30	132x	private$params <- params
31	132x	invisible(self)
32		},
33		#' @description Returns the parameters of this `RcodeBlock`.
34		#'
35		#' @return `character` the parameters of this `RcodeBlock`
36		get_params = function() {
37	3x	private$params
38		},
39		#' @description Returns an array of parameters available to this `RcodeBlock`.
40		#'
41		#' @return a `character` array of parameters
42		get_available_params = function() {
43	5x	names(knitr::opts_chunk$get())
44		},
45		#' @description Create the `RcodeBlock` from a list.
46		#'
47		#' @param x `named list` with two fields `c("text", "params")`.
48		#' Use the `get_available_params` method to get all possible parameters.
49		#'
50		#' @return invisibly self
51		from_list = function(x) {
52	3x	checkmate::assert_list(x)
53	3x	checkmate::assert_names(names(x), must.include = c("text", "params"))
54	3x	self$set_content(x$text)
55	3x	self$set_params(x$params)
56	3x	invisible(self)
57		},
58		#' @description Convert the `RcodeBlock` to a list.
59		#'
60		#' @return `named list` with a text and `params`.
61		to_list = function() {
62	3x	list(text = self$get_content(), params = self$get_params())
63		}
64		),
65		private = list(
66		params = list()
67		),
68		lock_objects = TRUE,
69		lock_class = TRUE
70		)

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

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

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

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

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 `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		initialize = function(content = character(0), style = private$styles[1]) {
16	130x	super$set_content(content)
17	130x	self$set_style(style)
18	130x	invisible(self)
19		},
20		#' @description Sets the style of this `TextBlock`.
21		#'
22		#' @details The style has bearing on the rendering of this block.
23		#'
24		#' @param style (`character(1)`) one of: `"default"`, `"header2"`, `"header3"` `"verbatim"`
25		#'
26		#' @return invisibly self
27		set_style = function(style) {
28	174x	private$style <- match.arg(style, private$styles)
29	173x	invisible(self)
30		},
31		#' @description Returns the style of this `TextBlock`.
32		#'
33		#' @return `character(1)` the style of this `TextBlock`
34		get_style = function() {
35	59x	private$style
36		},
37		#' @description Returns an array of styles available to this `TextBlock`.
38		#'
39		#' @return a `character` array of styles
40		get_available_styles = function() {
41	23x	private$styles
42		},
43		#' @description Create the `TextBlock` from a list.
44		#'
45		#' @param x `named list` with two fields `c("text", "style")`.
46		#' Use the `get_available_styles` method to get all possible styles.
47		#'
48		#' @return invisibly self
49		from_list = function(x) {
50	36x	checkmate::assert_list(x)
51	36x	checkmate::assert_names(names(x), must.include = c("text", "style"))
52	36x	self$set_content(x$text)
53	36x	self$set_style(x$style)
54	36x	invisible(self)
55		},
56		#' @description Convert the `TextBlock` to a list.
57		#'
58		#' @return `named list` with a text and style.
59		to_list = function() {
60	16x	list(text = self$get_content(), style = self$get_style())
61		}
62		),
63		private = list(
64		style = character(0),
65		styles = c("default", "header2", "header3", "verbatim")
66		),
67		lock_objects = TRUE,
68		lock_class = TRUE
69		)

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

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		}