diff --git a/.lintr b/.lintr index 0a0bb22f3..49124b651 100644 --- a/.lintr +++ b/.lintr @@ -1,6 +1,5 @@ linters: linters_with_defaults( line_length_linter = line_length_linter(120), - cyclocomp_linter = NULL, object_usage_linter = NULL, indentation_linter = NULL ) diff --git a/.pre-commit-config.yaml b/.pre-commit-config.yaml index c3935c92f..aacd5607c 100755 --- a/.pre-commit-config.yaml +++ b/.pre-commit-config.yaml @@ -16,23 +16,27 @@ repos: additional_dependencies: - bslib - checkmate - #- flextable - - davidgohel/flextable # Error: package 'flextable' is not available - - davidgohel/gdtools # for flextable + - commonmark + - flextable - grid - - htmltools - knitr - lifecycle - R6 + - insightsengineering/rlistings # for rtables - rmarkdown + - insightsengineering/rtables + - insightsengineering/rtables.officer + - davidgohel/officer # for rtables.officer + - insightsengineering/formatters # for rtables - shiny - shinybusy + - shinyjs - shinyWidgets + - sortable + - insightsengineering/teal.data + - insightsengineering/teal.code - yaml - zip - - rlistings - - rtables - - rtables.officer - id: spell-check name: Check spelling with `spelling` exclude: > diff --git a/DESCRIPTION b/DESCRIPTION index 7e4ab942b..9d20c79d7 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -25,43 +25,53 @@ Imports: bsicons, bslib (>= 0.8.0), checkmate (>= 2.1.0), + commonmark (>= 1.9.2), flextable (>= 0.9.2), grid, + gtsummary (>= 1.7.0), htmltools (>= 0.5.4), knitr (>= 1.42), - lifecycle (>= 0.2.0), + methods, R6, + rlang (>= 1.0.0), rlistings (>= 0.2.10), rmarkdown (>= 2.23), rtables (>= 0.6.11), rtables.officer (>= 0.0.2), shiny (>= 1.8.1), shinybusy (>= 0.3.2), - shinyjs, + shinyjs (>= 2.1.0), shinyWidgets (>= 0.5.1), sortable (>= 0.5.0), + teal.code (>= 0.6.1.9002), + teal.data (>= 0.7.0.9002), + tools, + utils, yaml (>= 1.1.0), zip (>= 1.1.0) Suggests: + chromote, DT (>= 0.13), formatR (>= 1.5), formatters (>= 0.5.10), ggplot2 (>= 3.4.3), lattice (>= 0.18-4), + lifecycle (>= 0.2.0), png, + shinytest2, testthat (>= 3.2.2), tinytex, + waldo (>= 0.2.0), withr (>= 2.0.0) VignetteBuilder: knitr, rmarkdown -RdMacros: - lifecycle Config/Needs/verdepcheck: rstudio/bslib, mllg/checkmate, - davidgohel/flextable, rstudio/htmltools, yihui/knitr, r-lib/lifecycle, - r-lib/R6, insightsengineering/rlistings, rstudio/rmarkdown, + davidgohel/flextable, ddsjoberg/gtsummary, yihui/knitr, r-lib/lifecycle, + r-lib/R6, r-lib/rlang, insightsengineering/rlistings, rstudio/rmarkdown, insightsengineering/rtables, insightsengineering/rtables.officer, - rstudio/shiny, dreamRs/shinybusy, dreamRs/shinyWidgets, + rstudio/shiny, dreamRs/shinybusy, daattali/shinyjs, dreamRs/shinyWidgets, + rstudio/sortable, insightsengineering/teal.code, insightsengineering/teal.data, yaml=vubiostat/r-yaml, r-lib/zip, rstudio/DT, yihui/formatR, insightsengineering/formatters, tidyverse/ggplot2, deepayan/lattice, cran/png, r-lib/testthat, rstudio/tinytex, r-lib/withr @@ -71,3 +81,4 @@ Language: en-US LazyData: true Roxygen: list(markdown = TRUE) RoxygenNote: 7.3.2 +Config/testthat/edition: 3 diff --git a/NAMESPACE b/NAMESPACE index 067f228cd..977486fc9 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,28 +1,51 @@ # Generated by roxygen2: do not edit by hand -S3method(print,rmd_yaml_header) +S3method("[",teal_card) +S3method("[",teal_report) +S3method("[[<-",teal_card) +S3method("metadata<-",ReportCard) +S3method("metadata<-",teal_card) +S3method(c,teal_card) +S3method(c,teal_report) +S3method(format,code_chunk) +S3method(length,ReportCard) +S3method(length,Reporter) +S3method(metadata,ReportCard) +S3method(metadata,teal_card) +S3method(srv_editor_block,default) +S3method(teal_card,default) +S3method(teal_card,qenv) +S3method(teal_card,teal_card) +S3method(teal_card,teal_report) +S3method(toHTML,default) +S3method(ui_editor_block,default) +export("metadata<-") +export("teal_card<-") export(ReportCard) export(Reporter) export(add_card_button_srv) export(add_card_button_ui) -export(as_yaml_auto) +export(as.teal_card) +export(as.teal_report) +export(code_chunk) export(download_report_button_srv) export(download_report_button_ui) +export(metadata) export(preview_report_button_srv) export(preview_report_button_ui) +export(render) export(report_load_srv) export(report_load_ui) export(reporter_previewer_srv) export(reporter_previewer_ui) export(reset_report_button_srv) export(reset_report_button_ui) -export(rmd_output_arguments) -export(rmd_outputs) export(simple_reporter_srv) export(simple_reporter_ui) -importFrom(R6,R6Class) -importFrom(checkmate,assert_string) -importFrom(grid,grid.newpage) -importFrom(lifecycle,badge) -importFrom(rmarkdown,render) -importFrom(yaml,as.yaml) +export(srv_editor_block) +export(teal_card) +export(teal_report) +export(ui_editor_block) +importFrom(teal.code,eval_code) +importFrom(teal.data,teal_data) +importFrom(tools,toHTML) diff --git a/NEWS.md b/NEWS.md index ef37e9bf9..9e90f14d6 100644 --- a/NEWS.md +++ b/NEWS.md @@ -15,6 +15,10 @@ * Added `preview_report_button_ui` and `preview_report_button_srv` to create a shiny module that creates a button to open the report previewer in a modal. * Improve error message when reporter zip file is not named correctly (#365) +### Enhancements + +* Supports `flextable` and `gtsummary` objects. + # teal.reporter 0.4.0 ### Enhancements diff --git a/R/ContentBlock.R b/R/ContentBlock.R deleted file mode 100644 index 9d3255994..000000000 --- a/R/ContentBlock.R +++ /dev/null @@ -1,80 +0,0 @@ -#' @title `ContentBlock`: A building block for report content -#' @docType class -#' @description This class represents a basic content unit in a report, -#' such as text, images, or other multimedia elements. -#' It serves as a foundation for constructing complex report structures. -#' -#' @keywords internal -ContentBlock <- R6::R6Class( # nolint: object_name_linter. - classname = "ContentBlock", - public = list( - #' @description Sets content of this `ContentBlock`. - #' - #' @param content (`any`) R object - #' - #' @return `self`, invisibly. - #' @examples - #' ContentBlock <- getFromNamespace("ContentBlock", "teal.reporter") - #' block <- ContentBlock$new() - #' block$set_content("Base64 encoded picture") - #' - set_content = function(content) { - private$content <- content - invisible(self) - }, - #' @description Retrieves the content assigned to this block. - #' - #' @return object stored in a `private$content` field - #' @examples - #' ContentBlock <- getFromNamespace("ContentBlock", "teal.reporter") - #' block <- ContentBlock$new() - #' block$get_content() - #' - get_content = function() { - private$content - }, - #' @description Create the `ContentBlock` from a list. - #' - #' @param x (`named list`) with two fields `text` and `style`. - #' Use the `get_available_styles` method to get all possible styles. - #' - #' @return `self`, invisibly. - from_list = function(x) { - invisible(self) - }, - #' @description Convert the `ContentBlock` to a list. - #' - #' @return `named list` with a text and style. - to_list = function() { - list() - } - ), - private = list( - content = NULL, # this can be any R object - # @description The copy constructor. - # - # @param name (`character(1)`) the name of the field - # @param value the value assigned to the field - # - # @return the value of the copied field - deep_clone = function(name, value) { - if (name == "content" && checkmate::test_file_exists(value)) { - extension <- "" - split <- strsplit(basename(value), split = "\\.") - # The below ensures no extension is found for files such as this: .gitignore but is found for files like - # .gitignore.txt - if (length(split[[1]]) > 1 && split[[1]][length(split[[1]]) - 1] != "") { - extension <- split[[1]][length(split[[1]])] - extension <- paste0(".", extension) - } - copied_file <- tempfile(fileext = extension) - file.copy(value, copied_file, copy.date = TRUE, copy.mode = TRUE) - copied_file - } else { - value - } - } - ), - lock_objects = TRUE, - lock_class = TRUE -) diff --git a/R/FileBlock.R b/R/FileBlock.R deleted file mode 100644 index d50d4fb1a..000000000 --- a/R/FileBlock.R +++ /dev/null @@ -1,65 +0,0 @@ -#' @title `FileBlock` -#' @docType class -#' @description -#' `FileBlock` manages file-based content in a report, -#' ensuring appropriate handling of content files. -#' -#' @keywords internal -FileBlock <- R6::R6Class( # nolint: object_name_linter. - classname = "FileBlock", - inherit = ContentBlock, - public = list( - #' @description Create the `FileBlock` from a list. - #' The list should contain one named field, `"basename"`. - #' - #' @param x (`named list`) with one field `"basename"`, a name of the file. - #' @param output_dir (`character`) with a path to the directory where a file will be copied. - #' - #' @return `self`, invisibly. - #' @examples - #' FileBlock <- getFromNamespace("FileBlock", "teal.reporter") - #' block <- FileBlock$new() - #' file_path <- tempfile(fileext = ".png") - #' saveRDS(iris, file_path) - #' block$from_list(list(basename = basename(file_path)), dirname(file_path)) - #' - from_list = function(x, output_dir) { - checkmate::assert_list(x) - checkmate::assert_names(names(x), must.include = "basename") - path <- file.path(output_dir, x$basename) - file_type <- paste0(".", tools::file_ext(path)) - checkmate::assert_file_exists(path, extension = file_type) - new_file_path <- tempfile(fileext = file_type) - file.copy(path, new_file_path) - super$set_content(new_file_path) - invisible(self) - }, - #' @description Convert the `FileBlock` to a list. - #' - #' @param output_dir (`character`) with a path to the directory where a file will be copied. - #' - #' @return `named list` with a `basename` of the file. - #' @examples - #' FileBlock <- getFromNamespace("FileBlock", "teal.reporter") - #' block <- FileBlock$new() - #' block$to_list(tempdir()) - #' - to_list = function(output_dir) { - base_name <- basename(super$get_content()) - file.copy(super$get_content(), file.path(output_dir, base_name)) - list(basename = base_name) - } - ), - private = list( - content = character(0L), - - # @description Finalize the `FileBlock`. - # - # @details Removes the temporary file created in the constructor. - finalize = function() { - try(unlink(super$get_content())) - } - ), - lock_objects = TRUE, - lock_class = TRUE -) diff --git a/R/HTMLBlock.R b/R/HTMLBlock.R deleted file mode 100644 index 70a90e335..000000000 --- a/R/HTMLBlock.R +++ /dev/null @@ -1,62 +0,0 @@ -#' @title `HTMLBlock` -#' @docType class -#' @description -#' Specialized `FileBlock` for managing HTML content in reports. -#' It's designed to handle various HTML content, and render the report as HTML, -#' however `htmlwidgets` objects can also be rendered to static document-ready format. -#' -#' @keywords internal -HTMLBlock <- R6::R6Class( # nolint: object_name_linter. - classname = "HTMLBlock", - inherit = ContentBlock, - public = list( - #' @description Initialize a `HTMLBlock` object. - #' - #' @param content An object that can be rendered as a HTML content assigned to - #' this `HTMLBlock` - #' - #' @return Object of class `HTMLBlock`, invisibly. - initialize = function(content) { - if (!missing(content)) { - checkmate::assert_multi_class(content, private$supported_types) - self$set_content(content) - } - invisible(self) - }, - - #' @description Create the `HTMLBlock` from a list. - #' - #' @param x (`named list`) with a single field `content` containing `shiny.tag`, - #' `shiny.tag.list` or `htmlwidget`. - #' - #' @return `self`, invisibly. - #' @examples - #' HTMLBlock <- getFromNamespace("HTMLBlock", "teal.reporter") - #' block <- HTMLBlock$new() - #' block$from_list(list(content = shiny::tags$div("test"))) - #' - from_list = function(x) { - checkmate::assert_list(x, types = private$supported_types) - checkmate::assert_names(names(x), must.include = "content") - self$set_content(x$content) - invisible(self) - }, - - #' @description Convert the `HTMLBlock` to a list. - #' - #' @return `named list` with a text and style. - #' @examples - #' HTMLBlock <- getFromNamespace("HTMLBlock", "teal.reporter") - #' block <- HTMLBlock$new(shiny::tags$div("test")) - #' block$to_list() - #' - to_list = function() { - list(content = self$get_content()) - } - ), - private = list( - supported_types = c("shiny.tag", "shiny.tag.list", "htmlwidget") - ), - lock_objects = TRUE, - lock_class = TRUE -) diff --git a/R/LoadReporterModule.R b/R/LoadReporterModule.R index 73451393f..3179a6c19 100644 --- a/R/LoadReporterModule.R +++ b/R/LoadReporterModule.R @@ -25,7 +25,6 @@ report_load_ui <- function(id, label = NULL) { ) } - #' @rdname load_report_button #' @return `shiny::moduleServer` #' @export @@ -94,7 +93,7 @@ load_json_report <- function(reporter, zip_path, filename) { tmp_dir <- tempdir() output_dir <- file.path(tmp_dir, sprintf("report_load_%s", gsub("[.]", "", format(Sys.time(), "%Y%m%d%H%M%OS4")))) dir.create(path = output_dir) - if (!is.null(zip_path) && grepl("report_", filename)) { + if (!is.null(zip_path) && grepl("report(er)?_", filename)) { tryCatch( expr = zip::unzip(zip_path, exdir = output_dir, junkpaths = TRUE), warning = function(cond) { @@ -143,3 +142,4 @@ load_json_report <- function(reporter, zip_path, filename) { ) } } +1 + 1 diff --git a/R/NewpageBlock.R b/R/NewpageBlock.R deleted file mode 100644 index fc17ec740..000000000 --- a/R/NewpageBlock.R +++ /dev/null @@ -1,27 +0,0 @@ -#' @title `NewpageBlock` -#' @docType class -#' @description -#' A `ContentBlock` subclass that represents a page break in a report output. -#' -#' @keywords internal -NewpageBlock <- R6::R6Class( # nolint: object_name_linter. - classname = "NewpageBlock", - inherit = ContentBlock, - public = list( - #' @description Initialize a `NewpageBlock` object. - #' - #' @details Returns a `NewpageBlock` object with no content and the default style. - #' - #' @return Object of class `NewpageBlock`, invisibly. - #' @examples - #' NewpageBlock <- getFromNamespace("NewpageBlock", "teal.reporter") - #' block <- NewpageBlock$new() - #' - initialize = function() { - super$set_content("\n\\newpage\n") - invisible(self) - } - ), - lock_objects = TRUE, - lock_class = TRUE -) diff --git a/R/PictureBlock.R b/R/PictureBlock.R deleted file mode 100644 index 24c2dd287..000000000 --- a/R/PictureBlock.R +++ /dev/null @@ -1,129 +0,0 @@ -#' @title `PictureBlock` -#' @docType class -#' @description -#' Specialized `FileBlock` for managing picture content in reports. -#' It's designed to handle plots from packages such as `ggplot2`, `grid`, or `lattice`. -#' It can save plots to files, set titles and specify dimensions. -#' -#' @keywords internal -PictureBlock <- R6::R6Class( # nolint: object_name_linter. - classname = "PictureBlock", - inherit = FileBlock, - public = list( - #' @description Initialize a `PictureBlock` object. - #' - #' @param plot (`ggplot` or `grid`) a picture in this `PictureBlock` - #' - #' @return Object of class `PictureBlock`, invisibly. - initialize = function(plot) { - if (!missing(plot)) { - self$set_content(plot) - } - invisible(self) - }, - #' @description Sets the content of this `PictureBlock`. - #' - #' @details Raises error if argument is not a `ggplot`, `grob` or `trellis` plot. - #' - #' @param content (`ggplot` or `grob` or `trellis`) a picture in this `PictureBlock` - #' - #' @return `self`, invisibly. - #' @examplesIf require("ggplot2") && require("lattice") - #' library(ggplot2) - #' library(lattice) - #' - #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter") - #' block <- PictureBlock$new() - #' block$set_content(ggplot(iris)) - #' - #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter") - #' block <- PictureBlock$new() - #' block$set_content(bwplot(1)) - #' - #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter") - #' block <- PictureBlock$new() - #' block$set_content(ggplotGrob(ggplot(iris))) - set_content = function(content) { - checkmate::assert_multi_class(content, private$supported_plots) - path <- tempfile(fileext = ".png") - grDevices::png(filename = path, width = private$dim[1], height = private$dim[2]) - tryCatch( - expr = { - if (inherits(content, "grob")) { - grid::grid.newpage() - grid::grid.draw(content) - } else if (inherits(content, c("gg", "Heatmap"))) { # "Heatmap" S4 from ComplexHeatmap - print(content) - } else if (inherits(content, "trellis")) { - grid::grid.newpage() - grid::grid.draw(grid::grid.grabExpr(print(content), warn = 0, wrap.grobs = TRUE)) - } - super$set_content(path) - }, - finally = grDevices::dev.off() - ) - invisible(self) - }, - #' @description Sets the title of this `PictureBlock`. - #' - #' @details Raises error if argument is not `character(1)`. - #' - #' @param title (`character(1)`) a string assigned to this `PictureBlock` - #' - #' @return `self`, invisibly. - #' @examples - #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter") - #' block <- PictureBlock$new() - #' block$set_title("Title") - #' - set_title = function(title) { - checkmate::assert_string(title) - private$title <- title - invisible(self) - }, - #' @description Get the title of this `PictureBlock`. - #' - #' @return The content of this `PictureBlock`. - #' @examples - #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter") - #' block <- PictureBlock$new() - #' block$get_title() - #' - get_title = function() { - private$title - }, - #' @description Sets the dimensions of this `PictureBlock`. - #' - #' @param dim (`numeric(2)`) figure dimensions (width and height) in pixels. - #' - #' @return `self`, invisibly. - #' @examples - #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter") - #' block <- PictureBlock$new() - #' block$set_dim(c(800, 600)) - #' - set_dim = function(dim) { - checkmate::assert_numeric(dim, len = 2) - private$dim <- dim - invisible(self) - }, - #' @description Get `PictureBlock` dimensions as a numeric vector. - #' - #' @return `numeric` the array of 2 numeric values representing width and height in pixels. - #' @examples - #' PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter") - #' block <- PictureBlock$new() - #' block$get_dim() - get_dim = function() { - private$dim - } - ), - private = list( - supported_plots = c("ggplot", "grob", "trellis", "Heatmap"), - type = character(0), - title = "", - dim = c(800, 600) - ), - lock_objects = TRUE, - lock_class = TRUE -) diff --git a/R/Previewer.R b/R/Previewer.R deleted file mode 100644 index 9989cd2fc..000000000 --- a/R/Previewer.R +++ /dev/null @@ -1,330 +0,0 @@ -#' Show report previewer button module -#' -#' @description `r lifecycle::badge("experimental")` -#' Provides a button that triggers showing the report preview in a modal. -#' -#' For more details see the vignette: `vignette("previewerReporter", "teal.reporter")`. -#' -#' @name reporter_previewer -#' -#' @param id (`character(1)`) `shiny` module instance id. -#' @param label (`character(1)`) label of the button. By default it is "Preview Report". -#' @param reporter (`Reporter`) instance. -#' -#' @return `NULL`. -NULL - -#' @rdname reporter_previewer -#' @export -preview_report_button_ui <- function(id, label = "Preview Report") { - checkmate::assert_string(label, null.ok = TRUE) - ns <- shiny::NS(id) - .outline_button( - ns("preview_button"), - label = shiny::tags$span( - label, - shiny::uiOutput(ns("preview_button_counter")) - ), - icon = "file-earmark-text" - ) -} - -#' @rdname reporter_previewer -#' @export -preview_report_button_srv <- function(id, reporter) { - checkmate::assert_class(reporter, "Reporter") - - shiny::moduleServer(id, function(input, output, session) { - shiny::setBookmarkExclude(c("preview_button")) - - shiny::observeEvent(reporter$get_reactive_add_card(), { - shinyjs::toggleClass( - id = "preview_button", condition = reporter$get_reactive_add_card() == 0, class = "disabled" - ) - }) - - output$preview_button_counter <- shiny::renderUI({ - shiny::tags$span( - class = "position-absolute badge rounded-pill bg-primary", - reporter$get_reactive_add_card() - ) - }) - - preview_modal <- function() { - shiny::tags$div( - class = "teal-reporter reporter-previewer-modal", - .custom_css_dependency(), - shiny::modalDialog( - easyClose = TRUE, - size = "xl", - reporter_previewer_content_ui(session$ns("preview_content")), - footer = shiny::tagList( - shiny::tags$button( - type = "button", - class = "btn btn-outline-secondary", - `data-bs-dismiss` = "modal", - NULL, - "Dismiss" - ) - ) - ) - ) - } - - shiny::observeEvent(input$preview_button, { - shiny::showModal(preview_modal()) - }) - reporter_previewer_content_srv(id = "preview_content", reporter = reporter) - }) -} - - -# deprecated ------------------------------------------------------------------------------------------------------ - - -#' Report previewer module -#' -#' @description `r lifecycle::badge("deprecated")` -#' -#' Module offers functionalities to visualize, manipulate, -#' and interact with report cards that have been added to a report. -#' It includes a previewer interface to see the cards and options to modify the report before downloading. -#' -#' Cards are saved by the `shiny` bookmarking mechanism. -#' -#' For more details see the vignette: `vignette("previewerReporter", "teal.reporter")`. -#' -#' This function is deprecated and will be removed in the next release. -#' Please use `preview_report_button_ui()` and `preview_report_button_srv()` -#' to create a preview button that opens a modal with the report preview. -#' -#' @details `r global_knitr_details()` -#' -#' @name reporter_previewer_deprecated -#' -#' @param id (`character(1)`) `shiny` module instance id. -#' @param reporter (`Reporter`) instance. -#' @param global_knitr (`list`) of `knitr` parameters (passed to `knitr::opts_chunk$set`) -#' for customizing the rendering process. -#' @param previewer_buttons (`character`) set of modules to include with `c("download", "load", "reset")` possible -#' values and `"download"` is required. -#' Default `c("download", "load", "reset")` -#' @inheritParams reporter_download_inputs -#' -#' @return `NULL`. -NULL - -#' @rdname reporter_previewer_deprecated -#' @export -reporter_previewer_ui <- function(id) { - ns <- shiny::NS(id) - lifecycle::deprecate_soft( - when = "0.5.0", - what = "reporter_previewer_ui()", - details = paste( - "Calling `reporter_previewer_ui()` is deprecated and will be removed in the next release.\n", - "Please use `report_load_ui()`, `download_report_button_ui()`, `reset_report_button_ui()`,", - "and `preview_report_button_ui()` instead." - ) - ) - bslib::page_fluid( - shiny::tagList( - shinyjs::useShinyjs(), - shiny::tags$div( - class = "well", - style = "display: inline-flex; flex-direction: row; gap: 10px;", - shiny::tags$span(id = ns("load_span"), report_load_ui(ns("load"), label = "Load Report")), - shiny::tags$span( - id = ns("download_span"), download_report_button_ui(ns("download"), label = "Download Report") - ), - shiny::tags$span(id = ns("reset_span"), reset_report_button_ui(ns("reset"), label = "Reset Report")) - ), - shiny::tags$div( - reporter_previewer_content_ui(ns("previewer")) - ) - ) - ) -} - -#' @rdname reporter_previewer_deprecated -#' @export -reporter_previewer_srv <- function(id, - reporter, - global_knitr = getOption("teal.reporter.global_knitr"), - rmd_output = getOption("teal.reporter.rmd_output"), - rmd_yaml_args = getOption("teal.reporter.rmd_yaml_args"), - previewer_buttons = c("download", "load", "reset")) { - lifecycle::deprecate_soft( - when = "0.5.0", - what = "reporter_previewer_srv()", - details = paste( - "Calling `reporter_previewer_srv()` is deprecated and will be removed in the next release.\n", - "Please use `report_load_srv()`, `download_report_button_srv()`, `reset_report_button_srv()`,", - "and `preview_report_button_srv()` instead." - ) - ) - checkmate::assert_subset(previewer_buttons, c("download", "load", "reset"), empty.ok = FALSE) - checkmate::assert_true("download" %in% previewer_buttons) - checkmate::assert_class(reporter, "Reporter") - checkmate::assert_subset(names(global_knitr), names(knitr::opts_chunk$get())) - checkmate::assert_subset( - rmd_output, - c("html_document", "pdf_document", "powerpoint_presentation", "word_document"), - empty.ok = FALSE - ) - checkmate::assert_list(rmd_yaml_args, names = "named") - checkmate::assert_names( - names(rmd_yaml_args), - subset.of = c("author", "title", "date", "output", "toc"), - must.include = "output" - ) - checkmate::assert_true(rmd_yaml_args[["output"]] %in% rmd_output) - - shiny::moduleServer(id, function(input, output, session) { - if (!"load" %in% previewer_buttons) { - shinyjs::hide(id = "load_span") - } - if (!"download" %in% previewer_buttons) { - shinyjs::hide(id = "download_span") - } - if (!"reset" %in% previewer_buttons) { - shinyjs::hide(id = "reset_span") - } - report_load_srv("load", reporter = reporter) - download_report_button_srv( - "download", - reporter = reporter, - global_knitr = global_knitr, - rmd_output = rmd_output, - rmd_yaml_args = rmd_yaml_args - ) - reset_report_button_srv("reset", reporter = reporter) - reporter_previewer_content_srv("previewer", reporter = reporter) - }) -} - - -# reporter_previewer_content -------------------------------------------------------------------------------------- - -#' @keywords internal -reporter_previewer_content_ui <- function(id) { - shiny::uiOutput(shiny::NS(id, "pcards")) -} - -#' @keywords internal -reporter_previewer_content_srv <- function(id, reporter) { - shiny::moduleServer(id, function(input, output, session) { - shiny::setBookmarkExclude("card_remove_id") - report_cards <- shiny::reactive({ - shiny::req(reporter$get_reactive_add_card()) - input$reporter_cards_order - reporter$get_cards() - }) - output$pcards <- shiny::renderUI({ - cards <- report_cards() - - if (length(cards)) { - shiny::tags$div( - .custom_css_dependency(), - bslib::accordion( - id = session$ns("reporter_cards"), - class = "teal-reporter report-previewer-accordion", - lapply(names(cards), function(card_id) { - htmltools::tagAppendChildren( - tag = shiny::tags$div( - id = card_id, - `data-rank-id` = card_id, - bslib::accordion_panel( - title = cards[[card_id]]$get_name(), - icon = bslib::tooltip( - bsicons::bs_icon("arrows-move"), - "Move card" - ), - shiny::tags$div( - id = paste0("card", card_id), - lapply( - cards[[card_id]]$get_content(), - function(b) { - block_to_html(b) - } - ) - ) - ) - ), - .cssSelector = ".accordion-button", - bslib::tooltip( - shiny::tags$a( - class = "action-button", - role = "button", - style = "text-decoration: none;", - onclick = sprintf( - "Shiny.setInputValue('%s', '%s', {priority: 'event'});", - session$ns("card_remove_id"), - card_id - ), - bsicons::bs_icon("x-circle", class = "text-danger") - ), - "Remove card" - ) - ) - }) - ), - sortable::sortable_js( - css_id = session$ns("reporter_cards"), - options = sortable::sortable_options( - onSort = sortable::sortable_js_capture_input(session$ns("reporter_cards_order")), - handle = ".accordion-icon" - ) - ) - ) - } else { - shiny::tags$div( - shiny::tags$br(), - shiny::tags$p( - class = "text-danger", - shiny::tags$strong("No Cards added") - ) - ) - } - }) - - shiny::observeEvent(input$card_remove_id, { - reporter$remove_cards(ids = input$card_remove_id) - }) - - shiny::observeEvent(input$reporter_cards_order, { - reporter$reorder_cards(input$reporter_cards_order) - }) - }) -} - -#' @noRd -#' @keywords internal -block_to_html <- function(b) { - b_content <- b$get_content() - if (inherits(b, "TextBlock")) { - switch(b$get_style(), - header1 = shiny::tags$h1(b_content), - header2 = shiny::tags$h2(b_content), - header3 = shiny::tags$h3(b_content), - header4 = shiny::tags$h4(b_content), - verbatim = shiny::tags$pre(b_content), - shiny::tags$pre(b_content) - ) - } else if (inherits(b, "RcodeBlock")) { - panel_item("R Code", shiny::tags$pre(b_content)) - } else if (inherits(b, "PictureBlock")) { - shiny::tags$img(src = knitr::image_uri(b_content)) - } else if (inherits(b, "TableBlock")) { - b_table <- readRDS(b_content) - shiny::tags$pre( - flextable::htmltools_value(b_table) - ) - } else if (inherits(b, "NewpageBlock")) { - shiny::tags$br() - } else if (inherits(b, "HTMLBlock")) { - b_content - } else { - stop("Unknown block class") - } -} diff --git a/R/RcodeBlock.R b/R/RcodeBlock.R deleted file mode 100644 index 19f3b750f..000000000 --- a/R/RcodeBlock.R +++ /dev/null @@ -1,120 +0,0 @@ -#' @title `RcodeBlock` -#' @docType class -#' @description -#' Specialized `ContentBlock` designed to embed `R` code in reports. -#' -#' @keywords internal -RcodeBlock <- R6::R6Class( # nolint: object_name_linter. - classname = "RcodeBlock", - inherit = ContentBlock, - public = list( - #' @description Initialize a `RcodeBlock` object. - #' - #' @details Returns a `RcodeBlock` object with no content and no parameters. - #' - #' @param content (`character(1)` or `character(0)`) a string assigned to this `RcodeBlock` - #' @param ... any `rmarkdown` `R` chunk parameter and it value. - #' - #' @return Object of class `RcodeBlock`, invisibly. - #' @examples - #' RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter") - #' block <- RcodeBlock$new() - #' - initialize = function(content = character(0), ...) { - checkmate::assert_class(content, "character") - super$set_content(content) - self$set_params(list(...)) - invisible(self) - }, - #' @description Sets content of this `RcodeBlock`. - #' - #' @param content (`any`) R object - #' - #' @return `self`, invisibly. - #' @examples - #' RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter") - #' block <- RcodeBlock$new() - #' block$set_content("a <- 1") - #' - set_content = function(content) { - checkmate::assert_string(content) - super$set_content(content) - }, - #' @description Sets the parameters of this `RcodeBlock`. - #' - #' @details Configures `rmarkdown` chunk parameters for the `R` code block, - #' influencing its rendering and execution behavior. - #' - #' @param params (`list`) any `rmarkdown` R chunk parameter and its value. - #' - #' @return `self`, invisibly. - #' @examples - #' RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter") - #' block <- RcodeBlock$new() - #' block$set_params(list(echo = TRUE)) - #' - set_params = function(params) { - checkmate::assert_list(params, names = "named") - checkmate::assert_subset(names(params), self$get_available_params()) - private$params <- params - invisible(self) - }, - #' @description Get the parameters of this `RcodeBlock`. - #' - #' @return `character` the parameters of this `RcodeBlock`. - #' @examples - #' RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter") - #' block <- RcodeBlock$new() - #' block$get_params() - #' - get_params = function() { - private$params - }, - #' @description Get available array of parameters available to this `RcodeBlock`. - #' - #' @return A `character` array of parameters. - #' @examples - #' RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter") - #' block <- RcodeBlock$new() - #' block$get_available_params() - #' - get_available_params = function() { - names(knitr::opts_chunk$get()) - }, - #' @description Create the `RcodeBlock` from a list. - #' - #' @param x (`named list`) with two fields `text` and `params`. - #' Use the `get_available_params` method to get all possible parameters. - #' - #' @return `self`, invisibly. - #' @examples - #' RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter") - #' block <- RcodeBlock$new() - #' block$from_list(list(text = "sth", params = list())) - #' - from_list = function(x) { - checkmate::assert_list(x) - checkmate::assert_names(names(x), must.include = c("text", "params")) - self$set_content(x$text) - self$set_params(x$params) - invisible(self) - }, - #' @description Convert the `RcodeBlock` to a list. - #' - #' @return `named list` with a text and `params`. - #' @examples - #' RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter") - #' block <- RcodeBlock$new() - #' block$to_list() - #' - to_list = function() { - list(text = self$get_content(), params = self$get_params()) - } - ), - private = list( - content = character(0), - params = list() - ), - lock_objects = TRUE, - lock_class = TRUE -) diff --git a/R/Renderer.R b/R/Renderer.R deleted file mode 100644 index e586e98f7..000000000 --- a/R/Renderer.R +++ /dev/null @@ -1,289 +0,0 @@ -#' @title `Renderer` -#' @docType class -#' @description -#' A class for rendering reports from `ContentBlock` into various formats using `rmarkdown`. -#' It supports `TextBlock`, `PictureBlock`, `RcodeBlock`, `NewpageBlock`, and `TableBlock`. -#' -#' @keywords internal -Renderer <- R6::R6Class( # nolint: object_name_linter. - classname = "Renderer", - public = list( - #' @description Initialize a `Renderer` object. - #' - #' @details Creates a new instance of `Renderer` - #' with a temporary directory for storing report files. - #' - #' @return Object of class `Renderer`, invisibly. - #' @examples - #' Renderer <- getFromNamespace("Renderer", "teal.reporter") - #' Renderer$new() - #' - initialize = function() { - tmp_dir <- tempdir() - output_dir <- file.path(tmp_dir, sprintf("report_%s", gsub("[.]", "", format(Sys.time(), "%Y%m%d%H%M%OS4")))) - dir.create(path = output_dir) - private$output_dir <- output_dir - invisible(self) - }, - #' @description Getting the `Rmd` text which could be easily rendered later. - #' - #' @param blocks (`list`) of `TextBlock`, `PictureBlock` and `NewpageBlock` objects. - #' @param yaml_header (`character`) an `rmarkdown` `yaml` header. - #' @param global_knitr (`list`) of `knitr` parameters (passed to `knitr::opts_chunk$set`) - #' for customizing the rendering process. - #' @details `r global_knitr_details()` - #' - #' @return Character vector constituting `rmarkdown` text (`yaml` header + body), ready to be rendered. - #' @examplesIf require("ggplot2") - #' library(yaml) - #' library(rtables) - #' library(ggplot2) - #' - #' ReportCard <- getFromNamespace("ReportCard", "teal.reporter") - #' Reporter <- getFromNamespace("Reporter", "teal.reporter") - #' yaml_quoted <- getFromNamespace("yaml_quoted", "teal.reporter") - #' md_header <- getFromNamespace("md_header", "teal.reporter") - #' Renderer <- getFromNamespace("Renderer", "teal.reporter") - #' - #' card1 <- ReportCard$new() - #' card1$append_text("Header 2 text", "header2") - #' card1$append_text("A paragraph of default text") - #' card1$append_plot( - #' ggplot(iris, aes(x = Petal.Length)) + geom_histogram() - #' ) - #' - #' card2 <- ReportCard$new() - #' card2$append_text("Header 2 text", "header2") - #' card2$append_text("A paragraph of default text") - #' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean) - #' table_res2 <- build_table(lyt, airquality) - #' card2$append_table(table_res2) - #' card2$append_rcode("2+2", echo = FALSE) - #' - #' reporter <- Reporter$new() - #' reporter$append_cards(list(card1, card2)) - #' - #' yaml_l <- list( - #' author = yaml_quoted("NEST"), - #' title = yaml_quoted("Report"), - #' date = yaml_quoted("07/04/2019"), - #' output = list(html_document = list(toc = FALSE)) - #' ) - #' - #' yaml_header <- md_header(as.yaml(yaml_l)) - #' - #' result_path <- Renderer$new()$renderRmd(reporter$get_blocks(), yaml_header) - #' - renderRmd = function(blocks, yaml_header, global_knitr = getOption("teal.reporter.global_knitr")) { - checkmate::assert_list( - blocks, - c("TextBlock", "PictureBlock", "NewpageBlock", "TableBlock", "RcodeBlock", "HTMLBlock") - ) - checkmate::assert_subset(names(global_knitr), names(knitr::opts_chunk$get())) - if (missing(yaml_header)) { - yaml_header <- md_header(yaml::as.yaml(list(title = "Report"))) - } - - private$report_type <- get_yaml_field(yaml_header, "output") - - parsed_global_knitr <- sprintf( - "\n```{r setup, include=FALSE}\nknitr::opts_chunk$set(%s)\n%s\n```\n", - capture.output(dput(global_knitr)), - if (identical(private$report_type, "powerpoint_presentation")) { - format_code_block_function <- quote( - code_block <- function(code_text) { - df <- data.frame(code_text) - ft <- flextable::flextable(df) - ft <- flextable::delete_part(ft, part = "header") - ft <- flextable::autofit(ft, add_h = 0) - ft <- flextable::fontsize(ft, size = 7, part = "body") - ft <- flextable::bg(x = ft, bg = "lightgrey") - ft <- flextable::border_outer(ft) - if (flextable::flextable_dim(ft)$widths > 8) { - ft <- flextable::width(ft, width = 8) - } - ft - } - ) - paste(deparse(format_code_block_function), collapse = "\n") - } else { - "" - } - ) - - parsed_blocks <- paste( - unlist( - lapply(blocks, function(b) private$block2md(b)) - ), - collapse = "\n\n" - ) - - rmd_text <- paste0(yaml_header, "\n", parsed_global_knitr, "\n", parsed_blocks, "\n") - tmp <- tempfile(fileext = ".Rmd") - input_path <- file.path( - private$output_dir, - sprintf("input_%s.Rmd", gsub("[.]", "", format(Sys.time(), "%Y%m%d%H%M%OS3"))) - ) - cat(rmd_text, file = input_path) - input_path - }, - #' @description Renders the `Report` to the desired output format by compiling the `rmarkdown` file. - #' - #' @param blocks (`list`) of `TextBlock`, `PictureBlock` or `NewpageBlock` objects. - #' @param yaml_header (`character`) an `rmarkdown` `yaml` header. - #' @param global_knitr (`list`) of `knitr` parameters (passed to `knitr::opts_chunk$set`) - #' for customizing the rendering process. - #' @param ... `rmarkdown::render` arguments, `input` and `output_dir` should not be updated. - #' @details `r global_knitr_details()` - #' - #' @return `character` path to the output. - #' @examplesIf require("ggplot2") - #' library(yaml) - #' library(ggplot2) - #' - #' ReportCard <- getFromNamespace("ReportCard", "teal.reporter") - #' Reporter <- getFromNamespace("Reporter", "teal.reporter") - #' yaml_quoted <- getFromNamespace("yaml_quoted", "teal.reporter") - #' md_header <- getFromNamespace("md_header", "teal.reporter") - #' Renderer <- getFromNamespace("Renderer", "teal.reporter") - #' - #' card1 <- ReportCard$new() - #' card1$append_text("Header 2 text", "header2") - #' card1$append_text("A paragraph of default text") - #' card1$append_plot( - #' ggplot(iris, aes(x = Petal.Length)) + geom_histogram() - #' ) - #' - #' card2 <- ReportCard$new() - #' card2$append_text("Header 2 text", "header2") - #' card2$append_text("A paragraph of default text") - #' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean) - #' table_res2 <- build_table(lyt, airquality) - #' card2$append_table(table_res2) - #' card2$append_rcode("2+2", echo = FALSE) - #' - #' reporter <- Reporter$new() - #' reporter$append_cards(list(card1, card2)) - #' - #' yaml_l <- list( - #' author = yaml_quoted("NEST"), - #' title = yaml_quoted("Report"), - #' date = yaml_quoted("07/04/2019"), - #' output = list(html_document = list(toc = FALSE)) - #' ) - #' - #' yaml_header <- md_header(as.yaml(yaml_l)) - #' result_path <- Renderer$new()$render(reporter$get_blocks(), yaml_header) - #' - render = function(blocks, yaml_header, global_knitr = getOption("teal.reporter.global_knitr"), ...) { - args <- list(...) - input_path <- self$renderRmd(blocks, yaml_header, global_knitr) - args <- append(args, list( - input = input_path, - output_dir = private$output_dir, - output_format = "all", - quiet = TRUE - )) - args_nams <- unique(names(args)) - args <- lapply(args_nams, function(x) args[[x]]) - names(args) <- args_nams - do.call(rmarkdown::render, args) - }, - #' @description Get `output_dir` field. - #' - #' @return `character` a `output_dir` field path. - #' @examples - #' Renderer <- getFromNamespace("Renderer", "teal.reporter")$new() - #' Renderer$get_output_dir() - #' - get_output_dir = function() { - private$output_dir - } - ), - private = list( - output_dir = character(0), - report_type = NULL, - # factory method - block2md = function(block) { - if (inherits(block, "TextBlock")) { - private$textBlock2md(block) - } else if (inherits(block, "RcodeBlock")) { - private$rcodeBlock2md(block) - } else if (inherits(block, "PictureBlock")) { - private$pictureBlock2md(block) - } else if (inherits(block, "TableBlock")) { - private$tableBlock2md(block) - } else if (inherits(block, "NewpageBlock")) { - block$get_content() - } else if (inherits(block, "HTMLBlock")) { - private$htmlBlock2md(block) - } else { - stop("Unknown block class") - } - }, - # card specific methods - textBlock2md = function(block) { - text_style <- block$get_style() - block_content <- block$get_content() - switch(text_style, - "default" = block_content, - "verbatim" = sprintf("\n```\n%s\n```\n", block_content), - "header2" = paste0("## ", block_content), - "header3" = paste0("### ", block_content), - block_content - ) - }, - rcodeBlock2md = function(block) { - params <- block$get_params() - params <- lapply(params, function(l) if (is.character(l)) shQuote(l) else l) - if (identical(private$report_type, "powerpoint_presentation")) { - block_content_list <- split_text_block(block$get_content(), 30) - paste( - sprintf( - "\\newpage\n\n---\n\n```{r, echo=FALSE}\ncode_block(\n%s)\n```\n", - shQuote(block_content_list, type = "cmd") - ), - collapse = "\n\n" - ) - } else { - sprintf( - "\\newpage\n\n--- \n\n```{r, %s}\n%s\n```\n", - paste(names(params), params, sep = "=", collapse = ", "), - block$get_content() - ) - } - }, - pictureBlock2md = function(block) { - basename_pic <- basename(block$get_content()) - file.copy(block$get_content(), file.path(private$output_dir, basename_pic)) - params <- c( - `out.width` = "'100%'", - `out.height` = "'100%'" - ) - title <- block$get_title() - if (length(title)) params["fig.cap"] <- shQuote(title) - sprintf( - "\n```{r, echo = FALSE, %s}\nknitr::include_graphics(path = '%s')\n```\n", - paste(names(params), params, sep = "=", collapse = ", "), - basename_pic - ) - }, - tableBlock2md = function(block) { - basename_table <- basename(block$get_content()) - file.copy(block$get_content(), file.path(private$output_dir, basename_table)) - sprintf("```{r echo = FALSE}\nreadRDS('%s')\n```", basename_table) - }, - htmlBlock2md = function(block) { - basename <- basename(tempfile(fileext = ".rds")) - suppressWarnings(saveRDS(block$get_content(), file = file.path(private$output_dir, basename))) - sprintf("```{r echo = FALSE}\nreadRDS('%s')\n```", basename) - }, - - # @description Finalizes a `Renderer` object. - finalize = function() { - unlink(private$output_dir, recursive = TRUE) - } - ), - lock_objects = TRUE, - lock_class = TRUE -) diff --git a/R/ReportCard.R b/R/ReportCard.R index 4b549a9e4..893a60a4a 100644 --- a/R/ReportCard.R +++ b/R/ReportCard.R @@ -21,8 +21,7 @@ ReportCard <- R6::R6Class( # nolint: object_name_linter. #' card <- ReportCard$new() #' initialize = function() { - private$content <- list() - private$metadata <- list() + private$content <- teal_card() invisible(self) }, #' @description Appends a table to this `ReportCard`. @@ -33,10 +32,7 @@ ReportCard <- R6::R6Class( # nolint: object_name_linter. #' @examples #' card <- ReportCard$new()$append_table(iris) #' - append_table = function(table) { - self$append_content(TableBlock$new(table)) - invisible(self) - }, + append_table = function(table) self$append_content(table), #' @description Appends a html content to this `ReportCard`. #' #' @param content An object that can be rendered as a HTML content. @@ -44,10 +40,7 @@ ReportCard <- R6::R6Class( # nolint: object_name_linter. #' @examples #' card <- ReportCard$new()$append_html(shiny::div("HTML Content")) #' - append_html = function(content) { - self$append_content(HTMLBlock$new(content)) - invisible(self) - }, + append_html = function(content) self$append_content(content), #' @description Appends a plot to this `ReportCard`. #' #' @param plot (`ggplot` or `grob` or `trellis`) plot object. @@ -60,26 +53,24 @@ ReportCard <- R6::R6Class( # nolint: object_name_linter. #' ggplot(iris, aes(x = Petal.Length)) + geom_histogram() #' ) #' - append_plot = function(plot, dim = NULL) { - pb <- PictureBlock$new() - if (!is.null(dim) && length(dim) == 2) { - pb$set_dim(dim) - } - pb$set_content(plot) - self$append_content(pb) - invisible(self) - }, + append_plot = function(plot, dim = NULL) self$append_content(plot), #' @description Appends a text paragraph to this `ReportCard`. #' #' @param text (`character`) The text content to add. - #' @param style (`character(1)`) the style of the paragraph. One of: `r TextBlock$new()$get_available_styles()`. + #' @param style (`character(1)`) the style of the paragraph. #' @return `self`, invisibly. #' @examples #' card <- ReportCard$new()$append_text("A paragraph of default text") #' - append_text = function(text, style = TextBlock$new()$get_available_styles()[1]) { - self$append_content(TextBlock$new(text, style)) - invisible(self) + append_text = function(text, style = c("default", "header2", "header3", "verbatim")) { + styled <- switch(match.arg(style), + "default" = text, + "verbatim" = sprintf("\n```\n%s\n```\n", text), + "header2" = paste0("## ", text), + "header3" = paste0("### ", text), + text + ) + self$append_content(styled) }, #' @description Appends an `R` code chunk to `ReportCard`. #' @@ -90,41 +81,35 @@ ReportCard <- R6::R6Class( # nolint: object_name_linter. #' card <- ReportCard$new()$append_rcode("2+2", echo = FALSE) #' append_rcode = function(text, ...) { - self$append_content(RcodeBlock$new(text, ...)) - invisible(self) + self$append_content(code_chunk(code = text, ...)) }, - #' @description Appends a generic `ContentBlock` to this `ReportCard`. + #' @description Appends a generic content to this `ReportCard`. #' - #' @param content (`ContentBlock`) object. + #' @param content (Object.) #' @return `self`, invisibly. #' @examples - #' NewpageBlock <- getFromNamespace("NewpageBlock", "teal.reporter") - #' card <- ReportCard$new()$append_content(NewpageBlock$new()) + #' card <- ReportCard$new()$append_content(code_chunk("foo <- 2")) #' append_content = function(content) { - checkmate::assert_class(content, "ContentBlock") - private$content <- append(private$content, content) + private$content <- c(private$content, content) invisible(self) }, #' @description Get all content blocks from this `ReportCard`. #' - #' @return `list()` list of `TableBlock`, `TextBlock` and `PictureBlock`. + #' @return `teal_card()` containing appended elements. #' @examples #' card <- ReportCard$new()$append_text("Some text")$append_metadata("rc", "a <- 2 + 2") #' #' card$get_content() #' #' - get_content = function() { - private$content - }, + get_content = function() private$content, #' @description Clears all content and metadata from `ReportCard`. #' #' @return `self`, invisibly. #' reset = function() { - private$content <- list() - private$metadata <- list() + private$content <- teal_card() invisible(self) }, #' @description Get the metadata associated with `ReportCard`. @@ -136,7 +121,7 @@ ReportCard <- R6::R6Class( # nolint: object_name_linter. #' card$get_metadata() #' get_metadata = function() { - private$metadata + metadata(private$content) }, #' @description Appends metadata to this `ReportCard`. #' @@ -155,10 +140,8 @@ ReportCard <- R6::R6Class( # nolint: object_name_linter. #' 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) + checkmate::assert_false(key %in% names(metadata(private$content))) + metadata(private$content, key) <- value invisible(self) }, #' @description Get the name of the `ReportCard`. @@ -167,7 +150,7 @@ ReportCard <- R6::R6Class( # nolint: object_name_linter. #' @examples #' ReportCard$new()$set_name("NAME")$get_name() get_name = function() { - private$name + metadata(private$content, "title") %||% character(0L) }, #' @description Set the name of the `ReportCard`. #' @@ -176,10 +159,14 @@ ReportCard <- R6::R6Class( # nolint: object_name_linter. #' @examples #' ReportCard$new()$set_name("NAME")$get_name() set_name = function(name) { - checkmate::assert_character(name) - private$name <- name + metadata(private$content, "title") <- name invisible(self) }, + #' @description Set content block names for compatibility with newer `teal_card` + #' @param new_names (`character`) vector of new names. + set_content_names = function(new_names) { + names(private$content) <- new_names + }, #' @description Convert the `ReportCard` to a list, including content and metadata. #' @param output_dir (`character`) with a path to the directory where files will be copied. #' @return (`named list`) a `ReportCard` representation. @@ -194,25 +181,11 @@ ReportCard <- R6::R6Class( # nolint: object_name_linter. #' #' card$to_list(tempdir()) #' - to_list = function(output_dir) { - new_blocks <- list() - for (block in self$get_content()) { - block_class <- class(block)[1] - formal_args <- formalArgs(block$to_list) - cblock <- if ("output_dir" %in% formal_args) { - block$to_list(output_dir) - } else { - block$to_list() - } - new_block <- list() - new_block[[block_class]] <- cblock - new_blocks <- c(new_blocks, new_block) + to_list = function(output_dir = lifecycle::deprecated()) { + if (lifecycle::is_present(output_dir)) { + lifecycle::deprecate_soft("1.0.0", "ReportCard$to_list(output_dir)") } - new_card <- list() - new_card[["blocks"]] <- new_blocks - new_card[["metadata"]] <- self$get_metadata() - new_card[["name"]] <- self$get_name() - new_card + private$content }, #' @description Reconstructs the `ReportCard` from a list representation. #' @param card (`named list`) a `ReportCard` representation. @@ -229,42 +202,16 @@ ReportCard <- R6::R6Class( # nolint: object_name_linter. #' #' ReportCard$new()$from_list(card$to_list(tempdir()), tempdir()) #' - from_list = function(card, output_dir) { + from_list = function(card, output_dir = lifecycle::deprecated()) { self$reset() - blocks <- card$blocks - metadata <- card$metadata - name <- card$name - if (length(name) == 0) name <- character(0) - blocks_names <- names(blocks) - blocks_names <- gsub("[.][0-9]*$", "", blocks_names) - for (iter_b in seq_along(blocks)) { - block_class <- blocks_names[iter_b] - block <- blocks[[iter_b]] - instance <- private$dispatch_block(block_class) - formal_args <- formalArgs(instance$new()$from_list) - cblock <- if (all(c("x", "output_dir") %in% formal_args)) { - instance$new()$from_list(block, output_dir) - } else if ("x" %in% formal_args) { - instance$new()$from_list(block) - } else { - instance$new()$from_list() - } - self$append_content(cblock) - } - for (meta in names(metadata)) { - self$append_metadata(meta, metadata[[meta]]) - } - self$set_name(name) + private$content <- card invisible(self) } ), private = list( content = list(), - metadata = list(), - name = character(0), - dispatch_block = function(block_class) { - eval(str2lang(block_class)) - }, + name = character(0L), + id = character(0L), # @description The copy constructor. # # @param name the name of the field @@ -273,13 +220,19 @@ ReportCard <- R6::R6Class( # nolint: object_name_linter. # 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 - } - }) + content <- Reduce( + f = function(result, this) { + if (inherits(this, "R6")) { + this <- this$clone(deep = TRUE) + } + c(result, this) + }, + init = teal_card(), + x = value + ) + + metadata(content) <- metadata(value) + content } else { value } @@ -288,3 +241,8 @@ ReportCard <- R6::R6Class( # nolint: object_name_linter. lock_objects = TRUE, lock_class = TRUE ) + +#' @export +length.ReportCard <- function(x) { + length(x$get_content()) +} diff --git a/R/Reporter.R b/R/Reporter.R index 7b365dd52..f0a159581 100644 --- a/R/Reporter.R +++ b/R/Reporter.R @@ -1,9 +1,11 @@ -#' @title `Reporter`: An `R6` class for managing report cards +#' @title `Reporter`: An `R6` class for managing reports #' @docType class #' @description #' -#' This `R6` class is designed to store and manage report cards, +#' This `R6` class is designed to store and manage reports, #' facilitating the creation, manipulation, and serialization of report-related data. +#' It supports both `ReportCard` and `teal_card` objects, allowing flexibility +#' in the types of reports that can be stored and managed. #' #' @export #' @@ -17,159 +19,216 @@ Reporter <- R6::R6Class( # nolint: object_name_linter. #' reporter <- Reporter$new() #' initialize = function() { - private$cards <- list() - private$reactive_add_card <- shiny::reactiveVal(0) + private$cards <- shiny::reactiveValues() + private$cached_html <- shiny::reactiveValues() + private$trigger_reactive <- shiny::reactiveVal(NULL) invisible(self) }, - #' @description Append one or more `ReportCard` objects to the `Reporter`. + + #' @description Append one or more `ReportCard` or `teal_card` objects to the `Reporter`. #' - #' @param cards (`ReportCard`) or a list of such objects + #' @param cards (`ReportCard` or `teal_card`) or a list of such objects #' @return `self`, invisibly. #' @examplesIf require("ggplot2") #' library(ggplot2) - #' library(rtables) - #' - #' card1 <- ReportCard$new() #' - #' card1$append_text("Header 2 text", "header2") - #' card1$append_text("A paragraph of default text") - #' card1$append_plot( - #' ggplot(iris, aes(x = Petal.Length)) + geom_histogram() - #' ) + #' card1 <- teal_card("## Header 2 text", "A paragraph of default text") + #' card1 <- c(card1, ggplot(iris, aes(x = Petal.Length)) + geom_histogram()) + #' metadata(card1, "title") <- "Card1" #' - #' card2 <- ReportCard$new() - #' - #' card2$append_text("Header 2 text", "header2") - #' card2$append_text("A paragraph of default text") - #' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean) - #' table_res2 <- build_table(lyt, airquality) - #' card2$append_table(table_res2) + #' card2 <- teal_card("Document introduction") + #' metadata(card2, "title") <- "Card2" #' #' reporter <- Reporter$new() #' reporter$append_cards(list(card1, card2)) append_cards = function(cards) { - checkmate::assert_list(cards, "ReportCard") + if (checkmate::test_multi_class(cards, classes = c("teal_card", "ReportCard"))) { + cards <- list(cards) + } + + checkmate::assert_list(cards, types = c("ReportCard", "teal_card")) + new_cards <- lapply(cards, function(x) if (inherits(x, "teal_card")) x else x$get_content()) + + if (!is.null(self$get_template())) { + new_cards <- lapply(new_cards, self$get_template()) + } + # Set up unique id for each card - names(cards) <- vapply(cards, function(card) { + names(new_cards) <- vapply(new_cards, function(card) { sprintf("card_%s", substr(rlang::hash(list(deparse1(card), Sys.time())), 1, 8)) }, character(1L)) - for (card_id in names(cards)) { - private$cards[[card_id]] <- cards[[card_id]] - private$cards_order <- c(private$cards_order, card_id) + for (card_id in names(new_cards)) { + private$cards[[card_id]] <- new_cards[[card_id]] + private$cached_html[[card_id]] <- lapply(new_cards[[card_id]], tools::toHTML) } - private$reactive_add_card(length(private$cards)) invisible(self) }, - #' @description Retrieves all `ReportCard` objects contained in the `Reporter`. + #' @description Reorders `teal_card` objects in `Reporter`. + #' @param new_order `character` vector with names of `teal_card` objects to + #' be set in this order. + #' @description Reorders `teal_card` objects in `Reporter`. + #' @return `self`, invisibly. + #' @examplesIf require("ggplot2") + #' library(ggplot2) + #' library(rtables) + #' + #' card1 <- teal_card("## Header 2 text", "A paragraph of default text") + #' card1 <- c(card1, ggplot(iris, aes(x = Petal.Length)) + geom_histogram()) + #' metadata(card1, "title") <- "Card1" + #' + #' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean) + #' table_res2 <- build_table(lyt, airquality) + #' card2 <- teal_card( + #' "## Header 2 text", + #' "A paragraph of default text", + #' table_res2 + #' ) + #' metadata(card2, "title") <- "Card2" + #' + #' reporter <- Reporter$new() + #' reporter$append_cards(list(card1, card2)) #' - #' @return A (`list`) of [`ReportCard`] objects. + #' names(reporter$get_cards()) + #' reporter$reorder_cards(c("Card2", "Card1")) + #' names(reporter$get_cards()) + reorder_cards = function(new_order) { + private$override_order <- new_order + invisible(self) + }, + #' @description Sets `ReportCard` or `teal_card` content. + #' @param card_id (`character(1)`) the unique id of the card to be replaced. + #' @param card The new object (`ReportCard` or `teal_card`) to replace the existing one. + #' @return `self`, invisibly. #' @examplesIf require("ggplot2") #' library(ggplot2) #' library(rtables) #' - #' card1 <- ReportCard$new() + #' card1 <- teal_card("## Header 2 text", "A paragraph of default text") + #' card1 <- c(card1, ggplot(iris, aes(x = Petal.Length)) + geom_histogram()) + #' metadata(card1, "title") <- "Card1" #' - #' card1$append_text("Header 2 text", "header2") - #' card1$append_text("A paragraph of default text") - #' card1$append_plot( - #' ggplot(iris, aes(x = Petal.Length)) + geom_histogram() + #' reporter <- Reporter$new() + #' reporter$append_cards(list(card1)) + #' + #' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean) + #' table_res2 <- build_table(lyt, airquality) + #' card2 <- teal_card( + #' "## Header 2 text", + #' "A paragraph of default text", + #' table_res2 #' ) + #' metadata(card2, "title") <- "Card2" + #' + #' reporter$replace_card(card2, "Card1") + #' reporter$get_cards()[[1]]$get_name() + replace_card = function(card, card_id) { + if (inherits(card, "ReportCard")) { + card <- card$get_content() + } + private$cards[[card_id]] <- card + private$cached_html[[card_id]] <- lapply(card, tools::toHTML) + invisible(self) + }, + #' @description Retrieves all `teal_card` objects contained in `Reporter`. + #' @return A (`list`) of [`teal_card`] objects. + #' @examplesIf require("ggplot2") + #' library(ggplot2) + #' library(rtables) #' - #' card2 <- ReportCard$new() + #' card1 <- teal_card("## Header 2 text", "A paragraph of default text") + #' card1 <- c(card1, ggplot(iris, aes(x = Petal.Length)) + geom_histogram()) #' - #' card2$append_text("Header 2 text", "header2") - #' card2$append_text("A paragraph of default text") #' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean) #' table_res2 <- build_table(lyt, airquality) - #' card2$append_table(table_res2) + #' card2 <- teal_card( + #' "## Header 2 text", + #' "A paragraph of default text", + #' table_res2 + #' ) #' #' reporter <- Reporter$new() #' reporter$append_cards(list(card1, card2)) #' reporter$get_cards() get_cards = function() { - private$cards[private$cards_order] + result <- if (shiny::isRunning()) { + shiny::reactiveValuesToList(private$cards) + } else { + shiny::isolate(shiny::reactiveValuesToList(private$cards)) + } + result <- Filter(Negate(is.null), result) # Exclude all cards that were removed + # Ensure that cards added after reorder are returned (as well as reordered ones that were removed are excluded) + result[union(intersect(private$override_order, names(result)), names(result))] }, - #' @description Compiles and returns all content blocks from the [`ReportCard`] in the `Reporter`. - #' + #' @description Compiles and returns all content blocks from the `teal_card` + #' objects in the `Reporter`. #' @param sep An optional separator to insert between each content block. - #' Default is a `NewpageBlock$new()`object. - #' @return `list()` list of `TableBlock`, `TextBlock`, `PictureBlock` and `NewpageBlock`. + #' Default is a `\n\\newpage\n` markdown. + #' @return `list()` of `teal_card` #' @examplesIf require("ggplot2") #' library(ggplot2) #' library(rtables) #' - #' card1 <- ReportCard$new() - #' - #' card1$append_text("Header 2 text", "header2") - #' card1$append_text("A paragraph of default text") - #' card1$append_plot( - #' ggplot(iris, aes(x = Petal.Length)) + geom_histogram() - #' ) - #' - #' card2 <- ReportCard$new() + #' card1 <- teal_card("## Header 2 text", "A paragraph of default text") + #' card1 <- c(card1, ggplot(iris, aes(x = Petal.Length)) + geom_histogram()) #' - #' card2$append_text("Header 2 text", "header2") - #' card2$append_text("A paragraph of default text") #' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean) #' table_res2 <- build_table(lyt, airquality) - #' card2$append_table(table_res2) + #' card2 <- teal_card( + #' "## Header 2 text", + #' "A paragraph of default text", + #' table_res2 + #' ) #' #' reporter <- Reporter$new() #' reporter$append_cards(list(card1, card2)) #' reporter$get_blocks() - #' - get_blocks = function(sep = 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)) + get_blocks = function(sep = "\\newpage") { + cards <- self$get_cards() + blocks <- teal_card() + for (idx in seq_along(cards)) { + card <- cards[[idx]] + title <- trimws(metadata(card, "title")) + metadata(card)$title <- NULL + card_title <- if (length(title) > 0 && nzchar(title)) { + sprintf("# %s", title) + } else { + sprintf("# _Unnamed Card (%d)_", idx) } - blocks <- append(blocks, private$cards[[length(private$cards)]]$get_content()) + blocks <- c(blocks, as.teal_card(card_title), card) + if (idx != length(cards) && length(sep)) blocks <- c(blocks, trimws(sep)) } blocks }, - #' @description Resets the `Reporter`, removing all [`ReportCard`] objects and metadata. + #' @description Resets the `Reporter`, removing all `teal_card` objects and metadata. #' #' @return `self`, invisibly. #' reset = function() { - private$cards <- list() + if (shiny::isRunning()) { + for (card_id in names(private$cards)) private$cards[[card_id]] <- NULL + } else { + private$cards <- shiny::reactiveValues() + } + private$override_order <- character(0L) private$metadata <- list() - private$reactive_add_card(0) - private$cards_order <- c() invisible(self) }, - #' @description Removes specific `ReportCard` objects from the `Reporter` by their indices. + #' @description Removes specific `teal_card` objects from the `Reporter` by their indices. #' - #' @param ids (`character`) the ids of the cards to be removed. + #' @param ids (`integer`, `character`) the indexes of cards (either name) #' @return `self`, invisibly. - remove_cards = function(ids) { - if (!is.null(ids)) { - private$cards <- private$cards[!names(private$cards) %in% ids] - private$cards_order <- private$cards_order[!private$cards_order %in% ids] + remove_cards = function(ids = NULL) { + checkmate::assert( + checkmate::check_null(ids), + checkmate::check_integer(ids, min.len = 1, max.len = length(private$cards)), + checkmate::check_character(ids, min.len = 1, max.len = length(private$cards)) + ) + for (card_id in ids) { + private$cards[[card_id]] <- NULL } - private$reactive_add_card(length(private$cards)) invisible(self) }, - #' @description Reorders `ReportCard` or `ReportDocument` objects in `Reporter`. - #' @param new_order `character` vector with card ids in the desired order. - #' @return `self`, invisibly. - reorder_cards = function(new_order) { - private$cards_order <- new_order - invisible(self) - }, - #' @description Gets the current value of the reactive variable for adding cards. - #' - #' @return `reactive_add_card` current `numeric` value of the reactive variable. - #' @note The function has to be used in the shiny reactive context. - #' @examples - #' library(shiny) - #' - #' isolate(Reporter$new()$get_reactive_add_card()) - get_reactive_add_card = function() { - private$reactive_add_card() - }, #' @description Get the metadata associated with this `Reporter`. #' #' @return `named list` of metadata to be appended. @@ -177,9 +236,7 @@ Reporter <- R6::R6Class( # nolint: object_name_linter. #' reporter <- Reporter$new()$append_metadata(list(sth = "sth")) #' reporter$get_metadata() #' - get_metadata = function() { - private$metadata - }, + get_metadata = function() private$metadata, #' @description Appends metadata to this `Reporter`. #' #' @param meta (`named list`) of metadata to be appended. @@ -221,15 +278,49 @@ Reporter <- R6::R6Class( # nolint: object_name_linter. checkmate::assert_directory_exists(output_dir) rlist <- list(name = "teal Reporter", version = "1", id = self$get_id(), cards = list()) rlist[["metadata"]] <- self$get_metadata() - for (card in self$get_cards()) { + cards <- self$get_cards() + for (i in seq_along(cards)) { # we want to have list names being a class names to indicate the class for $from_list + card <- cards[[i]] card_class <- class(card)[1] u_card <- list() - u_card[[card_class]] <- card$to_list(output_dir) + tmp <- tempfile(fileext = ".rds") + suppressWarnings(saveRDS(card, file = tmp)) + tmp_base <- basename(tmp) + file.copy(tmp, file.path(output_dir, tmp_base)) + u_card[[card_class]] <- list(name = names(cards)[i], path = tmp_base) rlist$cards <- c(rlist$cards, u_card) } rlist }, + #' @description Extracts and saves all figure elements from the `teal_card` objects in the `Reporter` to a specified directory. + #' @param output_dir (`character(1)`) a path to the directory where figures will be saved. + #' @param sub_directory (`character(1)`) a sub-directory within `output_dir` to save figures. + write_figures = function(output_dir, sub_directory = "figures") { + figures_dir <- file.path(output_dir, sub_directory) + dir.create(figures_dir, showWarnings = FALSE, recursive = TRUE) + cards <- self$get_cards() + for (card_id in names(cards)) { + card <- cards[[card_id]] + cached_html <- self$get_cached_html(card_id) + for (element_ix in seq_along(card)) { + card_element <- card[[element_ix]] + if ( + inherits(card_element, "chunk_output") && + checkmate::test_multi_class(card_element[[1]], classes = c("recordedplot", "ggplot", "grob", "trellis", "gg", "Heatmap")) + ) { + base64_image <- cached_html[[names(card)[[element_ix]]]] + if ( # Ensure we only save valid base64 images + !is.null(base64_image) && inherits(base64_image, "shiny.tag") && identical(base64_image$name, "img") && + !is.null(base64_image$attribs) && grepl("^data:image/[^;]+;base64,", base64_image$attribs$src) + ) { + b64 <- sub("^data:image/[^;]+;base64,", "", base64_image$attribs$src) + writeBin(jsonlite::base64_dec(b64), file.path(figures_dir, sprintf("card_%s_%d.png", card_id, element_ix))) + } + } + } + } + }, #' @description Reinitializes a `Reporter` from a list representation and associated files in a specified directory. #' @param rlist (`named list`) representing a `Reporter` instance. #' @param output_dir (`character(1)`) a path to the directory from which files will be copied. @@ -254,8 +345,15 @@ Reporter <- R6::R6Class( # nolint: object_name_linter. for (iter_c in seq_along(rlist$cards)) { card_class <- cards_names[iter_c] card <- rlist$cards[[iter_c]] - new_card <- eval(str2lang(card_class))$new() - new_card$from_list(card, output_dir) + if (card_class == "teal_card") { + new_card <- readRDS(file.path(output_dir, card$path)) + class(new_card) <- "teal_card" + new_card <- list(new_card) # so that it doesn't loose class and can be used in self$append_cards + names(new_card) <- card$name + } else { + new_card <- eval(str2lang(card_class))$new() + new_card$from_list(card, output_dir) + } new_cards <- c(new_cards, new_card) } } else { @@ -319,18 +417,61 @@ Reporter <- R6::R6Class( # nolint: object_name_linter. private$id <- id invisible(self) }, + ## TODO: averissimo consider alternatives to trigger the re-render of modal + #' @description Trigger report rendering of preview modal in shiny context. + #' @param val value to the passed to the reactive trigger. + #' @return `reactiveVal` value + reactive_trigger = function(val) { + if (missing(val)) { + private$trigger_reactive() + } else { + private$trigger_reactive(val) + } + }, + #' @description Get cached HTML for a specific `teal_card` by its id. + #' @param card_id (`character(1)`) the unique id of the card. + get_cached_html = function(card_id) { + if (shiny::isRunning()) { + private$cached_html[[card_id]] + } else { + shiny::isolate(private$cached_html[[card_id]]) + } + }, #' @description Get the `Reporter` id #' @return `character(1)` the `Reporter` id. - get_id = function() { - private$id - } + get_id = function() private$id, + #' @description Set template function for `teal_card` + #' Set a function that is called on every report content (of class `teal_card`) added through `$append_cards` + #' @param template (`function`) a template function. + #' @return `self`, invisibly. + #' @examples + #' + #' reporter <- teal.reporter::Reporter$new() + #' template_fun <- function(document) { + #' disclaimer <- teal.reporter::teal_card("Here comes disclaimer text") + #' c(disclaimer, document) + #' } + #' reporter$set_template(template_fun) + #' doc1 <- teal.reporter::teal_card("## Header 2 text", "Regular text") + #' metadata(doc1, "title") <- "Welcome card" + #' reporter$append_cards(doc1) + #' reporter$get_cards() + set_template = function(template) { + private$template <- template + invisible(self) + }, + #' @description Get the `Reporter` template + #' @return a template `function`. + get_template = function() private$template ), private = list( id = "", - cards = list(), + cards = NULL, # reactiveValues + cached_html = NULL, # reactiveValues + trigger_reactive = NULL, # reactiveVal to trigger reactive contexts + override_order = character(0L), # to sort cards (reactiveValues are not sortable) metadata = list(), - reactive_add_card = NULL, - cards_order = c(), + template = NULL, # @description The copy constructor. # # @param name the name of the field @@ -338,13 +479,21 @@ Reporter <- R6::R6Class( # nolint: object_name_linter. # @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 - } + shiny::isolate({ + if (name == "cards") { + new_cards <- lapply(shiny::reactiveValuesToList(value), function(card) { + if (R6::is.R6(card)) card$clone(deep = TRUE) else card + }) + do.call(shiny::reactiveValues, new_cards) + } else { + value + } + }) } ), lock_objects = TRUE, lock_class = TRUE ) + +#' @export +length.Reporter <- function(x) length(x$get_cards()) diff --git a/R/ResetModule.R b/R/ResetModule.R index c05b8ef46..5c2798f22 100644 --- a/R/ResetModule.R +++ b/R/ResetModule.R @@ -9,7 +9,7 @@ #' @name reset_report_button #' #' @param id (`character(1)`) `shiny` module instance id. -#' @param label (`character(1)`) label of the button. By default it is empty. +#' @param label (`character(1)`) label of the button. By default `NULL`. #' @param reporter (`Reporter`) instance. #' @return `NULL`. NULL @@ -18,7 +18,6 @@ NULL #' @export reset_report_button_ui <- function(id, label = NULL) { checkmate::assert_string(label, null.ok = TRUE) - .outline_button( shiny::NS(id, "reset_reporter"), label = label, @@ -35,12 +34,9 @@ reset_report_button_srv <- function(id, reporter) { shiny::moduleServer(id, function(input, output, session) { shiny::setBookmarkExclude(c("reset_reporter")) - ns <- session$ns - nr_cards <- length(reporter$get_cards()) - - shiny::observeEvent(reporter$get_reactive_add_card(), { + shiny::observeEvent(reporter$get_cards(), { shinyjs::toggleClass( - id = "reset_reporter", condition = reporter$get_reactive_add_card() == 0, class = "disabled" + id = "reset_reporter", condition = length(reporter$get_cards()) == 0, class = "disabled" ) }) @@ -66,13 +62,21 @@ reset_report_button_srv <- function(id, reporter) { NULL, "Dismiss" ), - shiny::actionButton(ns("reset_reporter_ok"), "Reset", class = "btn btn-primary") + shiny::actionButton(session$ns("reset_reporter_ok"), "Reset", class = "btn btn-primary") ) ) ) ) }) + shiny::observeEvent(reporter$get_cards(), { + if (length(reporter$get_cards())) { + shinyjs::enable("reset_reporter") + } else { + shinyjs::disable("reset_reporter") + } + }) + shiny::observeEvent(input$reset_reporter_ok, { reporter$reset() shiny::removeModal() diff --git a/R/SimpleReporter.R b/R/SimpleReporter.R index 4b7fb9bd4..1c6f67166 100644 --- a/R/SimpleReporter.R +++ b/R/SimpleReporter.R @@ -15,7 +15,7 @@ #' @param id (`character(1)`) `shiny` module instance id. #' @param reporter (`Reporter`) instance. #' @param card_fun (`function`) which returns a [`ReportCard`] instance, -#' the function has a `card` argument and an optional `comment` argument. +#' the function has a `teal_card` argument and an optional `comment` argument. #' @param global_knitr (`list`) a global `knitr` parameters for customizing the rendering process. #' @inheritParams reporter_download_inputs #' diff --git a/R/TableBlock.R b/R/TableBlock.R deleted file mode 100644 index 3c2406abb..000000000 --- a/R/TableBlock.R +++ /dev/null @@ -1,52 +0,0 @@ -#' @title `TableBlock` -#' @docType class -#' @description -#' Specialized `FileBlock` for managing table content in reports. -#' It's designed to handle various table formats, converting them into a consistent, -#' document-ready format (e.g., `flextable`) for inclusion in reports. -#' -#' @keywords internal -TableBlock <- R6::R6Class( # nolint: object_name_linter. - classname = "TableBlock", - inherit = FileBlock, - public = list( - #' @description Initialize a `TableBlock` object. - #' - #' @param table (`data.frame` or `rtables` or `TableTree` or `ElementaryTable` or `listing_df`) a table assigned to - #' this `TableBlock` - #' - #' @return Object of class `TableBlock`, invisibly. - initialize = function(table) { - if (!missing(table)) { - self$set_content(table) - } - invisible(self) - }, - #' @description Sets content of this `TableBlock`. - #' - #' @details Raises error if argument is not a table-like object. - #' - #' @param content (`data.frame` or `rtables` or `TableTree` or `ElementaryTable` or `listing_df`) - #' a table assigned to this `TableBlock` - #' - #' @return `self`, invisibly. - #' @examples - #' TableBlock <- getFromNamespace("TableBlock", "teal.reporter") - #' block <- TableBlock$new() - #' block$set_content(iris) - #' - set_content = function(content) { - checkmate::assert_multi_class(content, private$supported_tables) - content <- to_flextable(content) - path <- tempfile(fileext = ".rds") - saveRDS(content, file = path) - super$set_content(path) - invisible(self) - } - ), - private = list( - supported_tables = c("data.frame", "rtables", "TableTree", "ElementaryTable", "listing_df") - ), - lock_objects = TRUE, - lock_class = TRUE -) diff --git a/R/TextBlock.R b/R/TextBlock.R deleted file mode 100644 index a6d090785..000000000 --- a/R/TextBlock.R +++ /dev/null @@ -1,119 +0,0 @@ -#' @title `TextBlock` -#' @docType class -#' @description -#' Specialized `ContentBlock` for embedding styled text within reports. -#' It supports multiple styling options to accommodate various text roles, -#' such as headers or verbatim text, in the report content. -#' -#' @keywords internal -TextBlock <- R6::R6Class( # nolint: object_name_linter. - classname = "TextBlock", - inherit = ContentBlock, - public = list( - #' @description Initialize a `TextBlock` object. - #' - #' @details Constructs a `TextBlock` object with no content and the default style. - #' - #' @param content (`character`) a string assigned to this `TextBlock` - #' @param style (`character(1)`) one of: `"default"`, `"header2"`, `"header3"` `"verbatim"` - #' - #' @return Object of class `TextBlock`, invisibly. - #' @examples - #' TextBlock <- getFromNamespace("TextBlock", "teal.reporter") - #' block <- TextBlock$new() - #' - initialize = function(content = character(0), style = private$styles[1]) { - super$set_content(content) - self$set_style(style) - invisible(self) - }, - #' @description Sets content of this `TextBlock`. - #' - #' @param content (`any`) R object - #' - #' @return `self`, invisibly. - #' @examples - #' ContentBlock <- getFromNamespace("ContentBlock", "teal.reporter") - #' block <- ContentBlock$new() - #' block$set_content("Base64 encoded picture") - #' - set_content = function(content) { - checkmate::assert_string(content) - super$set_content(content) - }, - #' @description Sets the style of this `TextBlock`. - #' - #' @details The style has bearing on the rendering of this block. - #' - #' @param style (`character(1)`) one of: `"default"`, `"header2"`, `"header3"` `"verbatim"` - #' - #' @return `self`, invisibly. - #' @examples - #' TextBlock <- getFromNamespace("TextBlock", "teal.reporter") - #' block <- TextBlock$new() - #' block$set_style("header2") - #' - set_style = function(style) { - private$style <- match.arg(style, private$styles) - invisible(self) - }, - #' @description Get the style of this `TextBlock`. - #' - #' @return `character(1)` the style of this `TextBlock`. - #' @examples - #' TextBlock <- getFromNamespace("TextBlock", "teal.reporter") - #' block <- TextBlock$new() - #' block$get_style() - #' - get_style = function() { - private$style - }, - #' @description Get available an array of styles available to this `TextBlock`. - #' - #' @return A `character` array of styles. - #' @examples - #' TextBlock <- getFromNamespace("TextBlock", "teal.reporter") - #' block <- TextBlock$new() - #' block$get_available_styles() - #' - get_available_styles = function() { - private$styles - }, - #' @description Create the `TextBlock` from a list. - #' - #' @param x (`named list`) with two fields `text` and `style`. - #' Use the `get_available_styles` method to get all possible styles. - #' - #' @return `self`, invisibly. - #' @examples - #' TextBlock <- getFromNamespace("TextBlock", "teal.reporter") - #' block <- TextBlock$new() - #' block$from_list(list(text = "sth", style = "default")) - #' - from_list = function(x) { - checkmate::assert_list(x) - checkmate::assert_names(names(x), must.include = c("text", "style")) - self$set_content(x$text) - self$set_style(x$style) - invisible(self) - }, - #' @description Convert the `TextBlock` to a list. - #' - #' @return `named list` with a text and style. - #' @examples - #' TextBlock <- getFromNamespace("TextBlock", "teal.reporter") - #' block <- TextBlock$new() - #' block$to_list() - #' - to_list = function() { - list(text = self$get_content(), style = self$get_style()) - } - ), - private = list( - content = character(0), - style = character(0), - styles = c("default", "header2", "header3", "verbatim") - ), - lock_objects = TRUE, - lock_class = TRUE -) diff --git a/R/AddCardModule.R b/R/add_card.R similarity index 81% rename from R/AddCardModule.R rename to R/add_card.R index d87f87e7c..1159d1b32 100644 --- a/R/AddCardModule.R +++ b/R/add_card.R @@ -8,17 +8,17 @@ #' #' @details #' The `card_fun` function is designed to create a new `ReportCard` instance and optionally customize it: -#' - The `card` parameter allows for specifying a custom or default `ReportCard` instance. +#' - The `teal_card` parameter allows for specifying a custom or default `ReportCard` instance. #' - Use the `comment` parameter to add a comment to the card via `card$append_text()` - if `card_fun` does not #' have the `comment` parameter, then `comment` from `Add Card UI` module will be added at the end of the content of the #' card. #' - The `label` parameter enables customization of the card's name and its content through `card$append_text()`- #' if `card_fun` does not have the `label` parameter, then card name will be set to the name passed in -#' `Add Card UI` module, but no text will be added to the content of the `card`. +#' `Add Card UI` module, but no text will be added to the content of the `teal_card`. #' #' This module supports using a subclass of [`ReportCard`] for added flexibility. #' A subclass instance should be passed as the default value of -#' the `card` argument in the `card_fun` function. +#' the `teal_card` argument in the `card_fun` function. #' See below: #' ```{r} #' CustomReportCard <- R6::R6Class( @@ -91,14 +91,8 @@ add_card_button_srv <- function(id, reporter, card_fun) { ), shiny::tags$script( shiny::HTML( - sprintf( - " - $('#shiny-modal').on('shown.bs.modal', () => { - $('#%s').focus() - }) - ", - ns("label") - ) + sprintf("shinyjs.autoFocusModal('%s');", ns("label")), # See extendShinyJs.js + sprintf("shinyjs.enterToSubmit('%s', '%s');", ns("label"), ns("add_card_ok")) # See extendShinyJs.js ) ), footer = shiny::div( @@ -142,6 +136,8 @@ add_card_button_srv <- function(id, reporter, card_fun) { arg_list <- c(arg_list, list(label = input$label)) } + shinyjs::disable("add_card_ok") + if (has_card_arg) { # The default_card is defined here because formals() returns a pairedlist object # of formal parameter names and their default values. The values are missing @@ -168,15 +164,25 @@ add_card_button_srv <- function(id, reporter, card_fun) { msg, type = "error" ) + shinyjs::enable("add_card_ok") } 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) - } + checkmate::assert_multi_class(card, c("ReportCard", "teal_card")) + if (inherits(card, "ReportCard")) { + if (!has_comment_arg && length(input$comment) > 0 && input$comment != "") { + card$append_text("Comment", "header3") + card$append_text(input$comment) + } - if (!has_label_arg && length(input$label) == 1 && input$label != "") { - card$set_name(input$label) + if (!has_label_arg && length(input$label) == 1 && input$label != "") { + card$set_name(input$label) + } + } else if (inherits(card, "teal_card")) { + if (!has_comment_arg && length(input$comment) > 0 && input$comment != "") { + card <- c(card, "### Comment", input$comment) + } + if (!has_label_arg && length(input$label) == 1 && input$label != "") { + metadata(card, "title") <- input$label + } } reporter$append_cards(list(card)) diff --git a/R/DownloadModule.R b/R/download.R similarity index 61% rename from R/DownloadModule.R rename to R/download.R index c06cdb516..3fd32ae0c 100644 --- a/R/DownloadModule.R +++ b/R/download.R @@ -11,6 +11,7 @@ #' @name download_report_button #' #' @param id (`character(1)`) this `shiny` module's id. +#' @param label (`character(1)`) label before the icon. By default `NULL`. #' @param reporter (`Reporter`) instance. #' @param label (`character(1)`) label of the button. By default it is empty. #' @param global_knitr (`list`) of `knitr` parameters (passed to `knitr::opts_chunk$set`) @@ -24,11 +25,7 @@ NULL #' @export download_report_button_ui <- function(id, label = NULL) { checkmate::assert_string(label, null.ok = TRUE) - .outline_button( - shiny::NS(id, "download_button"), - label = label, - icon = "download" - ) + .outline_button(shiny::NS(id, "download_button"), label = label, icon = "download") } #' @rdname download_report_button @@ -54,7 +51,22 @@ download_report_button_srv <- function(id, subset.of = c("author", "title", "date", "output", "toc"), must.include = "output" ) - checkmate::assert_true(rmd_yaml_args[["output"]] %in% rmd_output) + if (!is.null(rmd_yaml_args$toc)) { + if (!is.list(rmd_yaml_args$output)) { + rmd_yaml_args$output <- structure( + list(list()), + names = rmd_yaml_args$output + ) + } + rmd_yaml_args$output[[1]]$toc <- rmd_yaml_args$toc + rmd_yaml_args$toc <- NULL + } + + checkmate::assert_true( + .var.name = "rmd_yaml_args$output", + rmd_yaml_args[["output"]] %in% rmd_output || + (length(names(rmd_yaml_args[["output"]])) > 0 && names(rmd_yaml_args[["output"]]) %in% rmd_output) + ) shiny::moduleServer(id, function(input, output, session) { shiny::setBookmarkExclude(c("download_button")) @@ -72,6 +84,7 @@ download_report_button_srv <- function(id, ), icon = shiny::icon("download") ) + shiny::tags$div( class = "teal-reporter reporter-modal", .custom_css_dependency(), @@ -110,38 +123,47 @@ download_report_button_srv <- function(id, NULL, "Dismiss" ), - downb + shiny::tags$a( + id = ns("download_data"), + class = "btn btn-primary shiny-download-link", + href = "", + target = "_blank", + download = NA, + shiny::icon("download"), + "Download" + ) ) ) ) } - shiny::observeEvent(input$download_button, { - shiny::showModal(download_modal()) + shiny::observeEvent(reporter$get_cards(), { + shinyjs::toggleState(length(reporter$get_cards()) > 0, id = "download_button") }) - shiny::observeEvent(reporter$get_reactive_add_card(), { - shinyjs::toggleClass( - id = "download_button", condition = reporter$get_reactive_add_card() == 0, class = "disabled" - ) - }) + shiny::observeEvent(input$download_button, shiny::showModal(download_modal())) output$download_data <- shiny::downloadHandler( - filename = function() { - paste0( - "report_", - if (reporter$get_id() == "") NULL else paste0(reporter$get_id(), "_"), - format(Sys.time(), "%y%m%d%H%M%S"), - ".zip" - ) - }, + filename = function() paste0(.report_identifier(reporter), ".zip"), content = function(file) { shiny::showNotification("Rendering and Downloading the document.") shinybusy::block(id = ns("download_data"), text = "", type = "dots") - input_list <- lapply(names(rmd_yaml_args), function(x) input[[x]]) - names(input_list) <- names(rmd_yaml_args) + rmd_yaml_with_inputs <- lapply(names(rmd_yaml_args), function(x) input[[x]]) + names(rmd_yaml_with_inputs) <- names(rmd_yaml_args) + if (is.logical(input$toc)) { + rmd_yaml_with_inputs$output <- structure( + list(list(dot = input$toc)), + names = rmd_yaml_with_inputs$output + ) + rmd_yaml_with_inputs$toc <- NULL # ensure toc is removed + } if (is.logical(input$showrcode)) global_knitr[["echo"]] <- input$showrcode - report_render_and_compress(reporter, input_list, global_knitr, file) + report_render_and_compress( + reporter = reporter, + rmd_yaml_args = rmd_yaml_with_inputs, + global_knitr = global_knitr, + file = file + ) shinybusy::unblock(id = ns("download_data")) }, contentType = "application/zip" @@ -154,118 +176,65 @@ download_report_button_srv <- function(id, #' 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 rmd_yaml_args (`named list`) with `Rmd` `yaml` header fields and their values. #' @param global_knitr (`list`) a global `knitr` parameters, like echo. #' But if local parameter is set it will have priority. -#' @param file (`character(1)`) where to copy the returned directory. +#' @param file (`character(1)`) where to copy created zip file. #' #' @return `file` argument, invisibly. #' #' @keywords internal -report_render_and_compress <- function(reporter, input_list, global_knitr, file = tempdir()) { +report_render_and_compress <- function(reporter, rmd_yaml_args, global_knitr, file = tempfile()) { checkmate::assert_class(reporter, "Reporter") - checkmate::assert_list(input_list, names = "named") + checkmate::assert_list(rmd_yaml_args, 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.") - } + tmp_dir <- file.path(tempdir(), .report_identifier(reporter)) - yaml_header <- as_yaml_auto(input_list) - renderer <- Renderer$new() + cards_combined <- reporter$get_blocks() + metadata(cards_combined) <- utils::modifyList(metadata(cards_combined), rmd_yaml_args) tryCatch( - renderer$render(reporter$get_blocks(), yaml_header, global_knitr), - warning = function(cond) { - print(cond) - shiny::showNotification( - ui = "Render document warning!", - action = "Please contact app developer", - type = "warning" - ) - }, + render( + input = cards_combined, + output_dir = tmp_dir, + global_knitr = global_knitr, + quiet = TRUE + ), + warning = function(cond) message("Render document warning: ", cond), error = function(cond) { - print(cond) - shiny::showNotification( - ui = "Render document error!", - action = "Please contact app developer", - type = "error" - ) + message("Render document error: ", cond) + do.call("return", args = list(), envir = parent.frame(2)) } ) - output_dir <- renderer$get_output_dir() + tryCatch( + reporter$to_jsondir(tmp_dir), + warning = function(cond) message("Archive document warning: ", cond), + error = function(cond) message("Archive document error: ", cond) + ) tryCatch( - archiver_dir <- reporter$to_jsondir(output_dir), - warning = function(cond) { - print(cond) - shiny::showNotification( - ui = "Archive document warning!", - action = "Please contact app developer", - type = "warning" - ) - }, - error = function(cond) { - print(cond) - shiny::showNotification( - ui = "Archive document error!", - action = "Please contact app developer", - type = "error" - ) - } + reporter$write_figures(tmp_dir), + warning = function(cond) message("Save reporter images warning: ", cond), + error = function(cond) message("Save reporter images error: ", cond) ) temp_zip_file <- tempfile(fileext = ".zip") tryCatch( - expr = zip::zipr(temp_zip_file, output_dir), - warning = function(cond) { - print(cond) - shiny::showNotification( - ui = "Zipping folder warning!", - action = "Please contact app developer", - type = "warning" - ) - }, - error = function(cond) { - print(cond) - shiny::showNotification( - ui = "Zipping folder error!", - action = "Please contact app developer", - type = "error" - ) - } + zip::zipr(temp_zip_file, tmp_dir), + warning = function(cond) message("Zipping folder warning: ", cond), + error = function(cond) message("Zipping folder error: ", cond) ) tryCatch( - expr = file.copy(temp_zip_file, file), - warning = function(cond) { - print(cond) - shiny::showNotification( - ui = "Copying file warning!", - action = "Please contact app developer", - type = "warning" - ) + { + file.copy(temp_zip_file, file) + unlink(tmp_dir, recursive = TRUE) }, - error = function(cond) { - print(cond) - shiny::showNotification( - ui = "Copying file error!", - action = "Please contact app developer", - type = "error" - ) - } + warning = function(cond) message("Copying file warning: ", cond), + error = function(cond) message("Copying file error: ", cond) ) - - rm(renderer) invisible(file) } @@ -293,8 +262,13 @@ reporter_download_inputs <- function(rmd_yaml_args, rmd_output, showrcode, sessi inputId = session$ns("output"), label = "Choose a document type: ", choices = rmd_output, - selected = rmd_yaml_args$output - ) + selected = if (is.list(rmd_yaml_args$output)) names(rmd_yaml_args$output) else rmd_yaml_args$output + ), + shiny::checkboxInput( + session$ns("toc"), + label = "Include Table of Contents", + value = if (is.list(rmd_yaml_args$output) && is.list(rmd_yaml_args$output[[1]])) rmd_yaml_args$output[[1]]$toc + ), ), toc = shiny::checkboxInput(session$ns("toc"), label = "Include Table of Contents", value = rmd_yaml_args$toc) ) @@ -312,11 +286,21 @@ reporter_download_inputs <- function(rmd_yaml_args, rmd_output, showrcode, sessi #' @noRd #' @keywords internal any_rcode_block <- function(reporter) { + cards <- reporter$get_cards() + + # todo: make sure code_chunk is also noticed any( vapply( reporter$get_blocks(), - function(e) inherits(e, "RcodeBlock"), - logical(1) + inherits, + logical(1), + what = "code_chunk" ) ) } + +.report_identifier <- function(reporter) { + id <- paste0("_", reporter$get_id()) %||% "" + timestamp <- format(Sys.time(), "_%y%m%d%H%M%S") + sprintf("reporter%s%s", id, timestamp) +} diff --git a/R/editor_block.R b/R/editor_block.R new file mode 100644 index 000000000..95cd98432 --- /dev/null +++ b/R/editor_block.R @@ -0,0 +1,104 @@ +#' @rdname srv_editor_block +#' @export +ui_editor_block <- function(id, value, cached_html) { + UseMethod("ui_editor_block", value) +} + +#' UI and Server functions for editing report document blocks +#' +#' These functions provide a user interface and server logic for editing and extending +#' the editor functionality to support new data types. +#' +#' @details +#' The methods for this S3 generic can be extended by the app developer to new classes +#' or even overwritten. +#' For this a function with the name `srv_editor_block.` and/or `ui_editor_block.` +#' should be defined in the Global Environment, where `` is the class of +#' the object to be used in the method. +#' +#' For example, to override the default behavior for `character` class, you can use: +#' +#' ```r +#' ui_editor_block.character <- function(id, value) { +#' # custom implementation +#' shiny::tagList( +#' shiny::tags$h6(shiny::icon("pencil", class = "text-muted"), "Editable CUSTOM markdown block"), +#' shiny::textAreaInput(ns("content"), label = NULL, value = value, width = "100%") +#' ) +#' } +#' srv_editor_block.character <- function(id, value) { +#' # custom implementation +#' # ... +#' } +#' ``` +#' +#' Alternatively, you can register the S3 method using +#' `registerS3method("ui_editor_block", "", fun)` and +#' `registerS3method("srv_editor_block", "", fun)`. +#' +#' @param id (`character(1)`) A unique identifier for the module. +#' @param value The content of the block to be edited. It can be a character string or other types. +#' @param cached_html (`shiny.tag` or `shiny.tag.list`) Cached HTML content to display in the UI. +#' @export +srv_editor_block <- function(id, value) { + UseMethod("srv_editor_block", value) +} + +#' @export +ui_editor_block.default <- function(id, value, cached_html) { + .ui_editor_block(id, value, cached_html) +} + +#' @export +srv_editor_block.default <- function(id, value) { + .srv_editor_block(id, value) +} + +#' @keywords internal +.ui_editor_block <- function(id, value, cached_html) { + UseMethod(".ui_editor_block", value) +} + +#' @keywords internal +.srv_editor_block <- function(id, value) { + UseMethod(".srv_editor_block", value) +} + +#' @method .ui_editor_block default +.ui_editor_block.default <- function(id, value, cached_html) { + shiny::tags$div( + shiny::tags$h6( + shiny::tags$span( + class = "fa-stack small text-muted", + # style = "width: 2em;", # necessary to avoid extra space after icon + shiny::icon("pencil", class = "fa-stack-1x"), + shiny::icon("ban", class = "fa-stack-2x fa-inverse text-black-50") + ), + "Non-editable block" + ), + if (is.null(cached_html)) { + tools::toHTML(value) + } else { + cached_html + } + ) +} + +#' @method .srv_editor_block default +.srv_editor_block.default <- function(id, value) { + shiny::moduleServer(id, function(input, output, session) NULL) # No input being changed, skipping update +} + +#' @method .ui_editor_block character +.ui_editor_block.character <- function(id, value, cached_html) { + ns <- shiny::NS(id) + shiny::tagList( + shiny::tags$h6(shiny::icon("pencil", class = "text-muted"), "Editable markdown block"), + shiny::textAreaInput(ns("content"), label = NULL, value = value, width = "100%") + ) +} + +#' @method .srv_editor_block character +.srv_editor_block.character <- function(id, value) { + shiny::moduleServer(id, function(input, output, session) shiny::reactive(input$content)) +} diff --git a/R/editor_card.R b/R/editor_card.R new file mode 100644 index 000000000..4d04577a0 --- /dev/null +++ b/R/editor_card.R @@ -0,0 +1,53 @@ +ui_card_editor <- function(id, value, cached_html) { + ns <- shiny::NS(id) + shiny::tagList( + shiny::tags$div( + id = ns("blocks"), + lapply(names(value), function(block_name) { + ui_editor_block( + shiny::NS(ns("blocks"), block_name), + value = value[[block_name]], + cached_html = cached_html[[block_name]] + ) + }) + ), + shiny::actionButton(ns("add_block"), label = "Add text block", icon = shiny::icon("plus")) + ) +} + +srv_card_editor <- function(id, card_r) { + shiny::moduleServer(id, function(input, output, session) { + blocks_inputs_rvs <- shiny::reactiveValues() # Store input names for snapshot + blocks_queue_rv <- shiny::reactiveVal() + + shiny::observeEvent(card_r(), { # Reset on card change + for (name in names(blocks_inputs_rvs)) blocks_inputs_rvs[[name]] <- NULL + blocks_queue_rv(NULL) # Force retriggering + blocks_queue_rv(names(card_r())) + }) + + shiny::observeEvent(blocks_queue_rv(), { + lapply(blocks_queue_rv(), function(block_name) { + new_block_id <- shiny::NS("blocks", block_name) + block_content <- card_r()[[block_name]] %||% "" # Initialize as empty string + blocks_inputs_rvs[[block_name]] <- srv_editor_block(new_block_id, value = block_content) + + if (!block_name %in% names(card_r())) { # Only adds UI if not already rendered + new_block_ui <- ui_editor_block( + session$ns(new_block_id), + value = block_content, + cached_html = NULL + ) + shiny::insertUI(sprintf("#%s", session$ns("blocks")), where = "beforeEnd", ui = new_block_ui) + } + }) + }) + + shiny::observeEvent(input$add_block, { + new_name <- utils::tail(make.unique(c(names(blocks_inputs_rvs), "block"), sep = "_"), 1) + blocks_queue_rv(new_name) + }) + + blocks_inputs_rvs + }) +} diff --git a/R/previewer_card.R b/R/previewer_card.R new file mode 100644 index 000000000..26bfbd08c --- /dev/null +++ b/R/previewer_card.R @@ -0,0 +1,46 @@ +previewer_card_ui <- function(id, card_id) { + ns <- shiny::NS(id) + accordion_item <- bslib::accordion_panel( + value = card_id, + title = shiny::tags$label(shiny::uiOutput(ns("title"))), + icon = bslib::tooltip( + bsicons::bs_icon("arrows-move"), + "Move card" + ), + shiny::tags$h6(id = ns("loading_placeholder"), class = "text-muted", "Loading the report..."), + shiny::uiOutput(ns("card_content")) + ) + accordion_item <- shiny::tagAppendAttributes(accordion_item, "data-rank-id" = card_id) + + accordion_item <- shiny::tagAppendAttributes( + tag = accordion_item, + .cssSelector = ".accordion-header", + class = "d-flex", + ) + + accordion_item <- htmltools::tagAppendChildren( + tag = accordion_item, + .cssSelector = ".accordion-header", + ui_previewer_card_actions(ns("actions")) + ) +} + +previewer_card_srv <- function(id, card_r, card_id, reporter) { + # todo: card_name should be only on the server side + shiny::moduleServer(id, function(input, output, session) { + output$title <- shiny::renderUI({ + title <- metadata(shiny::req(card_r()), "title") + if (is.null(title) || isFALSE(nzchar(title))) { + title <- shiny::tags$span("(Empty title)", class = "text-muted") + } + title + }) + output$card_content <- shiny::renderUI({ + result <- reporter$get_cached_html(card_id) + shiny::removeUI(sprintf("#%s", session$ns("loading_placeholder"))) + result + }) + + srv_previewer_card_actions("actions", card_r, card_id, reporter) + }) +} diff --git a/R/previewer_card_actions.R b/R/previewer_card_actions.R new file mode 100644 index 000000000..0c9ba6bf4 --- /dev/null +++ b/R/previewer_card_actions.R @@ -0,0 +1,118 @@ +ui_previewer_card_actions <- function(id) { + ns <- shiny::NS(id) + shiny::tagList( + shiny::actionLink( + inputId = ns("edit_action"), + class = "btn btn-primary btn-sm float-end p-3", + label = NULL, + title = "Edit card", + icon = shiny::icon("edit") + ), + shiny::actionLink( + inputId = ns("remove_action"), + class = "btn btn-danger btn-sm float-end p-3", + label = NULL, + icon = shiny::icon("trash-alt"), + ) + ) +} + +srv_previewer_card_actions <- function(id, card_r, card_id, reporter) { + shiny::moduleServer(id, function(input, output, session) { + new_card_rv <- shiny::reactiveVal() + + shiny::observeEvent( + ignoreInit = TRUE, + input$edit_action, + { + template_card <- card_r() + new_card_rv(template_card) + title <- metadata(template_card, "title") + + if (is.null(title) || isFALSE(nzchar(title))) { + title <- shiny::tags$span(class = "text-muted", "(Empty title)") + } + + shiny::showModal( + shiny::modalDialog( + title = shiny::tags$span( + class = "edit_title_container", + "Editing Card:", + shiny::tags$span(id = session$ns("static_title"), title), + shiny::actionButton( + session$ns("edit_title"), + label = shiny::tags$span(shiny::icon("pen-to-square"), "edit title"), + class = "fs-6", + title = "Edit title" + ), + shinyjs::hidden( + shiny::textInput( + session$ns("new_title"), + label = NULL, value = metadata(template_card, "title") + ) + ) + ), + size = "l", + easyClose = TRUE, + shiny::tagList( + ui_card_editor(session$ns("editor"), value = template_card, reporter$get_cached_html(card_id)), + shiny::uiOutput(session$ns("add_text_element_button_ui")) + ), + footer = shiny::tagList( + shiny::actionButton(session$ns("edit_save"), label = "Save"), + shiny::modalButton("Close") + ) + ) + ) + } + ) + + block_input_names_rvs <- srv_card_editor("editor", new_card_rv) + + shiny::observeEvent(input$edit_title, { + shinyjs::hide("edit_title") + shinyjs::hide("static_title") + shinyjs::show("new_title") + shinyjs::js$jumpToFocus(session$ns("new_title")) + }) + + # Handle + shiny::observeEvent(input$edit_save, { + new_card <- shiny::req(new_card_rv()) + input_r <- Filter(Negate(is.null), shiny::reactiveValuesToList(block_input_names_rvs)) + for (name in names(input_r)) { + new_card[[name]] <- shiny::isolate(input_r[[name]]()) + } + if (isFALSE(is.null(input$new_title))) { + metadata(new_card, "title") <- input$new_title + } + if (isFALSE(identical(new_card, card_r()))) { + tryCatch( + { + reporter$replace_card(card = new_card, card_id = card_id) + new_card_rv(NULL) + reporter$reactive_trigger(Sys.time()) + shiny::showNotification("Card was successfully updated.", type = "message") + }, + error = function(err) { + shiny::showNotification( + sprintf( + "A card with the name '%s' already exists. Please use a different name.", + metadata(new_card, "title") + ), + type = "error", + duration = 5 + ) + shinyjs::enable("edit_save") + } + ) + } else { + new_card_rv(NULL) + reporter$reactive_trigger(Sys.time()) + } + }) + + # Handle remove button + shiny::observeEvent(input$remove_action, reporter$remove_cards(ids = card_id)) + }) +} diff --git a/R/previewer_content.R b/R/previewer_content.R new file mode 100644 index 000000000..a615a81b2 --- /dev/null +++ b/R/previewer_content.R @@ -0,0 +1,73 @@ +# reporter_previewer_content -------------------------------------------------------------------------------------- + +#' @keywords internal +reporter_previewer_content_ui <- function(id, cached_content = rlang::list2()) { + ns <- shiny::NS(id) + shiny::tags$div( + .custom_css_dependency(), + bslib::accordion( + id = ns("reporter_cards"), + class = "teal-reporter report-previewer-accordion", + !!!cached_content + ), + sortable::sortable_js( + css_id = ns("reporter_cards"), + options = sortable::sortable_options( + onSort = sortable::sortable_js_capture_input(ns("reporter_cards_order")), + handle = ".accordion-icon" + ) + ) + ) +} + +#' @keywords internal +reporter_previewer_content_srv <- function(id, reporter) { + shiny::moduleServer(id, function(input, output, session) { + shiny::setBookmarkExclude("card_remove_id") + + session$onRestored(function(state) { + if (is.null(state$dir)) { + return(NULL) + } + reporterdir <- file.path(state$dir, "reporter") + reporter$from_jsondir(reporterdir) + }) + + shiny::exportTestValues(cards = reporter$get_cards()) + current_ids_rv <- shiny::reactiveVal() + queues_rv <- list(insert = shiny::reactiveVal(), remove = shiny::reactiveVal()) + + shiny::observeEvent(reporter$get_cards(), { + all_cards <- reporter$get_cards() + reporter_ids <- names(all_cards) + current_ids <- current_ids_rv() + + to_add <- !reporter_ids %in% current_ids + to_remove <- !current_ids %in% reporter_ids + if (any(to_add)) queues_rv$insert(reporter_ids[to_add]) + if (any(to_remove)) queues_rv$remove(current_ids[to_remove]) + + shinyjs::toggle("empty_reporters", condition = length(all_cards) == 0L) + }) + + # cached_cards <- shiny::reactiveValues() + + shiny::observeEvent(queues_rv$insert(), { + lapply(queues_rv$insert(), function(card_id) { + current_ids_rv(c(current_ids_rv(), card_id)) + }) + }) + + shiny::observeEvent(queues_rv$remove(), { + lapply(queues_rv$remove(), bslib::accordion_panel_remove, id = "reporter_cards") + }) + + shiny::observeEvent(input$card_remove_id, { + reporter$remove_cards(ids = input$card_remove_id) + }) + + shiny::observeEvent(input$reporter_cards_order, { + reporter$reorder_cards(input$reporter_cards_order) + }) + }) +} diff --git a/R/previewer_deprecated.R b/R/previewer_deprecated.R new file mode 100644 index 000000000..6f6cd53e3 --- /dev/null +++ b/R/previewer_deprecated.R @@ -0,0 +1,133 @@ +# deprecated ------------------------------------------------------------------------------------------------------ + +#' Report previewer module +#' +#' @description `r lifecycle::badge("deprecated")` +#' +#' Module offers functionalities to visualize, manipulate, +#' and interact with report cards that have been added to a report. +#' It includes a previewer interface to see the cards and options to modify the report before downloading. +#' +#' Cards are saved by the `shiny` bookmarking mechanism. +#' +#' For more details see the vignette: `vignette("previewerReporter", "teal.reporter")`. +#' +#' This function is deprecated and will be removed in the next release. +#' Please use `preview_report_button_ui()` and `preview_report_button_srv()` +#' to create a preview button that opens a modal with the report preview. +#' +#' @details `r global_knitr_details()` +#' +#' @name reporter_previewer_deprecated +#' +#' @param id (`character(1)`) `shiny` module instance id. +#' @param reporter (`Reporter`) instance. +#' @param global_knitr (`list`) of `knitr` parameters (passed to `knitr::opts_chunk$set`) +#' for customizing the rendering process. +#' @param previewer_buttons (`character`) set of modules to include with `c("download", "load", "reset")` possible +#' values and `"download"` is required. +#' Default `c("download", "load", "reset")` +#' @inheritParams reporter_download_inputs +#' +#' @return `NULL`. +NULL + +#' @rdname reporter_previewer_deprecated +#' @export +reporter_previewer_ui <- function(id) { + ns <- shiny::NS(id) + lifecycle::deprecate_soft( + when = "0.5.0", + what = "reporter_previewer_ui()", + details = paste( + "Calling `reporter_previewer_ui()` is deprecated and will be removed in the next release.\n", + "Please use `report_load_ui()`, `download_report_button_ui()`, `reset_report_button_ui()`,", + "and `preview_report_button_ui()` instead." + ) + ) + bslib::page_fluid( + shiny::tagList( + shinyjs::useShinyjs(), + shiny::singleton( + shiny::tags$head( + shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter")), + shiny::includeScript(system.file("js/extendShinyJs.js", package = "teal.reporter")) + ) + ), + + # Extend shinyjs::js to include function defined in extendShinyJs.js + shinyjs::extendShinyjs(text = "", functions = c("jumpToFocus", "enterToSubmit", "autoFocusModal")), + shiny::tags$div( + class = "well", + style = "display: inline-flex; flex-direction: row; gap: 10px;", + shiny::tags$span(id = ns("load_span"), report_load_ui(ns("load"), label = "Load Report")), + shiny::tags$span( + id = ns("download_span"), download_report_button_ui(ns("download"), label = "Download Report") + ), + shiny::tags$span(id = ns("reset_span"), reset_report_button_ui(ns("reset"), label = "Reset Report")) + ), + shiny::tags$div(reporter_previewer_content_ui(ns("previewer"))) + ) + ) +} + +#' @rdname reporter_previewer_deprecated +#' @export +reporter_previewer_srv <- function(id, + reporter, + global_knitr = getOption("teal.reporter.global_knitr"), + rmd_output = getOption("teal.reporter.rmd_output"), + rmd_yaml_args = getOption("teal.reporter.rmd_yaml_args"), + previewer_buttons = c("download", "load", "reset")) { + lifecycle::deprecate_soft( + when = "0.5.0", + what = "reporter_previewer_srv()", + details = paste( + "Calling `reporter_previewer_srv()` is deprecated and will be removed in the next release.\n", + "Please use `report_load_srv()`, `download_report_button_srv()`, `reset_report_button_srv()`,", + "and `preview_report_button_srv()` instead." + ) + ) + checkmate::assert_subset(previewer_buttons, c("download", "load", "reset"), empty.ok = FALSE) + checkmate::assert_true("download" %in% previewer_buttons) + checkmate::assert_class(reporter, "Reporter") + checkmate::assert_subset(names(global_knitr), names(knitr::opts_chunk$get())) + checkmate::assert_subset( + rmd_output, + c("html_document", "pdf_document", "powerpoint_presentation", "word_document"), + empty.ok = FALSE + ) + checkmate::assert_list(rmd_yaml_args, names = "named") + checkmate::assert_names( + names(rmd_yaml_args), + subset.of = c("author", "title", "date", "output", "toc"), + must.include = "output" + ) + checkmate::assert_true( + .var.name = "rmd_yaml_args$output", + rmd_yaml_args[["output"]] %in% rmd_output || + (length(names(rmd_yaml_args[["output"]])) > 0 && names(rmd_yaml_args[["output"]]) %in% rmd_output) + ) + + shiny::moduleServer(id, function(input, output, session) { + if (!"load" %in% previewer_buttons) { + shinyjs::hide(id = "load_span") + } + if (!"download" %in% previewer_buttons) { + shinyjs::hide(id = "download_span") + } + if (!"reset" %in% previewer_buttons) { + shinyjs::hide(id = "reset_span") + } + report_load_srv("load", reporter = reporter) + download_report_button_srv( + "download", + reporter = reporter, + global_knitr = global_knitr, + rmd_output = rmd_output, + rmd_yaml_args = rmd_yaml_args + ) + reset_report_button_srv("reset", reporter = reporter) + reporter_previewer_content_srv("previewer", reporter = reporter) + }) +} diff --git a/R/previewer_report.R b/R/previewer_report.R new file mode 100644 index 000000000..bed797a7e --- /dev/null +++ b/R/previewer_report.R @@ -0,0 +1,109 @@ +#' Show report previewer button module +#' +#' @description `r lifecycle::badge("experimental")` +#' Provides a button that triggers showing the report preview in a modal. +#' +#' For more details see the vignette: `vignette("previewerReporter", "teal.reporter")`. +#' +#' @name reporter_previewer +#' +#' @param id (`character(1)`) `shiny` module instance id. +#' @param label (`character(1)`) label of the button. By default it is "Preview Report". +#' @param reporter (`Reporter`) instance. +#' +#' @return `NULL`. +NULL + +#' @rdname reporter_previewer +#' @export +preview_report_button_ui <- function(id, label = "Preview Report") { + checkmate::assert_string(label, null.ok = TRUE) + ns <- shiny::NS(id) + shiny::tagList( + .outline_button( + ns("preview_button"), + label = shiny::tags$span( + label, + shiny::uiOutput(ns("preview_button_counter")) + ), + icon = "file-earmark-text" + ) + ) +} + +#' @rdname reporter_previewer +#' @export +preview_report_button_srv <- function(id, reporter) { + checkmate::assert_class(reporter, "Reporter") + + shiny::moduleServer(id, function(input, output, session) { + shiny::setBookmarkExclude(c("preview_button")) + + shiny::observeEvent(reporter$get_cards(), { + shinyjs::toggleClass( + id = "preview_button", condition = length(reporter) == 0, class = "disabled" + ) + }) + + output$preview_button_counter <- shiny::renderUI({ + shiny::tags$span( + class = "position-absolute badge rounded-pill bg-primary", + length(reporter) + ) + }) + + preview_modal <- function(cached_content) { + shiny::tags$div( + class = "teal-reporter reporter-previewer-modal", + .custom_css_dependency(), + shiny::modalDialog( + easyClose = TRUE, + size = "xl", + title = "Report Preview", + reporter_previewer_content_ui(session$ns("preview_content")), + footer = shiny::tagList( + shiny::tags$button( + type = "button", + class = "btn btn-outline-secondary", + "data-bs-dismiss" = "modal", + "Dismiss" + ) + ) + ) + ) + } + + reporter_previewer_content_srv(id = "preview_content", reporter = reporter) + + srv_list <- shiny::reactiveValues() + + shiny::observeEvent( + list(input$preview_button, reporter$reactive_trigger()), + ignoreInit = TRUE, + { + shiny::showModal(preview_modal()) + + panel_ns <- shiny::NS(shiny::NS("preview_content", "reporter_cards")) + lapply( + names(reporter$get_cards()), + function(card_id) { + bslib::accordion_panel_insert( + id = panel_ns(NULL), + previewer_card_ui(id = session$ns(panel_ns(card_id)), card_id = card_id) + ) + + if (is.null(srv_list[[card_id]])) { # Only initialize srv once per card_id + previewer_card_srv( + id = panel_ns(card_id), + card_r = shiny::reactive(reporter$get_cards()[[card_id]]), + card_id = card_id, + reporter = reporter + ) + srv_list[[card_id]] <- card_id + } + } + ) + } + ) + }) +} diff --git a/R/render.R b/R/render.R new file mode 100644 index 000000000..167d161be --- /dev/null +++ b/R/render.R @@ -0,0 +1,70 @@ +#' Render `teal_card` +#' @inheritParams rmarkdown::render +#' @param input (`teal_report` or `teal_code`) object to render. +#' @param global_knitr (`list`) options to apply to every code chunk in a teal_card document. +#' [Read more here](https://rmarkdown.rstudio.com/lesson-3.html#global-options). +#' @param keep_rmd (`logical(1)`) if `.Rmd` should be kept after rendering to desired `output_format`. +#' @param ... arguments passed to `rmarkdown::render`. +#' @examples +#' report <- teal_report() +#' teal_card(report) <- c( +#' teal_card(report), +#' "## Document section", +#' "Lorem ipsum dolor sit amet" +#' ) +#' report <- within(report, a <- 2) +#' report <- within(report, plot(a)) +#' metadata(teal_card(report)) <- list( +#' title = "My Document", +#' author = "NEST" +#' ) +#' if (interactive()) { +#' render(report, output_format = rmarkdown::pdf_document(), global_knitr = list(fig.width = 10)) +#' } +#' @export +render <- function( + input, + output_dir = getwd(), + global_knitr = getOption("teal.reporter.global_knitr"), + keep_rmd = TRUE, + ...) { + checkmate::assert_multi_class(input, c("teal_report", "teal_card", "Reporter")) + checkmate::assert_string(output_dir) + checkmate::assert_list(global_knitr, names = "named") + checkmate::assert_subset(names(global_knitr), names(knitr::opts_chunk$get())) + checkmate::assert_flag(keep_rmd) + checkmate::assert_subset(names(list(...)), names(formals(rmarkdown::render))) + + # Set output dir to a new working directory. Absolute paths in rmarkdown files will break .Rmd portability + dir.create(output_dir, recursive = TRUE, showWarnings = FALSE) + old_wd <- setwd(dir = output_dir) + on.exit(setwd(old_wd)) + + # This Rmd file is for render purpose as it contains evaluated code chunks and their outputs. + rmd_filepath <- "report.Rmd" + temp_rmd_content <- to_rmd( + block = input, + global_knitr = c(global_knitr, list(eval = FALSE)), # we don't want to rerun evaluated code chunks to render + include_chunk_output = TRUE + ) + cat(temp_rmd_content, file = rmd_filepath) + args <- utils::modifyList(list(...), list(input = rmd_filepath)) + tryCatch( + do.call(rmarkdown::render, args), + finally = { + report_items <- list.files(pattern = "report_item_") + unlink(c(rmd_filepath, report_items)) + } + ) + + if (keep_rmd) { + # This Rmd file doesn't contain chunk_outputs as they can be reproduced when executing code-chunks + out_rmd_content <- to_rmd( + block = input, + global_knitr = global_knitr, + include_chunk_output = FALSE + ) + cat(out_rmd_content, file = rmd_filepath) + } + output_dir +} diff --git a/R/teal.reporter.R b/R/teal.reporter.R index 500c0ba69..77b2af1e3 100644 --- a/R/teal.reporter.R +++ b/R/teal.reporter.R @@ -5,10 +5,5 @@ #' @keywords internal "_PACKAGE" -#' @importFrom checkmate assert_string -#' @importFrom grid grid.newpage -#' @importFrom R6 R6Class -#' @importFrom rmarkdown render -#' @importFrom yaml as.yaml -#' @importFrom lifecycle badge +#' @importFrom teal.data teal_data NULL diff --git a/R/teal_card.R b/R/teal_card.R new file mode 100644 index 000000000..9567b92fd --- /dev/null +++ b/R/teal_card.R @@ -0,0 +1,354 @@ +#' @title `teal_card`: An `S3` class for managing `teal` reports +#' +#' @description `r lifecycle::badge("experimental")` +#' +#' The `teal_card` `S3` class provides functionality to store, manage, edit, and adjust report contents. +#' It enables users to create, manipulate, and serialize report-related data efficiently. +#' +#' The `teal_card()` function serves two purposes: +#' 1. When called with a `teal_report` object, it acts as a getter and returns the card slot. +#' 2. When called with other arguments, it creates a new `teal_card` object from those arguments. +#' +#' @return An `S3` `list` of class `teal_card`. +#' @param ... Elements from which `teal_card` will be combined. +#' +#' @details The `teal_card` class supports `c()` and `x[i]` methods for combining and subsetting elements. +#' However, these methods only function correctly when the first element is a `teal_card`. +#' +#' @examples +#' # Create a new empty card +#' report <- teal_card() +#' +#' # Create a card with content +#' report <- teal_card("## Headline", "Some text", summary(iris)) +#' +#' # Extract card from a teal_report +#' tr <- teal_report(teal_card = teal_card("## Title")) +#' doc <- teal_card(tr) +#' +#' # Add elements to the report +#' report <- c(report, list("## Table"), list(summary(mtcars))) +#' +#' # Subset the report to keep only the first two elements +#' report <- report[1:2] +#' +#' # Append new elements after the first element +#' report <- append(report, c(list("## Table 2"), list(summary(mtcars))), after = 1) +#' +#' # Verify that the object remains a teal_card +#' class(report) +#' +#' @aliases teal_card +#' @name teal_card +#' +#' @export +teal_card <- function(...) { + UseMethod("teal_card") +} + +#' @export +#' @keywords internal +teal_card.default <- function(...) { + x <- lapply(list(...), .convert_teal_card_input) + + if (length(x) > 0) { + names(x) <- vapply( + sample.int(.Machine$integer.max, size = length(x)), + function(block) substr(rlang::hash(list(Sys.time(), block)), 1, 8), + character(1) + ) + } + structure(x, class = "teal_card") +} + +#' @export +#' @keywords internal +teal_card.teal_card <- function(...) { + dots <- list(...) + c(dots[[1]], dots[-1]) +} + +#' @export +#' @keywords internal +teal_card.teal_report <- function(...) { + dots <- list(...) + dots[[1]] <- dots[[1]]@teal_card + do.call(teal_card, args = dots) +} + +#' @export +#' @keywords internal +teal_card.qenv <- function(...) { + dots <- list(...) + dots[[1]] <- .code_to_card(dots[[1]]@code) + do.call(teal_card, args = dots) +} + +#' @rdname teal_card +#' @param value (`teal_card`) object to set in the `teal_report`. +#' @export +`teal_card<-` <- function(x, value) { + x <- methods::as(x, "teal_report") + checkmate::assert_class(x, "teal_report") + x@teal_card <- as.teal_card(value) + x +} + +#' @export +`[[<-.teal_card` <- function(x, index, value) { + new_card <- as.teal_card(value) + value <- new_card[[1]] + new_x <- NextMethod() + if (checkmate::test_integerish(index)) { + names(new_x)[[index]] <- names(new_card)[[1]] + } + new_x +} + +#' Create or coerce to a teal_card +#' +#' This function ensures that input is converted to a teal_card object. +#' It accepts various input types and converts them appropriately. +#' +#' @param x Object to convert to teal_card +#' @return A teal_card object +#' @rdname teal_card +#' @export +as.teal_card <- function(x) { # nolint: object_name. + if (inherits(x, "teal_card")) { + return(x) + } + if (identical(class(x), "list")) { + return(do.call(teal_card, unname(x))) + } + teal_card(x) +} + +#' @rdname teal_card +#' @export +c.teal_card <- function(...) { + dots <- list(...) + structure( + Reduce( + f = function(u, v) { + v <- as.teal_card(v) + if (length(names(u)) && length(names(v)) && any(names(u) %in% names(v))) { # when v stems from u + if (all(names(u) %in% names(v))) { # nothing from `u` is removed in `v` + v + } else { + warning( + "Appended `teal_card` doesn't remove some of the elements from previous `teal_card`.\n", + "Restoring original content and adding only new items to the end of the card." + ) + utils::modifyList(u, v) + } + } else { + attrs <- utils::modifyList(attributes(u) %||% list(), attributes(v)) + attrs$names <- union(names(u), names(v)) + attrs$metadata <- utils::modifyList(attr(u, "metadata", exact = TRUE) %||% list(), metadata(v)) + result <- utils::modifyList(unclass(u), v) # See test failure when removing unclass + attributes(result) <- attrs + result + } + }, + x = dots, + init = list() + ), + class = "teal_card" + ) +} + +#' @param i index specifying elements to extract or replace +#' @rdname teal_card +#' @export +`[.teal_card` <- function(x, i) { + out <- NextMethod() + class(out) <- "teal_card" + attr(out, "metadata") <- metadata(x) + out +} + +#' Access metadata from a `teal_card` or `ReportCard` +#' +#' This function retrieves metadata from a `teal_card` or `ReportCard` object. +#' When `which` is `NULL`, it returns all metadata fields as a list. +#' @param object (`teal_card` or `ReportCard`) The object from which to extract metadata. +#' @param which (`character` or `NULL`) The name of the metadata field to extract. +#' @return A list of metadata fields or a specific field if `which` is provided. +#' @export +metadata <- function(object, which = NULL) { + checkmate::assert_string(which, null.ok = TRUE) + UseMethod("metadata", object) +} + +#' @rdname metadata +#' @export +metadata.teal_card <- function(object, which = NULL) { + metadata <- attr(object, which = "metadata", exact = TRUE) + result <- metadata %||% list() + if (is.null(which)) { + return(result) + } + result[[which]] +} + +#' @rdname metadata +#' @export +metadata.ReportCard <- function(object, which = NULL) { + # TODO: soft deprecate + result <- list(title = object$get_name()) + if (is.null(which)) { + return(result) + } + result[[which]] +} + +#' Set metadata for a `teal_card` or `ReportCard` +#' +#' This function allows you to set or modify metadata fields in a `teal_card` or `ReportCard` object. +#' It can be used to add new metadata or update existing fields. +#' @param object (`teal_card` or `ReportCard`) The object to modify. +#' @param which (`character`) The name of the metadata field to set. +#' @param value The value to assign to the specified metadata field. +#' @return The modified object with updated metadata. +#' @export +`metadata<-` <- function(object, which = NULL, value) { + checkmate::assert_string(which, null.ok = TRUE) + UseMethod("metadata<-", object) +} + +#' @rdname metadata-set +#' @export +`metadata<-.teal_card` <- function(object, which = NULL, value) { + if (missing(which)) { + checkmate::assert_list(value, names = "named") + attr(object, which = "metadata") <- value + return(object) + } + attr(object, which = "metadata") <- utils::modifyList( + metadata(object), structure(list(value), names = which) + ) + object +} + +#' @rdname metadata-set +#' @details +#' The `ReportCard` class only supports the `title` field in metadata. +#' @export +`metadata<-.ReportCard` <- function(object, which, value) { + if (missing(which)) { + if (!is.null(value[["title"]])) { + object$set_name(value[["title"]]) + } + if (length(value) >= 2 || length(value) == 1 && is.null(value[["title"]])) { + warning("ReportCard class only supports `title` in metadata.") + } + return(object) + } + + if (isFALSE(identical(which, "title"))) { + warning("ReportCard class only supports `title` in metadata.") + } else { + object$set_name(value) + } + object +} + +#' Generate an R Markdown code chunk +#' +#' This function creates a `code_chunk` object, which represents an R Markdown +#' code chunk. It stores the R code and any specified chunk options (e.g., `echo`, `eval`). +#' These objects are typically processed later to generate the final R Markdown text. +#' +#' @param code A character string containing the R code. +#' @param ... Additional named parameters to be included as chunk options (e.g., `echo = TRUE`). +#' Check [knitr options/](https://yihui.org/knitr/options/) for more details. +#' @param lang (`character(1)`) See [`knitr::knit_engines`]. +#' +#' @return An object of class `code_chunk`. +#' @examples +#' my_chunk <- code_chunk("x <- 1:10", echo = TRUE, message = FALSE) +#' class(my_chunk) +#' attributes(my_chunk)$param +#' @export +code_chunk <- function(code, ..., lang = "R") { + checkmate::assert_character(code) + params <- list(...) + checkmate::assert_list(params, names = "named", .var.name = "...") + structure( + paste(code, collapse = "\n"), + params = params, + lang = lang, + class = "code_chunk" + ) +} + +#' Builds `teal_card` from code and outputs in `qenv` object +#' +#' Builds a `teal_card` from the code and outputs of a `teal_data` +#' object, preserving the order of code execution and output display. +#' +#' @inheritParams eval_code-teal_report +#' @param x (`list`) object from `qenv@code`. +#' @return A `teal_card` built from the code and outputs in a `qenv` object. +#' @keywords internal +.code_to_card <- function(x, code_block_opts = list()) { + elems <- Reduce( + function(items, code_elem) { + this_chunk <- do.call(code_chunk, c(list(code = code_elem), code_block_opts)) + this_outs <- Filter( # intentionally remove warnings,messages from the generated report + function(x) !inherits(x[[1]], "condition"), + lapply( + attr(code_elem, "outputs"), + function(x) structure(list(x), class = c("chunk_output")) + ) + ) + c(items, list(this_chunk), this_outs) + }, + init = list(), + x = x + ) + do.call(teal_card, args = elems) +} + +#' Internal helper for `teal_card`` input conversion +#' +#' Converts input values to a format compatible with `teal_card`. +#' This function is used internally to handle common inputs, such as `ggplot` objects, +#' ensuring they are appropriately converted to evaluable output blocks that can +#' be saved to `RDS` file efficiently. +#' +#' This function performs the following conversions: +#' - `ggplot` objects are converted to `recordedplot` objects. +#' +#' If the R option `teal.reporter.disable_teal_card_conversion` is set to `TRUE`, +#' no conversion is applied. +#' +#' @param x (`object`) An object to be converted. +#' +#' @return The processed object, possibly converted or left unchanged. +#' +#' @keywords internal +.convert_teal_card_input <- function(x) { + if (isTRUE(getOption("teal.reporter.disable_teal_card_conversion"))) { + return(x) + } + if (inherits(x, "chunk_output")) { + structure(list(.convert_teal_card_input(x[[1]])), class = c("chunk_output")) + } else if (inherits(x, "ggplot")) { + .ggplot_to_recordedplot(x) + } else { + x + } +} + +#' @noRd +.ggplot_to_recordedplot <- function(x) { + checkmate::assert_class(x, "ggplot") + grDevices::pdf(file = NULL) + grDevices::dev.control(displaylist = "enable") + dev <- grDevices::dev.cur() + on.exit(grDevices::dev.off(dev)) + print(x) + grDevices::recordPlot() +} diff --git a/R/teal_report-c.R b/R/teal_report-c.R new file mode 100644 index 000000000..5518590fa --- /dev/null +++ b/R/teal_report-c.R @@ -0,0 +1,16 @@ +#' Concatenate `teal_report` objects +#' +#' @param ... (`teal_report`) objects to concatenate +#' +#' @return A [`teal_report`] object with combined [`teal_card`] elements. +#' +#' @export +#' @method c teal_report +c.teal_report <- function(...) { + result <- NextMethod() + l <- Filter(function(x) inherits(x, "teal_report"), list(...)) + if (length(l) > 1) { + teal_card(result) <- do.call(c, lapply(l, function(x) teal_card(x))) + } + result +} diff --git a/R/teal_report-class.R b/R/teal_report-class.R new file mode 100644 index 000000000..e9c80f928 --- /dev/null +++ b/R/teal_report-class.R @@ -0,0 +1,114 @@ +setOldClass("teal_card") + +#' Reproducible report +#' +#' Reproducible report container class. Inherits code tracking behavior from [`teal.data::teal_data-class`]. +#' +#' This class provides an isolated environment in which to store and process data with all code being recorded. +#' The environment, code, data set names, and data joining keys are stored in their respective slots. +#' These slots should never be accessed directly, use the provided get/set functions. +#' +#' As code is evaluated in `teal_data`, messages and warnings are stored in their respective slots. +#' If errors are raised, a `qenv.error` object is returned. +#' +#' @name teal_report-class +#' @rdname teal_report-class +#' +#' @slot .xData (`environment`) environment containing data sets and possibly +#' auxiliary variables. +#' Access variables with [get()], [`$`] or [`[[`]. +#' No setter provided. Evaluate code to add variables into `@.xData`. +#' @slot code (`list` of `character`) representing code necessary to reproduce the contents of `qenv`. +#' Access with [teal.code::get_code()]. +#' No setter provided. Evaluate code to append code to the slot. +#' @slot join_keys (`join_keys`) object specifying joining keys for data sets in +#' `@.xData`. +#' Access or modify with [teal.data::join_keys()]. +#' @slot verified (`logical(1)`) flag signifying that code in `@code` has been +#' proven to yield contents of `@.xData`. +#' Used internally. See [`teal.data::verify()`] for more details. +#' @slot card (`teal_card`) +#' @inheritSection teal.data::`teal_data-class` Code +#' @importFrom teal.data teal_data +#' @keywords internal +setClass( + Class = "teal_report", + contains = "teal_data", + slots = c(teal_card = "teal_card") +) + +#' It initializes the `teal_report` class +#' +#' Accepts .xData as a list and converts it to an environment before initializing +#' parent constructor (`teal_data`). +#' @noRd +setMethod( + "initialize", + "teal_report", + function(.Object, teal_card = NULL, ...) { # nolint: object_name. + args <- list(...) + if (is.null(teal_card)) teal_card <- teal_card() + checkmate::assert_class(teal_card, "teal_card") + checkmate::assert_list(args, names = "named") + methods::callNextMethod( + .Object, + teal_card = teal_card, + ... + ) + } +) + +#' Comprehensive data integration function for `teal` applications +#' +#' @description +#' `r lifecycle::badge("stable")` +#' +#' Initializes a reportable data for `teal` application. +#' +#' @inheritParams teal.data::teal_data +#' @param teal_card (`teal_card`) object containing the report content. +#' @return A `teal_report` object. +#' +#' @seealso [`teal.data::teal_data`] +#' +#' @export +#' +#' @examples +#' teal_report(x1 = iris, x2 = mtcars) +teal_report <- function(..., + teal_card = NULL, + code = character(0), + join_keys = teal.data::join_keys()) { + if (is.null(teal_card)) teal_card <- teal_card() + methods::new( + "teal_report", + .xData = list2env(list(...)), + teal_card = teal_card, + join_keys = join_keys, + code = code + ) +} + +methods::setAs( + "qenv", + "teal_report", + function(from, to) { + if (inherits(from, "teal_report")) { + return(from) + } + new_x <- teal_report() + for (slot_name in methods::slotNames(from)) { + methods::slot(new_x, slot_name) <- methods::slot(from, slot_name) + } + teal_card(new_x) <- .code_to_card(from@code) + new_x + } +) + +#' @rdname teal_report +#' @param x (`qenv` or `teal_data`) object to convert to `teal_report`. +#' @export +as.teal_report <- function(x) { # nolint: object_name. + checkmate::assert_class(x, "qenv") + methods::as(x, "teal_report") +} diff --git a/R/teal_report-eval_code.R b/R/teal_report-eval_code.R new file mode 100644 index 000000000..e97dbeadb --- /dev/null +++ b/R/teal_report-eval_code.R @@ -0,0 +1,34 @@ +#' @name eval_code-teal_report +#' @rdname eval_code-teal_report +#' @aliases eval_code,teal_report-method +#' +#' @inherit teal.code::eval_code +#' @param object (`teal_report`) +#' @param code_block_opts (`list`) Additional options for the R code chunk in R Markdown. +#' @return `teal_reporter` environment with the code evaluated and the outputs added +#' to the card or `qenv.error` if evaluation fails. +#' @importFrom teal.code eval_code +#' +#' @examples +#' td <- teal.data::teal_data() +#' td <- teal.code::eval_code(td, "iris <- iris") +#' tr <- as.teal_report(td) +#' tr <- teal.code::eval_code(tr, "a <- 1") +#' tr <- teal.code::eval_code(tr, "b <- 2L # with comment") +#' tr <- teal.code::eval_code(tr, quote(library(checkmate))) +#' tr <- teal.code::eval_code(tr, expression(assert_number(a))) +#' teal_card(tr) +setMethod( + "eval_code", + signature = c(object = "teal_report"), + function(object, code, code_block_opts = list(), ...) { + new_object <- methods::callNextMethod(object = object, code = code, ...) + if (inherits(new_object, "error")) { + return(new_object) + } + new_blocks <- .code_to_card(x = setdiff(new_object@code, object@code), code_block_opts = code_block_opts) + + teal_card(new_object) <- c(teal_card(new_object), new_blocks) + new_object + } +) diff --git a/R/teal_report-extract.R b/R/teal_report-extract.R new file mode 100644 index 000000000..d44c793f6 --- /dev/null +++ b/R/teal_report-extract.R @@ -0,0 +1,6 @@ +#' @export +`[.teal_report` <- function(x, names) { + x <- NextMethod("`[`", x) # unverified doesn't need warning for code inconsistency + x@teal_card <- x@teal_card # todo: return code_chunks for given names + x +} diff --git a/R/toHTML.R b/R/toHTML.R new file mode 100644 index 000000000..10e7168a4 --- /dev/null +++ b/R/toHTML.R @@ -0,0 +1,144 @@ +#' @importFrom tools toHTML +NULL + +#' @method toHTML default +#' @keywords internal +#' @export +toHTML.default <- function(x, ...) { + .toHTML(x, ...) +} + +#' @keywords internal +.toHTML <- function(x, ...) { # nolint: object_name + UseMethod(".toHTML", x) +} + +#' @method .toHTML default +#' @keywords internal +.toHTML.default <- function(x, ...) { + shiny::HTML(commonmark::markdown_html(x, extensions = TRUE)) +} + +#' @method .toHTML ReportCard +#' @keywords internal +.toHTML.ReportCard <- function(x, ...) { + shiny::tagList(lapply(x$get_content(), tools::toHTML)) +} + +#' @method .toHTML teal_card +#' @keywords internal +.toHTML.teal_card <- function(x, ...) { + shiny::tagList(lapply(x, tools::toHTML, ...)) +} + +#' @method .toHTML teal_report +#' @keywords internal +.toHTML.teal_report <- function(x, ...) { + tools::toHTML(teal_card(x), ...) +} + +#' @method .toHTML rtables +#' @keywords internal +.toHTML.rtables <- function(x, ...) { + shiny::tags$pre(tools::toHTML(to_flextable(x))) +} + +#' @method .toHTML flextable +#' @keywords internal +.toHTML.flextable <- function(x, ...) { + flextable::htmltools_value(x) +} + +#' @method .toHTML condition +#' @keywords internal +.toHTML.condition <- function(x, ...) { + conditionMessage(x) +} + +.plot2html <- function(x, ...) { + on.exit(unlink(tmpfile)) + tmpfile <- tempfile(fileext = ".png") + grDevices::png(filename = tmpfile) + print(x) + grDevices::dev.off() + shiny::tags$img(src = knitr::image_uri(tmpfile)) +} + +#' @method .toHTML recordedplot +#' @keywords internal +.toHTML.recordedplot <- .plot2html + + +#' @method .toHTML trellis +#' @keywords internal +.toHTML.trellis <- .plot2html + +#' @method .toHTML gg +#' @keywords internal +.toHTML.gg <- function(x, ...) { + on.exit(unlink(tmpfile)) + tmpfile <- tempfile(fileext = ".png") + ggplot2::ggsave(tmpfile, plot = x, width = 5, height = 4, dpi = 100) + shiny::tags$img(src = knitr::image_uri(tmpfile)) +} + +#' @method .toHTML grob +#' @keywords internal +.toHTML.grob <- function(x, ...) { + on.exit(unlink(tmpfile)) + tmpfile <- tempfile(fileext = ".png") + grDevices::png(filename = tmpfile) + grid::grid.newpage() + grid::grid.draw(x) + grDevices::dev.off() + shiny::tags$img(src = knitr::image_uri(tmpfile)) +} + +#' @method .toHTML code_chunk +#' @keywords internal +.toHTML.code_chunk <- function(x, ...) { + shiny::tags$pre( + shiny::tags$code(x, class = sprintf("language-%s", attr(x, "lang"))), + .noWS = "inside" + ) +} + +#' @method .toHTML chunk_output +#' @keywords internal +.toHTML.chunk_output <- function(x, ...) { + tools::toHTML(x[[1]], ...) +} + +#' @method .toHTML summary.lm +#' @keywords internal +.toHTML.summary.lm <- function(x, ...) { + shiny::tags$pre(paste(utils::capture.output(print(x)), collapse = "\n")) +} + +#' @method .toHTML TableTree +#' @keywords internal +.toHTML.TableTree <- .toHTML.rtables + +#' @method .toHTML ElementaryTable +#' @keywords internal +.toHTML.ElementaryTable <- .toHTML.rtables + +#' @method .toHTML rlisting +#' @keywords internal +.toHTML.rlisting <- .toHTML.rtables + +#' @method .toHTML data.frame +#' @keywords internal +.toHTML.data.frame <- .toHTML.rtables + +#' @method .toHTML datatables +#' @keywords internal +.toHTML.datatables <- function(x, ...) { + x +} + +#' @method .toHTML gtsummary +#' @keywords internal +.toHTML.gtsummary <- function(x, ...) { + tools::toHTML(gtsummary::as_flex_table(x)) +} diff --git a/R/to_rmd.R b/R/to_rmd.R new file mode 100644 index 000000000..5387cabe5 --- /dev/null +++ b/R/to_rmd.R @@ -0,0 +1,210 @@ +.content_to_rmd <- function(block, ...) { + path <- basename(tempfile(pattern = "report_item_", fileext = ".rds")) + suppressWarnings(saveRDS(block, file = path)) + sprintf("```{r echo = FALSE, eval = TRUE}\nreadRDS('%s')\n```", path) +} + +#' Convert `ReporterCard`/`teal_card` content to `rmarkdown` +#' +#' This is an S3 generic that is used to generate content in `rmarkdown` format +#' from various types of blocks in a `ReporterCard` or `teal_card` object. +#' +#' # Customise `to_rmd` +#' The methods for this S3 generic can be extended by the app developer or even overwritten. +#' For this a function with the name `to_rmd.` should be defined in the +#' Global Environment, where `` is the class of the object to be converted. +#' +#' For example, to override the default behavior for `code_chunk` class, you can use: +#' +#' ```r +#' to_rmd.code_chunk <- function(block, ..., output_format) { +#' # custom implementation +#' sprintf("### A custom code chunk\n\n```{r}\n%s\n```\n", block) +#' } +#' ``` +#' +#' Alternatively, you can register the S3 method using `registerS3method("to_rmd", "", fun)` +#' +#' @param block (`any`) content which can be represented in Rmarkdown syntax. +#' @return `character(1)` containing a content or Rmarkdown document. +#' @keywords internal +to_rmd <- function(block, ...) { + UseMethod("to_rmd") +} + +#' @method to_rmd default +#' @keywords internal +to_rmd.default <- function(block, ...) { + .to_rmd(block, ...) +} + +.to_rmd <- function(block, ...) { + UseMethod(".to_rmd") +} + +#' @method .to_rmd default +#' @keywords internal +.to_rmd.default <- function(block, ...) { + block +} + +#' @method .to_rmd teal_report +#' @keywords internal +.to_rmd.teal_report <- function(block, ...) { + to_rmd(teal_card(block), ...) +} + +#' @method .to_rmd teal_card +#' @keywords internal +.to_rmd.teal_card <- function(block, global_knitr = getOption("teal.reporter.global_knitr"), ...) { + checkmate::assert_subset(names(global_knitr), names(knitr::opts_chunk$get())) + is_powerpoint <- identical(metadata(block)$output, "powerpoint_presentation") + powerpoint_exception_parsed <- if (is_powerpoint) { + format_code_block_function <- quote( + code_block <- function(code_text) { + df <- data.frame(code_text) + ft <- flextable::flextable(df) + ft <- flextable::delete_part(ft, part = "header") + ft <- flextable::autofit(ft, add_h = 0) + ft <- flextable::fontsize(ft, size = 7, part = "body") + ft <- flextable::bg(x = ft, bg = "lightgrey") + ft <- flextable::border_outer(ft) + if (flextable::flextable_dim(ft)$widths > 8) { + ft <- flextable::width(ft, width = 8) + } + ft + } + ) + deparse1(format_code_block_function, collapse = "\n") + } else { + NULL + } + global_knitr_parsed <- sprintf( + "knitr::opts_chunk$set(%s)", + paste(utils::capture.output(dput(global_knitr)), collapse = "") + ) + global_knitr_code_chunk <- code_chunk(c(global_knitr_parsed, powerpoint_exception_parsed), include = FALSE) + global_knitr_rendered <- to_rmd(global_knitr_code_chunk) + + # we need to prerender global_knitr as code_chunk for powerpoint will wrap it in code_block() call + blocks_w_global_knitr <- append( + block, + if (length(global_knitr) || is_powerpoint) list(global_knitr_rendered), + after = 0 + ) + + m <- metadata(block) + paste( + c( + if (length(m)) sprintf("---\n%s\n---", trimws(yaml::as.yaml(m, handlers = list("Date" = as.character)))), + unlist(lapply( + blocks_w_global_knitr, + function(x) to_rmd(x, output_format = m$output, ...) + )) + ), + collapse = "\n\n" + ) +} + +#' @method .to_rmd code_chunk +#' @keywords internal +.to_rmd.code_chunk <- function(block, ..., output_format = NULL) { + params <- lapply(attr(block, "params"), function(l) if (is.character(l)) shQuote(l) else l) + block_str <- format(block) + lang <- attr(block, "lang", exact = TRUE) + if (identical(output_format, "powerpoint_presentation")) { + block_content_list <- lapply( + split_text_block(block, 30), + function(x, lang) { + code_block <- sprintf("code_block(\n%s)", shQuote(x, type = "cmd")) + format(code_chunk(code_block, echo = FALSE, lang = lang)) + }, + lang = lang + ) + paste(sprintf("\\newpage\n\n---\n\n%s\n", block_content_list), collapse = "\n\n") + } else { + format(block) + } +} + +#' @method .to_rmd character +#' @keywords internal +.to_rmd.character <- function(block, ...) { + block +} + +#' @method .to_rmd chunk_output +#' @keywords internal +.to_rmd.chunk_output <- function(block, ..., include_chunk_output) { + if (!missing(include_chunk_output) && isTRUE(include_chunk_output)) { + to_rmd(block[[1]], ..., include_chunk_output = include_chunk_output) + } +} + +#' @method .to_rmd condition +#' @keywords internal +.to_rmd.condition <- function(block, ...) { + conditionMessage(block) +} + +#' @method .to_rmd gg +#' @keywords internal +.to_rmd.gg <- .content_to_rmd + +#' @method .to_rmd trellis +#' @keywords internal +.to_rmd.trellis <- .content_to_rmd + +#' @method .to_rmd recordedplot +#' @keywords internal +.to_rmd.recordedplot <- .content_to_rmd + +#' @method .to_rmd grob +#' @keywords internal +.to_rmd.grob <- .content_to_rmd + +#' @method .to_rmd Heatmap +#' @keywords internal +.to_rmd.Heatmap <- .content_to_rmd + +#' @method .to_rmd datatables +#' @keywords internal +.to_rmd.datatables <- .content_to_rmd + +#' @method .to_rmd summary.lm +#' @keywords internal +.to_rmd.summary.lm <- .content_to_rmd + +#' @method .to_rmd rtables +#' @keywords internal +.to_rmd.rtables <- function(block, ...) { + flextable_block <- to_flextable(block) + attr(flextable_block, "keep") <- attr(block, "keep") + to_rmd(flextable_block, ...) +} + +#' @method .to_rmd flextable +#' @keywords internal +.to_rmd.flextable <- .content_to_rmd + +#' @method .to_rmd TableTree +#' @keywords internal +.to_rmd.TableTree <- .to_rmd.rtables + +#' @method .to_rmd ElementaryTable +#' @keywords internal +.to_rmd.ElementaryTable <- .to_rmd.rtables + +#' @method .to_rmd rlisting +#' @keywords internal +.to_rmd.rlisting <- .to_rmd.rtables + +#' @method .to_rmd data.frame +#' @keywords internal +.to_rmd.data.frame <- .to_rmd.rtables + +#' @method .to_rmd gtsummary +#' @keywords internal +.to_rmd.gtsummary <- function(block, ...) { + to_rmd(gtsummary::as_flex_table(block), ...) +} diff --git a/R/utils.R b/R/utils.R index 8fa7ce1fb..9d575a95a 100644 --- a/R/utils.R +++ b/R/utils.R @@ -20,7 +20,6 @@ panel_item <- function(title, ..., collapsed = TRUE, input_id = NULL) { div_id <- paste0(input_id, "_div") panel_id <- paste0(input_id, "_panel_body_", sample(1:10000, 1)) - shiny::tags$div(.renderHook = function(res_tag) { res_tag$children <- list( shiny::tags$div( @@ -30,23 +29,17 @@ panel_item <- function(title, ..., collapsed = TRUE, input_id = NULL) { class = "card-header", shiny::tags$div( class = ifelse(collapsed, "collapsed", ""), - `data-bs-toggle` = "collapse", + `data-bs-toggle` = "collapse", # bs5 href = paste0("#", panel_id), `aria-expanded` = ifelse(collapsed, "false", "true"), shiny::icon("angle-down", class = "dropdown-icon"), - shiny::tags$label( - style = "display: inline;", - title, - ) + shiny::tags$label(style = "display: inline;", title) ) ), shiny::tags$div( id = panel_id, class = paste("collapse", ifelse(collapsed, "", "show")), - shiny::tags$div( - class = "card-body", - ... - ) + shiny::tags$div(class = "card-body", ...) ) ) ) @@ -87,9 +80,13 @@ to_flextable <- function(content) { rtables::header_section_div(ft) <- mf$header_section_div ft <- rtables.officer::tt_to_flextable(ft, total_width = c(grDevices::pdf.options()$width - 1)) } else if (inherits(content, "data.frame")) { - ft <- rtables.officer::tt_to_flextable( - rtables::df_to_tt(content) - ) + ft <- if (nrow(content) == 0) { + flextable::flextable(content) + } else { + rtables.officer::tt_to_flextable( + rtables::df_to_tt(content) + ) + } } else { stop(paste0("Unsupported class `(", format(class(content)), ")` when exporting table")) } @@ -160,6 +157,21 @@ global_knitr_details <- function() { ) } +#' @export +#' @keywords internal +format.code_chunk <- function(x, ...) { + language <- attr(x, "lang", exact = TRUE) + params <- attr(x, "params", exact = TRUE) + if (language %in% names(knitr::knit_engines$get())) { + sprintf( + "```{%s}\n%s\n```", + toString(c(language, paste(names(params), params, sep = "="))), + NextMethod() + ) + } else { + sprintf("```%s\n%s\n```", language, NextMethod()) + } +} #' @keywords internal .outline_button <- function(id, label, icon = NULL, class = "primary") { @@ -200,3 +212,8 @@ global_knitr_details <- function() { stylesheet = "custom.css" ) } + +#' @noRd +dummy <- function() { + R6::R6Class # Used to trick R CMD check for avoiding NOTE about R6 +} diff --git a/R/yaml_utils.R b/R/yaml_utils.R deleted file mode 100644 index d0ed58173..000000000 --- a/R/yaml_utils.R +++ /dev/null @@ -1,313 +0,0 @@ -#' Mark strings for quotation in `yaml` serialization -#' -#' This function is designed for use with the `yaml` package to explicitly, -#' It adds an attribute to character strings, indicating that they should be serialized with double quotes. -#' -#' @param x (`character`) -#' @keywords internal -#' @examples -#' library(yaml) -#' yaml_quoted <- getFromNamespace("yaml_quoted", "teal.reporter") -#' yaml <- list( -#' author = yaml_quoted("NEST"), -#' title = yaml_quoted("Report"), -#' date = yaml_quoted("07/04/2019"), -#' output = list(pdf_document = list(keep_tex = TRUE)) -#' ) -#' as.yaml(yaml) -yaml_quoted <- function(x) { - attr(x, "quoted") <- TRUE - x -} - -#' Create `markdown` header from `yaml` string -#' -#' This function wraps a `yaml`-formatted string in Markdown header delimiters. -#' -#' @param x (`character`) `yaml` formatted string. -#' @keywords internal -#' @examples -#' library(yaml) -#' yaml_quoted <- getFromNamespace("yaml_quoted", "teal.reporter") -#' yaml <- list( -#' author = yaml_quoted("NEST"), -#' title = yaml_quoted("Report"), -#' date = yaml_quoted("07/04/2019"), -#' output = list(pdf_document = list(keep_tex = TRUE)) -#' ) -#' md_header <- getFromNamespace("md_header", "teal.reporter") -#' md_header(as.yaml(yaml)) -md_header <- function(x) { - paste0("---\n", x, "---\n") -} - -#' Convert `yaml` representation of a boolean strings to logical Values -#' -#' Converts a single `character` string representing a `yaml` boolean value into a logical value in `R`. -#' -#' @param input (`character(1)`) -#' @param name (`charcter(1)`) -#' @param pos_logi (`character`) vector of `yaml` values which should be treated as `TRUE`. -#' @param neg_logi (`character`) vector of `yaml` values which should be treated as `FALSE`. -#' @param silent (`logical(1)`) if to suppress the messages and warnings. -#' @return `input` argument or the appropriate `logical` value. -#' @keywords internal -#' @examples -#' conv_str_logi <- getFromNamespace("conv_str_logi", "teal.reporter") -#' conv_str_logi("TRUE") -#' conv_str_logi("True") -#' -#' conv_str_logi("off") -#' conv_str_logi("n") -#' -#' conv_str_logi("sth") -conv_str_logi <- function(input, - name = "", - pos_logi = c("TRUE", "true", "True", "yes", "y", "Y", "on"), - neg_logi = c("FALSE", "false", "False", "no", "n", "N", "off"), - silent = TRUE) { - checkmate::assert_string(input) - checkmate::assert_string(name) - checkmate::assert_character(pos_logi) - checkmate::assert_character(neg_logi) - checkmate::assert_flag(silent) - - all_logi <- c(pos_logi, neg_logi) - if (input %in% all_logi) { - if (isFALSE(silent)) { - message(sprintf("The '%s' value should be a logical, so it is automatically converted.", input)) - } - input %in% pos_logi - } else { - input - } -} - -#' Get document output types from the `rmarkdown` package -#' -#' @description -#' -#' Retrieves vector of available document output types from the `rmarkdown` package, -#' such as `pdf_document`, `html_document`, etc. -#' -#' @return `character` vector. -#' @export -#' @examples -#' rmd_outputs() -rmd_outputs <- function() { - rmarkdown_namespace <- asNamespace("rmarkdown") - ls(rmarkdown_namespace)[grep("_document|_presentation", ls(rmarkdown_namespace))] -} - -#' Get document output arguments from the `rmarkdown` package -#' -#' @description -#' -#' Retrieves the arguments for a specified document output type from the `rmarkdown` package. -#' -#' @param output_name (`character`) `rmarkdown` output name. -#' @param default_values (`logical(1)`) if to return a default values for each argument. -#' @export -#' @examples -#' rmd_output_arguments("pdf_document") -#' rmd_output_arguments("pdf_document", TRUE) -rmd_output_arguments <- function(output_name, default_values = FALSE) { - checkmate::assert_string(output_name) - checkmate::assert_subset(output_name, rmd_outputs()) - - rmarkdown_namespace <- asNamespace("rmarkdown") - if (default_values) { - formals(rmarkdown_namespace[[output_name]]) - } else { - names(formals(rmarkdown_namespace[[output_name]])) - } -} - -#' Parse a named list to `yaml` header for an `Rmd` file -#' -#' @description -#' -#' Converts a named list into a `yaml` header for `Rmd`, handling output types and arguments -#' as defined in the `rmarkdown` package. This function simplifies the process of generating `yaml` headers. -#' -#' @details -#' This function processes a non-nested (flat) named list into a `yaml` header for an `Rmd` document. -#' It supports all standard `Rmd` `yaml` header fields, including `author`, `date`, `title`, `subtitle`, -#' `abstract`, `keywords`, `subject`, `description`, `category`, and `lang`. -#' Additionally, it handles `output` field types and arguments as defined in the `rmarkdown` package. -#' -#' @note Only non-nested lists are automatically parsed. -#' Nested lists require direct processing with `yaml::as.yaml`. -#' -#' @param input_list (`named list`) non nested with slots names and their values compatible with `Rmd` `yaml` header. -#' @param as_header (`logical(1)`) optionally wrap with result with the internal `md_header()`, default `TRUE`. -#' @param convert_logi (`logical(1)`) convert a character values to logical, -#' if they are recognized as quoted `yaml` logical values , default `TRUE`. -#' @param multi_output (`logical(1)`) multi `output` slots in the `input` argument, default `FALSE`. -#' @param silent (`logical(1)`) suppress messages and warnings, default `FALSE`. -#' @return `character` with `rmd_yaml_header` class, -#' result of [`yaml::as.yaml`], optionally wrapped with internal `md_header()`. -#' @export -#' @examples -#' # nested so using yaml::as.yaml directly -#' as_yaml_auto( -#' list(author = "", output = list(pdf_document = list(toc = TRUE))) -#' ) -#' -#' # auto parsing for a flat list, like shiny input -#' input <- list(author = "", output = "pdf_document", toc = TRUE, keep_tex = TRUE) -#' as_yaml_auto(input) -#' -#' as_yaml_auto(list(author = "", output = "pdf_document", toc = TRUE, keep_tex = "TRUE")) -#' -#' as_yaml_auto(list( -#' author = "", output = "pdf_document", toc = TRUE, keep_tex = TRUE, -#' wrong = 2 -#' )) -#' -#' as_yaml_auto(list(author = "", output = "pdf_document", toc = TRUE, keep_tex = 2), -#' silent = TRUE -#' ) -#' -#' input <- list(author = "", output = "pdf_document", toc = TRUE, keep_tex = "True") -#' as_yaml_auto(input) -#' as_yaml_auto(input, convert_logi = TRUE, silent = TRUE) -#' as_yaml_auto(input, silent = TRUE) -#' as_yaml_auto(input, convert_logi = FALSE, silent = TRUE) -#' -#' as_yaml_auto( -#' list( -#' author = "", output = "pdf_document", -#' output = "html_document", toc = TRUE, keep_tex = TRUE -#' ), -#' multi_output = TRUE -#' ) -#' as_yaml_auto( -#' list( -#' author = "", output = "pdf_document", -#' output = "html_document", toc = "True", keep_tex = TRUE -#' ), -#' multi_output = TRUE -#' ) -as_yaml_auto <- function(input_list, - as_header = TRUE, - convert_logi = TRUE, - multi_output = FALSE, - silent = FALSE) { - checkmate::assert_logical(as_header) - checkmate::assert_logical(convert_logi) - checkmate::assert_logical(silent) - checkmate::assert_logical(multi_output) - - if (multi_output) { - checkmate::assert_list(input_list, names = "named") - } else { - checkmate::assert_list(input_list, names = "unique") - } - - is_nested <- function(x) any(unlist(lapply(x, is.list))) - if (is_nested(input_list)) { - result <- input_list - } else { - result <- list() - input_nams <- names(input_list) - - # top fields - top_fields <- c( - "author", "date", "title", "subtitle", "abstract", - "keywords", "subject", "description", "category", "lang" - ) - for (itop in top_fields) { - if (itop %in% input_nams) { - result[[itop]] <- switch(itop, - date = as.character(input_list[[itop]]), - input_list[[itop]] - ) - } - } - - # output field - doc_types <- unlist(input_list[input_nams == "output"]) - if (length(doc_types)) { - for (dtype in doc_types) { - doc_type_args <- rmd_output_arguments(dtype, TRUE) - doc_type_args_nams <- names(doc_type_args) - any_output_arg <- any(input_nams %in% doc_type_args_nams) - - not_found_args <- setdiff(input_nams, c(doc_type_args_nams, top_fields, "output")) - if (isFALSE(silent) && length(not_found_args) > 0 && isFALSE(multi_output)) { - warning(sprintf("Not recognized and skipped arguments: %s", paste(not_found_args, collapse = ", "))) - } - - if (any_output_arg) { - doc_list <- list() - doc_list[[dtype]] <- list() - for (e in intersect(input_nams, doc_type_args_nams)) { - if (is.logical(doc_type_args[[e]]) && is.character(input_list[[e]])) { - pos_logi <- c("TRUE", "true", "True", "yes", "y", "Y", "on") - neg_logi <- c("FALSE", "false", "False", "no", "n", "N", "off") - all_logi <- c(pos_logi, neg_logi) - if (input_list[[e]] %in% all_logi && convert_logi) { - input_list[[e]] <- conv_str_logi(input_list[[e]], e, - pos_logi = pos_logi, - neg_logi = neg_logi, silent = silent - ) - } - } - - doc_list[[dtype]][[e]] <- input_list[[e]] - } - result[["output"]] <- append(result[["output"]], doc_list) - } else { - result[["output"]] <- append(result[["output"]], input_list[["output"]]) - } - } - } - } - - result <- yaml::as.yaml(result) - if (as_header) { - result <- md_header(result) - } - structure(result, class = "rmd_yaml_header") -} - -#' Print method for the `yaml_header` class -#' -#' @param x (`rmd_yaml_header`) class object. -#' @param ... optional text. -#' @return `NULL`. -#' @exportS3Method -#' @examples -#' input <- list(author = "", output = "pdf_document", toc = TRUE, keep_tex = TRUE) -#' out <- as_yaml_auto(input) -#' out -#' print(out) -print.rmd_yaml_header <- function(x, ...) { - cat(x, ...) -} - -#' Extract field from `yaml` text -#' -#' Parses `yaml` text, extracting the specified field. Returns list names if it's a list; -#' otherwise, the field itself. -#' -#' @param yaml_text (`rmd_yaml_header` or `character`) vector containing the `yaml` text. -#' @param field_name (`character`) the name of the field to extract. -#' -#' @return If the field is a list, it returns the names of elements in the list; otherwise, -#' it returns the extracted field. -#' -#' @keywords internal -get_yaml_field <- function(yaml_text, field_name) { - checkmate::assert_multi_class(yaml_text, c("rmd_yaml_header", "character")) - checkmate::assert_string(field_name) - - yaml_obj <- yaml::yaml.load(yaml_text) - - result <- yaml_obj[[field_name]] - if (is.list(result)) { - result <- names(result) - } - result -} diff --git a/R/zzz.R b/R/zzz.R index 48148c361..6fa370b33 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -1,5 +1,6 @@ .onLoad <- function(libname, pkgname) { op <- options() + teal_reporter_default_options <- list( teal.reporter.global_knitr = list( echo = TRUE, @@ -7,19 +8,28 @@ tidy = requireNamespace("formatR", quietly = TRUE) ), teal.reporter.rmd_output = c( - "html" = "html_document", "pdf" = "pdf_document", + "html" = "html_document", + "pdf" = "pdf_document", "powerpoint" = "powerpoint_presentation", "word" = "word_document" ), teal.reporter.rmd_yaml_args = list( - author = "NEST", title = "Report", - date = as.character(Sys.Date()), output = "html_document", - toc = FALSE + author = "NEST", + title = "Report", + date = as.character(Sys.Date()), + output = list(html_document = list(toc = FALSE)) ) ) toset <- !(names(teal_reporter_default_options) %in% names(op)) - if (any(toset)) options(teal_reporter_default_options[toset]) + if (any(toset)) { + options(teal_reporter_default_options[toset]) + } + + # Manual import instead of using backports and adding 1 more dependency + if (getRversion() < "4.4") { + assign("%||%", rlang::`%||%`, envir = getNamespace(pkgname)) + } invisible() } diff --git a/_pkgdown.yml b/_pkgdown.yml index 78c529ee2..411811ea9 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -21,6 +21,7 @@ navbar: github: icon: fa-github href: https://github.com/insightsengineering/teal.reporter + aria-label: View on Github reference: - title: "`shiny` modules for adding content to reports" @@ -33,6 +34,14 @@ reference: - simple_reporter_ui - title: Supporting `shiny` modules contents: + - download_report_button_srv + - download_report_button_ui + - reset_report_button_srv + - reset_report_button_ui + - report_load_srv + - report_load_ui + - srv_editor_block + - ui_editor_block - add_card_button - download_report_button - reset_report_button @@ -44,10 +53,25 @@ reference: - print.rmd_yaml_header - rmd_output_arguments - rmd_outputs - - title: "`R6` classes used inside package" + - title: "Classes used inside package" contents: + - teal_card + - teal_report - ReportCard - Reporter + - title: "Utility functions for `teal_card` object" + contents: + - as.teal_card + - code_chunk + - metadata + - "metadata<-" + - render + - teal_card + - "teal_card<-" + - title: "Utility functions for `teal_report` object" + contents: + - c.teal_report + - eval_code,teal_report-method - title: "Deprecated functions" contents: - reporter_previewer_deprecated diff --git a/inst/WORDLIST b/inst/WORDLIST index 392275b2a..fa308a12b 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -1,3 +1,4 @@ +Customise Forkers Hoffmann ORCID @@ -6,4 +7,6 @@ README Reinitializes UI funder +getter +reportable rmarkdown diff --git a/inst/css/custom.css b/inst/css/custom.css index cb4b381fe..ec1fe6de0 100644 --- a/inst/css/custom.css +++ b/inst/css/custom.css @@ -19,6 +19,17 @@ padding-top: 0; } +.fa-stack.small { width: 2em; } + +.edit_title_container { + display: flex; + gap: .5rem; +} + +pre > code { + padding-left: 0; +} + .teal-reporter.outline-button { padding: 0.3em; border-radius: 5px; diff --git a/inst/js/extendShinyJs.js b/inst/js/extendShinyJs.js new file mode 100644 index 000000000..b4ad78d71 --- /dev/null +++ b/inst/js/extendShinyJs.js @@ -0,0 +1,35 @@ +/* Focus on element with 'id' when shiny modal is shown */ +shinyjs.autoFocusModal = function(id) { + document.getElementById('shiny-modal').addEventListener( + 'shown.bs.modal', + () => document.getElementById(id).focus(), + { once: true } + ); +} + +/* When user has focus on 'id' they can press enter to mock a click to + * button/link/... + * Typically used to submit a form or trigger an action. + */ +shinyjs.enterToSubmit = function(id, submit_id) { + document.getElementById('shiny-modal').addEventListener( + 'shown.bs.modal', + () => document.getElementById(id).addEventListener('keyup', (e) => { + if (e.key === 'Enter') { + e.preventDefault(); // prevent form submission + document.getElementById(submit_id).click(); + } + }) + ); +} + +/* Jump focus to element with 'id' and if it is an input / textarea, go to end + * of the input. + */ +shinyjs.jumpToFocus = function(focus_id) { + const input = document.getElementById(focus_id); + input.focus(); + if (typeof input.setSelectionRange === 'function') { + input.setSelectionRange(input.value.length, input.value.length); + } +} diff --git a/man/ContentBlock.Rd b/man/ContentBlock.Rd deleted file mode 100644 index 4a5ee94db..000000000 --- a/man/ContentBlock.Rd +++ /dev/null @@ -1,149 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ContentBlock.R -\docType{class} -\name{ContentBlock} -\alias{ContentBlock} -\title{\code{ContentBlock}: A building block for report content} -\description{ -This class represents a basic content unit in a report, -such as text, images, or other multimedia elements. -It serves as a foundation for constructing complex report structures. -} -\examples{ - -## ------------------------------------------------ -## Method `ContentBlock$set_content` -## ------------------------------------------------ - -ContentBlock <- getFromNamespace("ContentBlock", "teal.reporter") -block <- ContentBlock$new() -block$set_content("Base64 encoded picture") - - -## ------------------------------------------------ -## Method `ContentBlock$get_content` -## ------------------------------------------------ - -ContentBlock <- getFromNamespace("ContentBlock", "teal.reporter") -block <- ContentBlock$new() -block$get_content() - -} -\keyword{internal} -\section{Methods}{ -\subsection{Public methods}{ -\itemize{ -\item \href{#method-ContentBlock-set_content}{\code{ContentBlock$set_content()}} -\item \href{#method-ContentBlock-get_content}{\code{ContentBlock$get_content()}} -\item \href{#method-ContentBlock-from_list}{\code{ContentBlock$from_list()}} -\item \href{#method-ContentBlock-to_list}{\code{ContentBlock$to_list()}} -\item \href{#method-ContentBlock-clone}{\code{ContentBlock$clone()}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-ContentBlock-set_content}{}}} -\subsection{Method \code{set_content()}}{ -Sets content of this \code{ContentBlock}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{ContentBlock$set_content(content)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{content}}{(\code{any}) R object} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -\code{self}, invisibly. -} -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{ContentBlock <- getFromNamespace("ContentBlock", "teal.reporter") -block <- ContentBlock$new() -block$set_content("Base64 encoded picture") - -} -\if{html}{\out{
}} - -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-ContentBlock-get_content}{}}} -\subsection{Method \code{get_content()}}{ -Retrieves the content assigned to this block. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{ContentBlock$get_content()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -object stored in a \code{private$content} field -} -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{ContentBlock <- getFromNamespace("ContentBlock", "teal.reporter") -block <- ContentBlock$new() -block$get_content() - -} -\if{html}{\out{
}} - -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-ContentBlock-from_list}{}}} -\subsection{Method \code{from_list()}}{ -Create the \code{ContentBlock} from a list. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{ContentBlock$from_list(x)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{x}}{(\verb{named list}) with two fields \code{text} and \code{style}. -Use the \code{get_available_styles} method to get all possible styles.} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -\code{self}, invisibly. -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-ContentBlock-to_list}{}}} -\subsection{Method \code{to_list()}}{ -Convert the \code{ContentBlock} to a list. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{ContentBlock$to_list()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -\verb{named list} with a text and style. -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-ContentBlock-clone}{}}} -\subsection{Method \code{clone()}}{ -The objects of this class are cloneable with this method. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{ContentBlock$clone(deep = FALSE)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{deep}}{Whether to make a deep clone.} -} -\if{html}{\out{
}} -} -} -} diff --git a/man/FileBlock.Rd b/man/FileBlock.Rd deleted file mode 100644 index a6a4dd40e..000000000 --- a/man/FileBlock.Rd +++ /dev/null @@ -1,137 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/FileBlock.R -\docType{class} -\name{FileBlock} -\alias{FileBlock} -\title{\code{FileBlock}} -\description{ -\code{FileBlock} manages file-based content in a report, -ensuring appropriate handling of content files. -} -\examples{ - -## ------------------------------------------------ -## Method `FileBlock$from_list` -## ------------------------------------------------ - -FileBlock <- getFromNamespace("FileBlock", "teal.reporter") -block <- FileBlock$new() -file_path <- tempfile(fileext = ".png") -saveRDS(iris, file_path) -block$from_list(list(basename = basename(file_path)), dirname(file_path)) - - -## ------------------------------------------------ -## Method `FileBlock$to_list` -## ------------------------------------------------ - -FileBlock <- getFromNamespace("FileBlock", "teal.reporter") -block <- FileBlock$new() -block$to_list(tempdir()) - -} -\keyword{internal} -\section{Super class}{ -\code{\link[teal.reporter:ContentBlock]{teal.reporter::ContentBlock}} -> \code{FileBlock} -} -\section{Methods}{ -\subsection{Public methods}{ -\itemize{ -\item \href{#method-FileBlock-from_list}{\code{FileBlock$from_list()}} -\item \href{#method-FileBlock-to_list}{\code{FileBlock$to_list()}} -\item \href{#method-FileBlock-clone}{\code{FileBlock$clone()}} -} -} -\if{html}{\out{ -
Inherited methods - -
-}} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FileBlock-from_list}{}}} -\subsection{Method \code{from_list()}}{ -Create the \code{FileBlock} from a list. -The list should contain one named field, \code{"basename"}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FileBlock$from_list(x, output_dir)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{x}}{(\verb{named list}) with one field \code{"basename"}, a name of the file.} - -\item{\code{output_dir}}{(\code{character}) with a path to the directory where a file will be copied.} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -\code{self}, invisibly. -} -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{FileBlock <- getFromNamespace("FileBlock", "teal.reporter") -block <- FileBlock$new() -file_path <- tempfile(fileext = ".png") -saveRDS(iris, file_path) -block$from_list(list(basename = basename(file_path)), dirname(file_path)) - -} -\if{html}{\out{
}} - -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FileBlock-to_list}{}}} -\subsection{Method \code{to_list()}}{ -Convert the \code{FileBlock} to a list. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FileBlock$to_list(output_dir)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{output_dir}}{(\code{character}) with a path to the directory where a file will be copied.} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -\verb{named list} with a \code{basename} of the file. -} -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{FileBlock <- getFromNamespace("FileBlock", "teal.reporter") -block <- FileBlock$new() -block$to_list(tempdir()) - -} -\if{html}{\out{
}} - -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FileBlock-clone}{}}} -\subsection{Method \code{clone()}}{ -The objects of this class are cloneable with this method. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FileBlock$clone(deep = FALSE)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{deep}}{Whether to make a deep clone.} -} -\if{html}{\out{
}} -} -} -} diff --git a/man/HTMLBlock.Rd b/man/HTMLBlock.Rd deleted file mode 100644 index 971bd6982..000000000 --- a/man/HTMLBlock.Rd +++ /dev/null @@ -1,147 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/HTMLBlock.R -\docType{class} -\name{HTMLBlock} -\alias{HTMLBlock} -\title{\code{HTMLBlock}} -\description{ -Specialized \code{FileBlock} for managing HTML content in reports. -It's designed to handle various HTML content, and render the report as HTML, -however \code{htmlwidgets} objects can also be rendered to static document-ready format. -} -\examples{ - -## ------------------------------------------------ -## Method `HTMLBlock$from_list` -## ------------------------------------------------ - -HTMLBlock <- getFromNamespace("HTMLBlock", "teal.reporter") -block <- HTMLBlock$new() -block$from_list(list(content = shiny::tags$div("test"))) - - -## ------------------------------------------------ -## Method `HTMLBlock$to_list` -## ------------------------------------------------ - -HTMLBlock <- getFromNamespace("HTMLBlock", "teal.reporter") -block <- HTMLBlock$new(shiny::tags$div("test")) -block$to_list() - -} -\keyword{internal} -\section{Super class}{ -\code{\link[teal.reporter:ContentBlock]{teal.reporter::ContentBlock}} -> \code{HTMLBlock} -} -\section{Methods}{ -\subsection{Public methods}{ -\itemize{ -\item \href{#method-HTMLBlock-new}{\code{HTMLBlock$new()}} -\item \href{#method-HTMLBlock-from_list}{\code{HTMLBlock$from_list()}} -\item \href{#method-HTMLBlock-to_list}{\code{HTMLBlock$to_list()}} -\item \href{#method-HTMLBlock-clone}{\code{HTMLBlock$clone()}} -} -} -\if{html}{\out{ -
Inherited methods - -
-}} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-HTMLBlock-new}{}}} -\subsection{Method \code{new()}}{ -Initialize a \code{HTMLBlock} object. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{HTMLBlock$new(content)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{content}}{An object that can be rendered as a HTML content assigned to -this \code{HTMLBlock}} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -Object of class \code{HTMLBlock}, invisibly. -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-HTMLBlock-from_list}{}}} -\subsection{Method \code{from_list()}}{ -Create the \code{HTMLBlock} from a list. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{HTMLBlock$from_list(x)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{x}}{(\verb{named list}) with a single field \code{content} containing \code{shiny.tag}, -\code{shiny.tag.list} or \code{htmlwidget}.} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -\code{self}, invisibly. -} -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{HTMLBlock <- getFromNamespace("HTMLBlock", "teal.reporter") -block <- HTMLBlock$new() -block$from_list(list(content = shiny::tags$div("test"))) - -} -\if{html}{\out{
}} - -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-HTMLBlock-to_list}{}}} -\subsection{Method \code{to_list()}}{ -Convert the \code{HTMLBlock} to a list. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{HTMLBlock$to_list()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -\verb{named list} with a text and style. -} -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{HTMLBlock <- getFromNamespace("HTMLBlock", "teal.reporter") -block <- HTMLBlock$new(shiny::tags$div("test")) -block$to_list() - -} -\if{html}{\out{
}} - -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-HTMLBlock-clone}{}}} -\subsection{Method \code{clone()}}{ -The objects of this class are cloneable with this method. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{HTMLBlock$clone(deep = FALSE)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{deep}}{Whether to make a deep clone.} -} -\if{html}{\out{
}} -} -} -} diff --git a/man/NewpageBlock.Rd b/man/NewpageBlock.Rd deleted file mode 100644 index 9a38d0168..000000000 --- a/man/NewpageBlock.Rd +++ /dev/null @@ -1,85 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/NewpageBlock.R -\docType{class} -\name{NewpageBlock} -\alias{NewpageBlock} -\title{\code{NewpageBlock}} -\description{ -A \code{ContentBlock} subclass that represents a page break in a report output. -} -\examples{ - -## ------------------------------------------------ -## Method `NewpageBlock$new` -## ------------------------------------------------ - -NewpageBlock <- getFromNamespace("NewpageBlock", "teal.reporter") -block <- NewpageBlock$new() - -} -\keyword{internal} -\section{Super class}{ -\code{\link[teal.reporter:ContentBlock]{teal.reporter::ContentBlock}} -> \code{NewpageBlock} -} -\section{Methods}{ -\subsection{Public methods}{ -\itemize{ -\item \href{#method-NewpageBlock-new}{\code{NewpageBlock$new()}} -\item \href{#method-NewpageBlock-clone}{\code{NewpageBlock$clone()}} -} -} -\if{html}{\out{ -
Inherited methods - -
-}} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-NewpageBlock-new}{}}} -\subsection{Method \code{new()}}{ -Initialize a \code{NewpageBlock} object. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{NewpageBlock$new()}\if{html}{\out{
}} -} - -\subsection{Details}{ -Returns a \code{NewpageBlock} object with no content and the default style. -} - -\subsection{Returns}{ -Object of class \code{NewpageBlock}, invisibly. -} -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{NewpageBlock <- getFromNamespace("NewpageBlock", "teal.reporter") -block <- NewpageBlock$new() - -} -\if{html}{\out{
}} - -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-NewpageBlock-clone}{}}} -\subsection{Method \code{clone()}}{ -The objects of this class are cloneable with this method. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{NewpageBlock$clone(deep = FALSE)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{deep}}{Whether to make a deep clone.} -} -\if{html}{\out{
}} -} -} -} diff --git a/man/PictureBlock.Rd b/man/PictureBlock.Rd deleted file mode 100644 index 37c74ab3a..000000000 --- a/man/PictureBlock.Rd +++ /dev/null @@ -1,264 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/PictureBlock.R -\docType{class} -\name{PictureBlock} -\alias{PictureBlock} -\title{\code{PictureBlock}} -\description{ -Specialized \code{FileBlock} for managing picture content in reports. -It's designed to handle plots from packages such as \code{ggplot2}, \code{grid}, or \code{lattice}. -It can save plots to files, set titles and specify dimensions. -} -\examples{ -\dontshow{if (require("ggplot2") && require("lattice")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} -library(ggplot2) -library(lattice) - -PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter") -block <- PictureBlock$new() -block$set_content(ggplot(iris)) - -PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter") -block <- PictureBlock$new() -block$set_content(bwplot(1)) - -PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter") -block <- PictureBlock$new() -block$set_content(ggplotGrob(ggplot(iris))) -\dontshow{\}) # examplesIf} - -## ------------------------------------------------ -## Method `PictureBlock$set_title` -## ------------------------------------------------ - -PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter") -block <- PictureBlock$new() -block$set_title("Title") - - -## ------------------------------------------------ -## Method `PictureBlock$get_title` -## ------------------------------------------------ - -PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter") -block <- PictureBlock$new() -block$get_title() - - -## ------------------------------------------------ -## Method `PictureBlock$set_dim` -## ------------------------------------------------ - -PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter") -block <- PictureBlock$new() -block$set_dim(c(800, 600)) - - -## ------------------------------------------------ -## Method `PictureBlock$get_dim` -## ------------------------------------------------ - -PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter") -block <- PictureBlock$new() -block$get_dim() -} -\keyword{internal} -\section{Super classes}{ -\code{\link[teal.reporter:ContentBlock]{teal.reporter::ContentBlock}} -> \code{\link[teal.reporter:FileBlock]{teal.reporter::FileBlock}} -> \code{PictureBlock} -} -\section{Methods}{ -\subsection{Public methods}{ -\itemize{ -\item \href{#method-PictureBlock-new}{\code{PictureBlock$new()}} -\item \href{#method-PictureBlock-set_content}{\code{PictureBlock$set_content()}} -\item \href{#method-PictureBlock-set_title}{\code{PictureBlock$set_title()}} -\item \href{#method-PictureBlock-get_title}{\code{PictureBlock$get_title()}} -\item \href{#method-PictureBlock-set_dim}{\code{PictureBlock$set_dim()}} -\item \href{#method-PictureBlock-get_dim}{\code{PictureBlock$get_dim()}} -\item \href{#method-PictureBlock-clone}{\code{PictureBlock$clone()}} -} -} -\if{html}{\out{ -
Inherited methods - -
-}} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-PictureBlock-new}{}}} -\subsection{Method \code{new()}}{ -Initialize a \code{PictureBlock} object. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{PictureBlock$new(plot)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{plot}}{(\code{ggplot} or \code{grid}) a picture in this \code{PictureBlock}} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -Object of class \code{PictureBlock}, invisibly. -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-PictureBlock-set_content}{}}} -\subsection{Method \code{set_content()}}{ -Sets the content of this \code{PictureBlock}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{PictureBlock$set_content(content)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{content}}{(\code{ggplot} or \code{grob} or \code{trellis}) a picture in this \code{PictureBlock}} -} -\if{html}{\out{
}} -} -\subsection{Details}{ -Raises error if argument is not a \code{ggplot}, \code{grob} or \code{trellis} plot. -} - -\subsection{Returns}{ -\code{self}, invisibly. -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-PictureBlock-set_title}{}}} -\subsection{Method \code{set_title()}}{ -Sets the title of this \code{PictureBlock}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{PictureBlock$set_title(title)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{title}}{(\code{character(1)}) a string assigned to this \code{PictureBlock}} -} -\if{html}{\out{
}} -} -\subsection{Details}{ -Raises error if argument is not \code{character(1)}. -} - -\subsection{Returns}{ -\code{self}, invisibly. -} -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter") -block <- PictureBlock$new() -block$set_title("Title") - -} -\if{html}{\out{
}} - -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-PictureBlock-get_title}{}}} -\subsection{Method \code{get_title()}}{ -Get the title of this \code{PictureBlock}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{PictureBlock$get_title()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -The content of this \code{PictureBlock}. -} -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter") -block <- PictureBlock$new() -block$get_title() - -} -\if{html}{\out{
}} - -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-PictureBlock-set_dim}{}}} -\subsection{Method \code{set_dim()}}{ -Sets the dimensions of this \code{PictureBlock}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{PictureBlock$set_dim(dim)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{dim}}{(\code{numeric(2)}) figure dimensions (width and height) in pixels.} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -\code{self}, invisibly. -} -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter") -block <- PictureBlock$new() -block$set_dim(c(800, 600)) - -} -\if{html}{\out{
}} - -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-PictureBlock-get_dim}{}}} -\subsection{Method \code{get_dim()}}{ -Get \code{PictureBlock} dimensions as a numeric vector. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{PictureBlock$get_dim()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -\code{numeric} the array of 2 numeric values representing width and height in pixels. -} -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{PictureBlock <- getFromNamespace("PictureBlock", "teal.reporter") -block <- PictureBlock$new() -block$get_dim() -} -\if{html}{\out{
}} - -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-PictureBlock-clone}{}}} -\subsection{Method \code{clone()}}{ -The objects of this class are cloneable with this method. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{PictureBlock$clone(deep = FALSE)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{deep}}{Whether to make a deep clone.} -} -\if{html}{\out{
}} -} -} -} diff --git a/man/RcodeBlock.Rd b/man/RcodeBlock.Rd deleted file mode 100644 index 8c1068430..000000000 --- a/man/RcodeBlock.Rd +++ /dev/null @@ -1,322 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/RcodeBlock.R -\docType{class} -\name{RcodeBlock} -\alias{RcodeBlock} -\title{\code{RcodeBlock}} -\description{ -Specialized \code{ContentBlock} designed to embed \code{R} code in reports. -} -\examples{ - -## ------------------------------------------------ -## Method `RcodeBlock$new` -## ------------------------------------------------ - -RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter") -block <- RcodeBlock$new() - - -## ------------------------------------------------ -## Method `RcodeBlock$set_content` -## ------------------------------------------------ - -RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter") -block <- RcodeBlock$new() -block$set_content("a <- 1") - - -## ------------------------------------------------ -## Method `RcodeBlock$set_params` -## ------------------------------------------------ - -RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter") -block <- RcodeBlock$new() -block$set_params(list(echo = TRUE)) - - -## ------------------------------------------------ -## Method `RcodeBlock$get_params` -## ------------------------------------------------ - -RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter") -block <- RcodeBlock$new() -block$get_params() - - -## ------------------------------------------------ -## Method `RcodeBlock$get_available_params` -## ------------------------------------------------ - -RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter") -block <- RcodeBlock$new() -block$get_available_params() - - -## ------------------------------------------------ -## Method `RcodeBlock$from_list` -## ------------------------------------------------ - -RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter") -block <- RcodeBlock$new() -block$from_list(list(text = "sth", params = list())) - - -## ------------------------------------------------ -## Method `RcodeBlock$to_list` -## ------------------------------------------------ - -RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter") -block <- RcodeBlock$new() -block$to_list() - -} -\keyword{internal} -\section{Super class}{ -\code{\link[teal.reporter:ContentBlock]{teal.reporter::ContentBlock}} -> \code{RcodeBlock} -} -\section{Methods}{ -\subsection{Public methods}{ -\itemize{ -\item \href{#method-RcodeBlock-new}{\code{RcodeBlock$new()}} -\item \href{#method-RcodeBlock-set_content}{\code{RcodeBlock$set_content()}} -\item \href{#method-RcodeBlock-set_params}{\code{RcodeBlock$set_params()}} -\item \href{#method-RcodeBlock-get_params}{\code{RcodeBlock$get_params()}} -\item \href{#method-RcodeBlock-get_available_params}{\code{RcodeBlock$get_available_params()}} -\item \href{#method-RcodeBlock-from_list}{\code{RcodeBlock$from_list()}} -\item \href{#method-RcodeBlock-to_list}{\code{RcodeBlock$to_list()}} -\item \href{#method-RcodeBlock-clone}{\code{RcodeBlock$clone()}} -} -} -\if{html}{\out{ -
Inherited methods - -
-}} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-RcodeBlock-new}{}}} -\subsection{Method \code{new()}}{ -Initialize a \code{RcodeBlock} object. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{RcodeBlock$new(content = character(0), ...)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{content}}{(\code{character(1)} or \code{character(0)}) a string assigned to this \code{RcodeBlock}} - -\item{\code{...}}{any \code{rmarkdown} \code{R} chunk parameter and it value.} -} -\if{html}{\out{
}} -} -\subsection{Details}{ -Returns a \code{RcodeBlock} object with no content and no parameters. -} - -\subsection{Returns}{ -Object of class \code{RcodeBlock}, invisibly. -} -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter") -block <- RcodeBlock$new() - -} -\if{html}{\out{
}} - -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-RcodeBlock-set_content}{}}} -\subsection{Method \code{set_content()}}{ -Sets content of this \code{RcodeBlock}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{RcodeBlock$set_content(content)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{content}}{(\code{any}) R object} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -\code{self}, invisibly. -} -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter") -block <- RcodeBlock$new() -block$set_content("a <- 1") - -} -\if{html}{\out{
}} - -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-RcodeBlock-set_params}{}}} -\subsection{Method \code{set_params()}}{ -Sets the parameters of this \code{RcodeBlock}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{RcodeBlock$set_params(params)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{params}}{(\code{list}) any \code{rmarkdown} R chunk parameter and its value.} -} -\if{html}{\out{
}} -} -\subsection{Details}{ -Configures \code{rmarkdown} chunk parameters for the \code{R} code block, -influencing its rendering and execution behavior. -} - -\subsection{Returns}{ -\code{self}, invisibly. -} -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter") -block <- RcodeBlock$new() -block$set_params(list(echo = TRUE)) - -} -\if{html}{\out{
}} - -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-RcodeBlock-get_params}{}}} -\subsection{Method \code{get_params()}}{ -Get the parameters of this \code{RcodeBlock}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{RcodeBlock$get_params()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -\code{character} the parameters of this \code{RcodeBlock}. -} -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter") -block <- RcodeBlock$new() -block$get_params() - -} -\if{html}{\out{
}} - -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-RcodeBlock-get_available_params}{}}} -\subsection{Method \code{get_available_params()}}{ -Get available array of parameters available to this \code{RcodeBlock}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{RcodeBlock$get_available_params()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -A \code{character} array of parameters. -} -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter") -block <- RcodeBlock$new() -block$get_available_params() - -} -\if{html}{\out{
}} - -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-RcodeBlock-from_list}{}}} -\subsection{Method \code{from_list()}}{ -Create the \code{RcodeBlock} from a list. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{RcodeBlock$from_list(x)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{x}}{(\verb{named list}) with two fields \code{text} and \code{params}. -Use the \code{get_available_params} method to get all possible parameters.} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -\code{self}, invisibly. -} -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter") -block <- RcodeBlock$new() -block$from_list(list(text = "sth", params = list())) - -} -\if{html}{\out{
}} - -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-RcodeBlock-to_list}{}}} -\subsection{Method \code{to_list()}}{ -Convert the \code{RcodeBlock} to a list. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{RcodeBlock$to_list()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -\verb{named list} with a text and \code{params}. -} -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter") -block <- RcodeBlock$new() -block$to_list() - -} -\if{html}{\out{
}} - -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-RcodeBlock-clone}{}}} -\subsection{Method \code{clone()}}{ -The objects of this class are cloneable with this method. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{RcodeBlock$clone(deep = FALSE)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{deep}}{Whether to make a deep clone.} -} -\if{html}{\out{
}} -} -} -} diff --git a/man/Renderer.Rd b/man/Renderer.Rd deleted file mode 100644 index 32e78f58a..000000000 --- a/man/Renderer.Rd +++ /dev/null @@ -1,267 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/Renderer.R -\docType{class} -\name{Renderer} -\alias{Renderer} -\title{\code{Renderer}} -\description{ -A class for rendering reports from \code{ContentBlock} into various formats using \code{rmarkdown}. -It supports \code{TextBlock}, \code{PictureBlock}, \code{RcodeBlock}, \code{NewpageBlock}, and \code{TableBlock}. -} -\examples{ -\dontshow{if (require("ggplot2")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} -library(yaml) -library(rtables) -library(ggplot2) - -ReportCard <- getFromNamespace("ReportCard", "teal.reporter") -Reporter <- getFromNamespace("Reporter", "teal.reporter") -yaml_quoted <- getFromNamespace("yaml_quoted", "teal.reporter") -md_header <- getFromNamespace("md_header", "teal.reporter") -Renderer <- getFromNamespace("Renderer", "teal.reporter") - -card1 <- ReportCard$new() -card1$append_text("Header 2 text", "header2") -card1$append_text("A paragraph of default text") -card1$append_plot( - ggplot(iris, aes(x = Petal.Length)) + geom_histogram() -) - -card2 <- ReportCard$new() -card2$append_text("Header 2 text", "header2") -card2$append_text("A paragraph of default text") -lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean) -table_res2 <- build_table(lyt, airquality) -card2$append_table(table_res2) -card2$append_rcode("2+2", echo = FALSE) - -reporter <- Reporter$new() -reporter$append_cards(list(card1, card2)) - -yaml_l <- list( - author = yaml_quoted("NEST"), - title = yaml_quoted("Report"), - date = yaml_quoted("07/04/2019"), - output = list(html_document = list(toc = FALSE)) -) - -yaml_header <- md_header(as.yaml(yaml_l)) - -result_path <- Renderer$new()$renderRmd(reporter$get_blocks(), yaml_header) -\dontshow{\}) # examplesIf} -\dontshow{if (require("ggplot2")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} -library(yaml) -library(ggplot2) - -ReportCard <- getFromNamespace("ReportCard", "teal.reporter") -Reporter <- getFromNamespace("Reporter", "teal.reporter") -yaml_quoted <- getFromNamespace("yaml_quoted", "teal.reporter") -md_header <- getFromNamespace("md_header", "teal.reporter") -Renderer <- getFromNamespace("Renderer", "teal.reporter") - -card1 <- ReportCard$new() -card1$append_text("Header 2 text", "header2") -card1$append_text("A paragraph of default text") -card1$append_plot( - ggplot(iris, aes(x = Petal.Length)) + geom_histogram() -) - -card2 <- ReportCard$new() -card2$append_text("Header 2 text", "header2") -card2$append_text("A paragraph of default text") -lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean) -table_res2 <- build_table(lyt, airquality) -card2$append_table(table_res2) -card2$append_rcode("2+2", echo = FALSE) - -reporter <- Reporter$new() -reporter$append_cards(list(card1, card2)) - -yaml_l <- list( - author = yaml_quoted("NEST"), - title = yaml_quoted("Report"), - date = yaml_quoted("07/04/2019"), - output = list(html_document = list(toc = FALSE)) -) - -yaml_header <- md_header(as.yaml(yaml_l)) -result_path <- Renderer$new()$render(reporter$get_blocks(), yaml_header) -\dontshow{\}) # examplesIf} - -## ------------------------------------------------ -## Method `Renderer$new` -## ------------------------------------------------ - -Renderer <- getFromNamespace("Renderer", "teal.reporter") -Renderer$new() - - -## ------------------------------------------------ -## Method `Renderer$get_output_dir` -## ------------------------------------------------ - -Renderer <- getFromNamespace("Renderer", "teal.reporter")$new() -Renderer$get_output_dir() - -} -\keyword{internal} -\section{Methods}{ -\subsection{Public methods}{ -\itemize{ -\item \href{#method-Renderer-new}{\code{Renderer$new()}} -\item \href{#method-Renderer-renderRmd}{\code{Renderer$renderRmd()}} -\item \href{#method-Renderer-render}{\code{Renderer$render()}} -\item \href{#method-Renderer-get_output_dir}{\code{Renderer$get_output_dir()}} -\item \href{#method-Renderer-clone}{\code{Renderer$clone()}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Renderer-new}{}}} -\subsection{Method \code{new()}}{ -Initialize a \code{Renderer} object. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Renderer$new()}\if{html}{\out{
}} -} - -\subsection{Details}{ -Creates a new instance of \code{Renderer} -with a temporary directory for storing report files. -} - -\subsection{Returns}{ -Object of class \code{Renderer}, invisibly. -} -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{Renderer <- getFromNamespace("Renderer", "teal.reporter") -Renderer$new() - -} -\if{html}{\out{
}} - -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Renderer-renderRmd}{}}} -\subsection{Method \code{renderRmd()}}{ -Getting the \code{Rmd} text which could be easily rendered later. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Renderer$renderRmd( - blocks, - yaml_header, - global_knitr = getOption("teal.reporter.global_knitr") -)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{blocks}}{(\code{list}) of \code{TextBlock}, \code{PictureBlock} and \code{NewpageBlock} objects.} - -\item{\code{yaml_header}}{(\code{character}) an \code{rmarkdown} \code{yaml} header.} - -\item{\code{global_knitr}}{(\code{list}) of \code{knitr} parameters (passed to \code{knitr::opts_chunk$set}) -for customizing the rendering process.} -} -\if{html}{\out{
}} -} -\subsection{Details}{ -To access the default values for the \code{global_knitr} parameter, -use \code{getOption('teal.reporter.global_knitr')}. These defaults include: -\itemize{ -\item \code{echo = TRUE} -\item \code{tidy.opts = list(width.cutoff = 60)} -\item \code{tidy = TRUE} if \code{formatR} package is installed, \code{FALSE} otherwise -} -} - -\subsection{Returns}{ -Character vector constituting \code{rmarkdown} text (\code{yaml} header + body), ready to be rendered. -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Renderer-render}{}}} -\subsection{Method \code{render()}}{ -Renders the \code{Report} to the desired output format by compiling the \code{rmarkdown} file. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Renderer$render( - blocks, - yaml_header, - global_knitr = getOption("teal.reporter.global_knitr"), - ... -)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{blocks}}{(\code{list}) of \code{TextBlock}, \code{PictureBlock} or \code{NewpageBlock} objects.} - -\item{\code{yaml_header}}{(\code{character}) an \code{rmarkdown} \code{yaml} header.} - -\item{\code{global_knitr}}{(\code{list}) of \code{knitr} parameters (passed to \code{knitr::opts_chunk$set}) -for customizing the rendering process.} - -\item{\code{...}}{\code{rmarkdown::render} arguments, \code{input} and \code{output_dir} should not be updated.} -} -\if{html}{\out{
}} -} -\subsection{Details}{ -To access the default values for the \code{global_knitr} parameter, -use \code{getOption('teal.reporter.global_knitr')}. These defaults include: -\itemize{ -\item \code{echo = TRUE} -\item \code{tidy.opts = list(width.cutoff = 60)} -\item \code{tidy = TRUE} if \code{formatR} package is installed, \code{FALSE} otherwise -} -} - -\subsection{Returns}{ -\code{character} path to the output. -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Renderer-get_output_dir}{}}} -\subsection{Method \code{get_output_dir()}}{ -Get \code{output_dir} field. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Renderer$get_output_dir()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -\code{character} a \code{output_dir} field path. -} -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{Renderer <- getFromNamespace("Renderer", "teal.reporter")$new() -Renderer$get_output_dir() - -} -\if{html}{\out{
}} - -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Renderer-clone}{}}} -\subsection{Method \code{clone()}}{ -The objects of this class are cloneable with this method. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Renderer$clone(deep = FALSE)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{deep}}{Whether to make a deep clone.} -} -\if{html}{\out{
}} -} -} -} diff --git a/man/ReportCard.Rd b/man/ReportCard.Rd index 5dfd44040..f306892ae 100644 --- a/man/ReportCard.Rd +++ b/man/ReportCard.Rd @@ -91,8 +91,7 @@ card <- ReportCard$new()$append_rcode("2+2", echo = FALSE) ## Method `ReportCard$append_content` ## ------------------------------------------------ -NewpageBlock <- getFromNamespace("NewpageBlock", "teal.reporter") -card <- ReportCard$new()$append_content(NewpageBlock$new()) +card <- ReportCard$new()$append_content(code_chunk("foo <- 2")) ## ------------------------------------------------ @@ -142,6 +141,7 @@ ReportCard$new()$set_name("NAME")$get_name() \item \href{#method-ReportCard-append_metadata}{\code{ReportCard$append_metadata()}} \item \href{#method-ReportCard-get_name}{\code{ReportCard$get_name()}} \item \href{#method-ReportCard-set_name}{\code{ReportCard$set_name()}} +\item \href{#method-ReportCard-set_content_names}{\code{ReportCard$set_content_names()}} \item \href{#method-ReportCard-to_list}{\code{ReportCard$to_list()}} \item \href{#method-ReportCard-from_list}{\code{ReportCard$from_list()}} \item \href{#method-ReportCard-clone}{\code{ReportCard$clone()}} @@ -256,7 +256,10 @@ Appends a plot to this \code{ReportCard}. \subsection{Method \code{append_text()}}{ Appends a text paragraph to this \code{ReportCard}. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{ReportCard$append_text(text, style = TextBlock$new()$get_available_styles()[1])}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{ReportCard$append_text( + text, + style = c("default", "header2", "header3", "verbatim") +)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -264,7 +267,7 @@ Appends a text paragraph to this \code{ReportCard}. \describe{ \item{\code{text}}{(\code{character}) The text content to add.} -\item{\code{style}}{(\code{character(1)}) the style of the paragraph. One of: default, header2, header3, verbatim.} +\item{\code{style}}{(\code{character(1)}) the style of the paragraph.} } \if{html}{\out{}} } @@ -316,7 +319,7 @@ Appends an \code{R} code chunk to \code{ReportCard}. \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-ReportCard-append_content}{}}} \subsection{Method \code{append_content()}}{ -Appends a generic \code{ContentBlock} to this \code{ReportCard}. +Appends a generic content to this \code{ReportCard}. \subsection{Usage}{ \if{html}{\out{
}}\preformatted{ReportCard$append_content(content)}\if{html}{\out{
}} } @@ -324,7 +327,7 @@ Appends a generic \code{ContentBlock} to this \code{ReportCard}. \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{content}}{(\code{ContentBlock}) object.} +\item{\code{content}}{(Object.)} } \if{html}{\out{
}} } @@ -333,8 +336,7 @@ Appends a generic \code{ContentBlock} to this \code{ReportCard}. } \subsection{Examples}{ \if{html}{\out{
}} -\preformatted{NewpageBlock <- getFromNamespace("NewpageBlock", "teal.reporter") -card <- ReportCard$new()$append_content(NewpageBlock$new()) +\preformatted{card <- ReportCard$new()$append_content(code_chunk("foo <- 2")) } \if{html}{\out{
}} @@ -352,7 +354,7 @@ Get all content blocks from this \code{ReportCard}. } \subsection{Returns}{ -\code{list()} list of \code{TableBlock}, \code{TextBlock} and \code{PictureBlock}. +\code{teal_card()} containing appended elements. } \subsection{Examples}{ \if{html}{\out{
}} @@ -474,6 +476,23 @@ Set the name of the \code{ReportCard}. } +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-ReportCard-set_content_names}{}}} +\subsection{Method \code{set_content_names()}}{ +Set content block names for compatibility with newer \code{teal_card} +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{ReportCard$set_content_names(new_names)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{new_names}}{(\code{character}) vector of new names.} +} +\if{html}{\out{
}} +} } \if{html}{\out{
}} \if{html}{\out{}} @@ -481,7 +500,7 @@ Set the name of the \code{ReportCard}. \subsection{Method \code{to_list()}}{ Convert the \code{ReportCard} to a list, including content and metadata. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{ReportCard$to_list(output_dir)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{ReportCard$to_list(output_dir = lifecycle::deprecated())}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -501,7 +520,7 @@ Convert the \code{ReportCard} to a list, including content and metadata. \subsection{Method \code{from_list()}}{ Reconstructs the \code{ReportCard} from a list representation. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{ReportCard$from_list(card, output_dir)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{ReportCard$from_list(card, output_dir = lifecycle::deprecated())}\if{html}{\out{
}} } \subsection{Arguments}{ diff --git a/man/Reporter.Rd b/man/Reporter.Rd index 978d194c9..126601691 100644 --- a/man/Reporter.Rd +++ b/man/Reporter.Rd @@ -3,14 +3,14 @@ \docType{class} \name{Reporter} \alias{Reporter} -\title{\code{Reporter}: An \code{R6} class for managing report cards} +\title{\code{Reporter}: An \code{R6} class for managing reports} \description{ -This \code{R6} class is designed to store and manage report cards, +This \code{R6} class is designed to store and manage reports, facilitating the creation, manipulation, and serialization of report-related data. +It supports both \code{ReportCard} and \code{teal_card} objects, allowing flexibility +in the types of reports that can be stored and managed. } \note{ -The function has to be used in the shiny reactive context. - if Report has an id when converting to JSON then It will be compared to the currently available one. if Report has an id when converting to JSON then It will be compared to the currently available one. @@ -18,46 +18,78 @@ if Report has an id when converting to JSON then It will be compared to the curr \examples{ \dontshow{if (require("ggplot2")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} library(ggplot2) -library(rtables) -card1 <- ReportCard$new() +card1 <- teal_card("## Header 2 text", "A paragraph of default text") +card1 <- c(card1, ggplot(iris, aes(x = Petal.Length)) + geom_histogram()) +metadata(card1, "title") <- "Card1" -card1$append_text("Header 2 text", "header2") -card1$append_text("A paragraph of default text") -card1$append_plot( - ggplot(iris, aes(x = Petal.Length)) + geom_histogram() -) +card2 <- teal_card("Document introduction") +metadata(card2, "title") <- "Card2" -card2 <- ReportCard$new() +reporter <- Reporter$new() +reporter$append_cards(list(card1, card2)) +\dontshow{\}) # examplesIf} +\dontshow{if (require("ggplot2")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +library(ggplot2) +library(rtables) + +card1 <- teal_card("## Header 2 text", "A paragraph of default text") +card1 <- c(card1, ggplot(iris, aes(x = Petal.Length)) + geom_histogram()) +metadata(card1, "title") <- "Card1" -card2$append_text("Header 2 text", "header2") -card2$append_text("A paragraph of default text") lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean) table_res2 <- build_table(lyt, airquality) -card2$append_table(table_res2) +card2 <- teal_card( + "## Header 2 text", + "A paragraph of default text", + table_res2 +) +metadata(card2, "title") <- "Card2" reporter <- Reporter$new() reporter$append_cards(list(card1, card2)) + +names(reporter$get_cards()) +reporter$reorder_cards(c("Card2", "Card1")) +names(reporter$get_cards()) \dontshow{\}) # examplesIf} \dontshow{if (require("ggplot2")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} library(ggplot2) library(rtables) -card1 <- ReportCard$new() +card1 <- teal_card("## Header 2 text", "A paragraph of default text") +card1 <- c(card1, ggplot(iris, aes(x = Petal.Length)) + geom_histogram()) +metadata(card1, "title") <- "Card1" + +reporter <- Reporter$new() +reporter$append_cards(list(card1)) -card1$append_text("Header 2 text", "header2") -card1$append_text("A paragraph of default text") -card1$append_plot( - ggplot(iris, aes(x = Petal.Length)) + geom_histogram() +lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean) +table_res2 <- build_table(lyt, airquality) +card2 <- teal_card( + "## Header 2 text", + "A paragraph of default text", + table_res2 ) +metadata(card2, "title") <- "Card2" -card2 <- ReportCard$new() +reporter$replace_card(card2, "Card1") +reporter$get_cards()[[1]]$get_name() +\dontshow{\}) # examplesIf} +\dontshow{if (require("ggplot2")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +library(ggplot2) +library(rtables) + +card1 <- teal_card("## Header 2 text", "A paragraph of default text") +card1 <- c(card1, ggplot(iris, aes(x = Petal.Length)) + geom_histogram()) -card2$append_text("Header 2 text", "header2") -card2$append_text("A paragraph of default text") lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean) table_res2 <- build_table(lyt, airquality) -card2$append_table(table_res2) +card2 <- teal_card( + "## Header 2 text", + "A paragraph of default text", + table_res2 +) reporter <- Reporter$new() reporter$append_cards(list(card1, card2)) @@ -67,21 +99,16 @@ reporter$get_cards() library(ggplot2) library(rtables) -card1 <- ReportCard$new() +card1 <- teal_card("## Header 2 text", "A paragraph of default text") +card1 <- c(card1, ggplot(iris, aes(x = Petal.Length)) + geom_histogram()) -card1$append_text("Header 2 text", "header2") -card1$append_text("A paragraph of default text") -card1$append_plot( - ggplot(iris, aes(x = Petal.Length)) + geom_histogram() -) - -card2 <- ReportCard$new() - -card2$append_text("Header 2 text", "header2") -card2$append_text("A paragraph of default text") lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean) table_res2 <- build_table(lyt, airquality) -card2$append_table(table_res2) +card2 <- teal_card( + "## Header 2 text", + "A paragraph of default text", + table_res2 +) reporter <- Reporter$new() reporter$append_cards(list(card1, card2)) @@ -95,14 +122,6 @@ reporter$get_blocks() reporter <- Reporter$new() -## ------------------------------------------------ -## Method `Reporter$get_reactive_add_card` -## ------------------------------------------------ - -library(shiny) - -isolate(Reporter$new()$get_reactive_add_card()) - ## ------------------------------------------------ ## Method `Reporter$get_metadata` ## ------------------------------------------------ @@ -164,27 +183,48 @@ dir.create(tmp_dir) unlink(list.files(tmp_dir, recursive = TRUE)) reporter$to_jsondir(tmp_dir) reporter$from_jsondir(tmp_dir) + +## ------------------------------------------------ +## Method `Reporter$set_template` +## ------------------------------------------------ + + +reporter <- teal.reporter::Reporter$new() +template_fun <- function(document) { + disclaimer <- teal.reporter::teal_card("Here comes disclaimer text") + c(disclaimer, document) +} +reporter$set_template(template_fun) +doc1 <- teal.reporter::teal_card("## Header 2 text", "Regular text") +metadata(doc1, "title") <- "Welcome card" +reporter$append_cards(doc1) +reporter$get_cards() } \section{Methods}{ \subsection{Public methods}{ \itemize{ \item \href{#method-Reporter-new}{\code{Reporter$new()}} \item \href{#method-Reporter-append_cards}{\code{Reporter$append_cards()}} +\item \href{#method-Reporter-reorder_cards}{\code{Reporter$reorder_cards()}} +\item \href{#method-Reporter-replace_card}{\code{Reporter$replace_card()}} \item \href{#method-Reporter-get_cards}{\code{Reporter$get_cards()}} \item \href{#method-Reporter-get_blocks}{\code{Reporter$get_blocks()}} \item \href{#method-Reporter-reset}{\code{Reporter$reset()}} \item \href{#method-Reporter-remove_cards}{\code{Reporter$remove_cards()}} -\item \href{#method-Reporter-reorder_cards}{\code{Reporter$reorder_cards()}} -\item \href{#method-Reporter-get_reactive_add_card}{\code{Reporter$get_reactive_add_card()}} \item \href{#method-Reporter-get_metadata}{\code{Reporter$get_metadata()}} \item \href{#method-Reporter-append_metadata}{\code{Reporter$append_metadata()}} \item \href{#method-Reporter-from_reporter}{\code{Reporter$from_reporter()}} \item \href{#method-Reporter-to_list}{\code{Reporter$to_list()}} +\item \href{#method-Reporter-write_figures}{\code{Reporter$write_figures()}} \item \href{#method-Reporter-from_list}{\code{Reporter$from_list()}} \item \href{#method-Reporter-to_jsondir}{\code{Reporter$to_jsondir()}} \item \href{#method-Reporter-from_jsondir}{\code{Reporter$from_jsondir()}} \item \href{#method-Reporter-set_id}{\code{Reporter$set_id()}} +\item \href{#method-Reporter-reactive_trigger}{\code{Reporter$reactive_trigger()}} +\item \href{#method-Reporter-get_cached_html}{\code{Reporter$get_cached_html()}} \item \href{#method-Reporter-get_id}{\code{Reporter$get_id()}} +\item \href{#method-Reporter-set_template}{\code{Reporter$set_template()}} +\item \href{#method-Reporter-get_template}{\code{Reporter$get_template()}} \item \href{#method-Reporter-clone}{\code{Reporter$clone()}} } } @@ -214,7 +254,7 @@ Object of class \code{Reporter}, invisibly. \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Reporter-append_cards}{}}} \subsection{Method \code{append_cards()}}{ -Append one or more \code{ReportCard} objects to the \code{Reporter}. +Append one or more \code{ReportCard} or \code{teal_card} objects to the \code{Reporter}. \subsection{Usage}{ \if{html}{\out{
}}\preformatted{Reporter$append_cards(cards)}\if{html}{\out{
}} } @@ -222,7 +262,53 @@ Append one or more \code{ReportCard} objects to the \code{Reporter}. \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{cards}}{(\code{ReportCard}) or a list of such objects} +\item{\code{cards}}{(\code{ReportCard} or \code{teal_card}) or a list of such objects} +} +\if{html}{\out{
}} +} +\subsection{Returns}{ +\code{self}, invisibly. +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Reporter-reorder_cards}{}}} +\subsection{Method \code{reorder_cards()}}{ +Reorders \code{teal_card} objects in \code{Reporter}. + + +Reorders \code{teal_card} objects in \code{Reporter}. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Reporter$reorder_cards(new_order)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{new_order}}{\code{character} vector with names of \code{teal_card} objects to +be set in this order.} +} +\if{html}{\out{
}} +} +\subsection{Returns}{ +\code{self}, invisibly. +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Reporter-replace_card}{}}} +\subsection{Method \code{replace_card()}}{ +Sets \code{ReportCard} or \code{teal_card} content. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Reporter$replace_card(card, card_id)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{card}}{The new object (\code{ReportCard} or \code{teal_card}) to replace the existing one.} + +\item{\code{card_id}}{(\code{character(1)}) the unique id of the card to be replaced.} } \if{html}{\out{
}} } @@ -234,41 +320,42 @@ Append one or more \code{ReportCard} objects to the \code{Reporter}. \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Reporter-get_cards}{}}} \subsection{Method \code{get_cards()}}{ -Retrieves all \code{ReportCard} objects contained in the \code{Reporter}. +Retrieves all \code{teal_card} objects contained in \code{Reporter}. \subsection{Usage}{ \if{html}{\out{
}}\preformatted{Reporter$get_cards()}\if{html}{\out{
}} } \subsection{Returns}{ -A (\code{list}) of \code{\link{ReportCard}} objects. +A (\code{list}) of \code{\link{teal_card}} objects. } } \if{html}{\out{
}} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Reporter-get_blocks}{}}} \subsection{Method \code{get_blocks()}}{ -Compiles and returns all content blocks from the \code{\link{ReportCard}} in the \code{Reporter}. +Compiles and returns all content blocks from the \code{teal_card} +objects in the \code{Reporter}. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Reporter$get_blocks(sep = NewpageBlock$new())}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Reporter$get_blocks(sep = "\\\\newpage")}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ \item{\code{sep}}{An optional separator to insert between each content block. -Default is a \code{NewpageBlock$new()}object.} +Default is a \verb{\\n\\\\newpage\\n} markdown.} } \if{html}{\out{
}} } \subsection{Returns}{ -\code{list()} list of \code{TableBlock}, \code{TextBlock}, \code{PictureBlock} and \code{NewpageBlock}. +\code{list()} of \code{teal_card} } } \if{html}{\out{
}} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Reporter-reset}{}}} \subsection{Method \code{reset()}}{ -Resets the \code{Reporter}, removing all \code{\link{ReportCard}} objects and metadata. +Resets the \code{Reporter}, removing all \code{teal_card} objects and metadata. \subsection{Usage}{ \if{html}{\out{
}}\preformatted{Reporter$reset()}\if{html}{\out{
}} } @@ -281,64 +368,21 @@ Resets the \code{Reporter}, removing all \code{\link{ReportCard}} objects and me \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Reporter-remove_cards}{}}} \subsection{Method \code{remove_cards()}}{ -Removes specific \code{ReportCard} objects from the \code{Reporter} by their indices. +Removes specific \code{teal_card} objects from the \code{Reporter} by their indices. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Reporter$remove_cards(ids)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Reporter$remove_cards(ids = NULL)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{ids}}{(\code{character}) the ids of the cards to be removed.} +\item{\code{ids}}{(\code{integer}, \code{character}) the indexes of cards (either name)} } \if{html}{\out{
}} } \subsection{Returns}{ \code{self}, invisibly. } -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Reporter-reorder_cards}{}}} -\subsection{Method \code{reorder_cards()}}{ -Reorders \code{ReportCard} or \code{ReportDocument} objects in \code{Reporter}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Reporter$reorder_cards(new_order)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{new_order}}{\code{character} vector with card ids in the desired order.} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -\code{self}, invisibly. -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Reporter-get_reactive_add_card}{}}} -\subsection{Method \code{get_reactive_add_card()}}{ -Gets the current value of the reactive variable for adding cards. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Reporter$get_reactive_add_card()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -\code{reactive_add_card} current \code{numeric} value of the reactive variable. -} -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{library(shiny) - -isolate(Reporter$new()$get_reactive_add_card()) -} -\if{html}{\out{
}} - -} - } \if{html}{\out{
}} \if{html}{\out{}} @@ -453,6 +497,25 @@ reporter$to_list(tmp_dir) } +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Reporter-write_figures}{}}} +\subsection{Method \code{write_figures()}}{ +Extracts and saves all figure elements from the \code{teal_card} objects in the \code{Reporter} to a specified directory. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Reporter$write_figures(output_dir, sub_directory = "figures")}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{output_dir}}{(\code{character(1)}) a path to the directory where figures will be saved.} + +\item{\code{sub_directory}}{(\code{character(1)}) a sub-directory within \code{output_dir} to save figures.} +} +\if{html}{\out{
}} +} } \if{html}{\out{
}} \if{html}{\out{}} @@ -575,6 +638,43 @@ The id is added to the downloaded file name. } } \if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Reporter-reactive_trigger}{}}} +\subsection{Method \code{reactive_trigger()}}{ +Trigger report rendering of preview modal in shiny context. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Reporter$reactive_trigger(val)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{val}}{value to the passed to the reactive trigger.} +} +\if{html}{\out{
}} +} +\subsection{Returns}{ +\code{reactiveVal} value +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Reporter-get_cached_html}{}}} +\subsection{Method \code{get_cached_html()}}{ +Get cached HTML for a specific \code{teal_card} by its id. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Reporter$get_cached_html(card_id)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{card_id}}{(\code{character(1)}) the unique id of the card.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Reporter-get_id}{}}} \subsection{Method \code{get_id()}}{ @@ -588,6 +688,58 @@ Get the \code{Reporter} id } } \if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Reporter-set_template}{}}} +\subsection{Method \code{set_template()}}{ +Set template function for \code{teal_card} +Set a function that is called on every report content (of class \code{teal_card}) added through \verb{$append_cards} +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Reporter$set_template(template)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{template}}{(\code{function}) a template function.} +} +\if{html}{\out{
}} +} +\subsection{Returns}{ +\code{self}, invisibly. +} +\subsection{Examples}{ +\if{html}{\out{
}} +\preformatted{ +reporter <- teal.reporter::Reporter$new() +template_fun <- function(document) { + disclaimer <- teal.reporter::teal_card("Here comes disclaimer text") + c(disclaimer, document) +} +reporter$set_template(template_fun) +doc1 <- teal.reporter::teal_card("## Header 2 text", "Regular text") +metadata(doc1, "title") <- "Welcome card" +reporter$append_cards(doc1) +reporter$get_cards() +} +\if{html}{\out{
}} + +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Reporter-get_template}{}}} +\subsection{Method \code{get_template()}}{ +Get the \code{Reporter} template +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Reporter$get_template()}\if{html}{\out{
}} +} + +\subsection{Returns}{ +a template \code{function}. +} +} +\if{html}{\out{
}} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Reporter-clone}{}}} \subsection{Method \code{clone()}}{ diff --git a/man/TableBlock.Rd b/man/TableBlock.Rd deleted file mode 100644 index 242354155..000000000 --- a/man/TableBlock.Rd +++ /dev/null @@ -1,118 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/TableBlock.R -\docType{class} -\name{TableBlock} -\alias{TableBlock} -\title{\code{TableBlock}} -\description{ -Specialized \code{FileBlock} for managing table content in reports. -It's designed to handle various table formats, converting them into a consistent, -document-ready format (e.g., \code{flextable}) for inclusion in reports. -} -\examples{ - -## ------------------------------------------------ -## Method `TableBlock$set_content` -## ------------------------------------------------ - -TableBlock <- getFromNamespace("TableBlock", "teal.reporter") -block <- TableBlock$new() -block$set_content(iris) - -} -\keyword{internal} -\section{Super classes}{ -\code{\link[teal.reporter:ContentBlock]{teal.reporter::ContentBlock}} -> \code{\link[teal.reporter:FileBlock]{teal.reporter::FileBlock}} -> \code{TableBlock} -} -\section{Methods}{ -\subsection{Public methods}{ -\itemize{ -\item \href{#method-TableBlock-new}{\code{TableBlock$new()}} -\item \href{#method-TableBlock-set_content}{\code{TableBlock$set_content()}} -\item \href{#method-TableBlock-clone}{\code{TableBlock$clone()}} -} -} -\if{html}{\out{ -
Inherited methods - -
-}} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-TableBlock-new}{}}} -\subsection{Method \code{new()}}{ -Initialize a \code{TableBlock} object. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{TableBlock$new(table)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{table}}{(\code{data.frame} or \code{rtables} or \code{TableTree} or \code{ElementaryTable} or \code{listing_df}) a table assigned to -this \code{TableBlock}} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -Object of class \code{TableBlock}, invisibly. -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-TableBlock-set_content}{}}} -\subsection{Method \code{set_content()}}{ -Sets content of this \code{TableBlock}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{TableBlock$set_content(content)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{content}}{(\code{data.frame} or \code{rtables} or \code{TableTree} or \code{ElementaryTable} or \code{listing_df}) -a table assigned to this \code{TableBlock}} -} -\if{html}{\out{
}} -} -\subsection{Details}{ -Raises error if argument is not a table-like object. -} - -\subsection{Returns}{ -\code{self}, invisibly. -} -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{TableBlock <- getFromNamespace("TableBlock", "teal.reporter") -block <- TableBlock$new() -block$set_content(iris) - -} -\if{html}{\out{
}} - -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-TableBlock-clone}{}}} -\subsection{Method \code{clone()}}{ -The objects of this class are cloneable with this method. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{TableBlock$clone(deep = FALSE)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{deep}}{Whether to make a deep clone.} -} -\if{html}{\out{
}} -} -} -} diff --git a/man/TextBlock.Rd b/man/TextBlock.Rd deleted file mode 100644 index b16b3ba5a..000000000 --- a/man/TextBlock.Rd +++ /dev/null @@ -1,323 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/TextBlock.R -\docType{class} -\name{TextBlock} -\alias{TextBlock} -\title{\code{TextBlock}} -\description{ -Specialized \code{ContentBlock} for embedding styled text within reports. -It supports multiple styling options to accommodate various text roles, -such as headers or verbatim text, in the report content. -} -\examples{ - -## ------------------------------------------------ -## Method `TextBlock$new` -## ------------------------------------------------ - -TextBlock <- getFromNamespace("TextBlock", "teal.reporter") -block <- TextBlock$new() - - -## ------------------------------------------------ -## Method `TextBlock$set_content` -## ------------------------------------------------ - -ContentBlock <- getFromNamespace("ContentBlock", "teal.reporter") -block <- ContentBlock$new() -block$set_content("Base64 encoded picture") - - -## ------------------------------------------------ -## Method `TextBlock$set_style` -## ------------------------------------------------ - -TextBlock <- getFromNamespace("TextBlock", "teal.reporter") -block <- TextBlock$new() -block$set_style("header2") - - -## ------------------------------------------------ -## Method `TextBlock$get_style` -## ------------------------------------------------ - -TextBlock <- getFromNamespace("TextBlock", "teal.reporter") -block <- TextBlock$new() -block$get_style() - - -## ------------------------------------------------ -## Method `TextBlock$get_available_styles` -## ------------------------------------------------ - -TextBlock <- getFromNamespace("TextBlock", "teal.reporter") -block <- TextBlock$new() -block$get_available_styles() - - -## ------------------------------------------------ -## Method `TextBlock$from_list` -## ------------------------------------------------ - -TextBlock <- getFromNamespace("TextBlock", "teal.reporter") -block <- TextBlock$new() -block$from_list(list(text = "sth", style = "default")) - - -## ------------------------------------------------ -## Method `TextBlock$to_list` -## ------------------------------------------------ - -TextBlock <- getFromNamespace("TextBlock", "teal.reporter") -block <- TextBlock$new() -block$to_list() - -} -\keyword{internal} -\section{Super class}{ -\code{\link[teal.reporter:ContentBlock]{teal.reporter::ContentBlock}} -> \code{TextBlock} -} -\section{Methods}{ -\subsection{Public methods}{ -\itemize{ -\item \href{#method-TextBlock-new}{\code{TextBlock$new()}} -\item \href{#method-TextBlock-set_content}{\code{TextBlock$set_content()}} -\item \href{#method-TextBlock-set_style}{\code{TextBlock$set_style()}} -\item \href{#method-TextBlock-get_style}{\code{TextBlock$get_style()}} -\item \href{#method-TextBlock-get_available_styles}{\code{TextBlock$get_available_styles()}} -\item \href{#method-TextBlock-from_list}{\code{TextBlock$from_list()}} -\item \href{#method-TextBlock-to_list}{\code{TextBlock$to_list()}} -\item \href{#method-TextBlock-clone}{\code{TextBlock$clone()}} -} -} -\if{html}{\out{ -
Inherited methods - -
-}} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-TextBlock-new}{}}} -\subsection{Method \code{new()}}{ -Initialize a \code{TextBlock} object. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{TextBlock$new(content = character(0), style = private$styles[1])}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{content}}{(\code{character}) a string assigned to this \code{TextBlock}} - -\item{\code{style}}{(\code{character(1)}) one of: \code{"default"}, \code{"header2"}, \code{"header3"} \code{"verbatim"}} -} -\if{html}{\out{
}} -} -\subsection{Details}{ -Constructs a \code{TextBlock} object with no content and the default style. -} - -\subsection{Returns}{ -Object of class \code{TextBlock}, invisibly. -} -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{TextBlock <- getFromNamespace("TextBlock", "teal.reporter") -block <- TextBlock$new() - -} -\if{html}{\out{
}} - -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-TextBlock-set_content}{}}} -\subsection{Method \code{set_content()}}{ -Sets content of this \code{TextBlock}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{TextBlock$set_content(content)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{content}}{(\code{any}) R object} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -\code{self}, invisibly. -} -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{ContentBlock <- getFromNamespace("ContentBlock", "teal.reporter") -block <- ContentBlock$new() -block$set_content("Base64 encoded picture") - -} -\if{html}{\out{
}} - -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-TextBlock-set_style}{}}} -\subsection{Method \code{set_style()}}{ -Sets the style of this \code{TextBlock}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{TextBlock$set_style(style)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{style}}{(\code{character(1)}) one of: \code{"default"}, \code{"header2"}, \code{"header3"} \code{"verbatim"}} -} -\if{html}{\out{
}} -} -\subsection{Details}{ -The style has bearing on the rendering of this block. -} - -\subsection{Returns}{ -\code{self}, invisibly. -} -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{TextBlock <- getFromNamespace("TextBlock", "teal.reporter") -block <- TextBlock$new() -block$set_style("header2") - -} -\if{html}{\out{
}} - -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-TextBlock-get_style}{}}} -\subsection{Method \code{get_style()}}{ -Get the style of this \code{TextBlock}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{TextBlock$get_style()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -\code{character(1)} the style of this \code{TextBlock}. -} -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{TextBlock <- getFromNamespace("TextBlock", "teal.reporter") -block <- TextBlock$new() -block$get_style() - -} -\if{html}{\out{
}} - -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-TextBlock-get_available_styles}{}}} -\subsection{Method \code{get_available_styles()}}{ -Get available an array of styles available to this \code{TextBlock}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{TextBlock$get_available_styles()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -A \code{character} array of styles. -} -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{TextBlock <- getFromNamespace("TextBlock", "teal.reporter") -block <- TextBlock$new() -block$get_available_styles() - -} -\if{html}{\out{
}} - -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-TextBlock-from_list}{}}} -\subsection{Method \code{from_list()}}{ -Create the \code{TextBlock} from a list. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{TextBlock$from_list(x)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{x}}{(\verb{named list}) with two fields \code{text} and \code{style}. -Use the \code{get_available_styles} method to get all possible styles.} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -\code{self}, invisibly. -} -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{TextBlock <- getFromNamespace("TextBlock", "teal.reporter") -block <- TextBlock$new() -block$from_list(list(text = "sth", style = "default")) - -} -\if{html}{\out{
}} - -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-TextBlock-to_list}{}}} -\subsection{Method \code{to_list()}}{ -Convert the \code{TextBlock} to a list. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{TextBlock$to_list()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -\verb{named list} with a text and style. -} -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{TextBlock <- getFromNamespace("TextBlock", "teal.reporter") -block <- TextBlock$new() -block$to_list() - -} -\if{html}{\out{
}} - -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-TextBlock-clone}{}}} -\subsection{Method \code{clone()}}{ -The objects of this class are cloneable with this method. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{TextBlock$clone(deep = FALSE)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{deep}}{Whether to make a deep clone.} -} -\if{html}{\out{
}} -} -} -} diff --git a/man/add_card_button.Rd b/man/add_card_button.Rd index 4e9629587..f1c3ae27e 100644 --- a/man/add_card_button.Rd +++ b/man/add_card_button.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AddCardModule.R +% Please edit documentation in R/add_card.R \name{add_card_button} \alias{add_card_button} \alias{add_card_button_ui} @@ -30,18 +30,18 @@ For more details see the vignette: \code{vignette("simpleReporter", "teal.report \details{ The \code{card_fun} function is designed to create a new \code{ReportCard} instance and optionally customize it: \itemize{ -\item The \code{card} parameter allows for specifying a custom or default \code{ReportCard} instance. +\item The \code{teal_card} parameter allows for specifying a custom or default \code{ReportCard} instance. \item Use the \code{comment} parameter to add a comment to the card via \code{card$append_text()} - if \code{card_fun} does not have the \code{comment} parameter, then \code{comment} from \verb{Add Card UI} module will be added at the end of the content of the card. \item The \code{label} parameter enables customization of the card's name and its content through \code{card$append_text()}- if \code{card_fun} does not have the \code{label} parameter, then card name will be set to the name passed in -\verb{Add Card UI} module, but no text will be added to the content of the \code{card}. +\verb{Add Card UI} module, but no text will be added to the content of the \code{teal_card}. } This module supports using a subclass of \code{\link{ReportCard}} for added flexibility. A subclass instance should be passed as the default value of -the \code{card} argument in the \code{card_fun} function. +the \code{teal_card} argument in the \code{card_fun} function. See below: \if{html}{\out{
}}\preformatted{CustomReportCard <- R6::R6Class( diff --git a/man/as_yaml_auto.Rd b/man/as_yaml_auto.Rd deleted file mode 100644 index 19d88d90e..000000000 --- a/man/as_yaml_auto.Rd +++ /dev/null @@ -1,86 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/yaml_utils.R -\name{as_yaml_auto} -\alias{as_yaml_auto} -\title{Parse a named list to \code{yaml} header for an \code{Rmd} file} -\usage{ -as_yaml_auto( - input_list, - as_header = TRUE, - convert_logi = TRUE, - multi_output = FALSE, - silent = FALSE -) -} -\arguments{ -\item{input_list}{(\verb{named list}) non nested with slots names and their values compatible with \code{Rmd} \code{yaml} header.} - -\item{as_header}{(\code{logical(1)}) optionally wrap with result with the internal \code{md_header()}, default \code{TRUE}.} - -\item{convert_logi}{(\code{logical(1)}) convert a character values to logical, -if they are recognized as quoted \code{yaml} logical values , default \code{TRUE}.} - -\item{multi_output}{(\code{logical(1)}) multi \code{output} slots in the \code{input} argument, default \code{FALSE}.} - -\item{silent}{(\code{logical(1)}) suppress messages and warnings, default \code{FALSE}.} -} -\value{ -\code{character} with \code{rmd_yaml_header} class, -result of \code{\link[yaml:as.yaml]{yaml::as.yaml}}, optionally wrapped with internal \code{md_header()}. -} -\description{ -Converts a named list into a \code{yaml} header for \code{Rmd}, handling output types and arguments -as defined in the \code{rmarkdown} package. This function simplifies the process of generating \code{yaml} headers. -} -\details{ -This function processes a non-nested (flat) named list into a \code{yaml} header for an \code{Rmd} document. -It supports all standard \code{Rmd} \code{yaml} header fields, including \code{author}, \code{date}, \code{title}, \code{subtitle}, -\code{abstract}, \code{keywords}, \code{subject}, \code{description}, \code{category}, and \code{lang}. -Additionally, it handles \code{output} field types and arguments as defined in the \code{rmarkdown} package. -} -\note{ -Only non-nested lists are automatically parsed. -Nested lists require direct processing with \code{yaml::as.yaml}. -} -\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 -) -} diff --git a/man/c.teal_report.Rd b/man/c.teal_report.Rd new file mode 100644 index 000000000..790d39b07 --- /dev/null +++ b/man/c.teal_report.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/teal_report-c.R +\name{c.teal_report} +\alias{c.teal_report} +\title{Concatenate \code{teal_report} objects} +\usage{ +\method{c}{teal_report}(...) +} +\arguments{ +\item{...}{(\code{teal_report}) objects to concatenate} +} +\value{ +A \code{\link{teal_report}} object with combined \code{\link{teal_card}} elements. +} +\description{ +Concatenate \code{teal_report} objects +} diff --git a/man/code_chunk.Rd b/man/code_chunk.Rd new file mode 100644 index 000000000..1c5bcbf1d --- /dev/null +++ b/man/code_chunk.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/teal_card.R +\name{code_chunk} +\alias{code_chunk} +\title{Generate an R Markdown code chunk} +\usage{ +code_chunk(code, ..., lang = "R") +} +\arguments{ +\item{code}{A character string containing the R code.} + +\item{...}{Additional named parameters to be included as chunk options (e.g., \code{echo = TRUE}). +Check \href{https://yihui.org/knitr/options/}{knitr options/} for more details.} + +\item{lang}{(\code{character(1)}) See \code{\link[knitr:knit_engines]{knitr::knit_engines}}.} +} +\value{ +An object of class \code{code_chunk}. +} +\description{ +This function creates a \code{code_chunk} object, which represents an R Markdown +code chunk. It stores the R code and any specified chunk options (e.g., \code{echo}, \code{eval}). +These objects are typically processed later to generate the final R Markdown text. +} +\examples{ +my_chunk <- code_chunk("x <- 1:10", echo = TRUE, message = FALSE) +class(my_chunk) +attributes(my_chunk)$param +} diff --git a/man/conv_str_logi.Rd b/man/conv_str_logi.Rd deleted file mode 100644 index d923faa4c..000000000 --- a/man/conv_str_logi.Rd +++ /dev/null @@ -1,42 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/yaml_utils.R -\name{conv_str_logi} -\alias{conv_str_logi} -\title{Convert \code{yaml} representation of a boolean strings to logical Values} -\usage{ -conv_str_logi( - input, - name = "", - pos_logi = c("TRUE", "true", "True", "yes", "y", "Y", "on"), - neg_logi = c("FALSE", "false", "False", "no", "n", "N", "off"), - silent = TRUE -) -} -\arguments{ -\item{input}{(\code{character(1)})} - -\item{name}{(\code{charcter(1)})} - -\item{pos_logi}{(\code{character}) vector of \code{yaml} values which should be treated as \code{TRUE}.} - -\item{neg_logi}{(\code{character}) vector of \code{yaml} values which should be treated as \code{FALSE}.} - -\item{silent}{(\code{logical(1)}) if to suppress the messages and warnings.} -} -\value{ -\code{input} argument or the appropriate \code{logical} value. -} -\description{ -Converts a single \code{character} string representing a \code{yaml} boolean value into a logical value in \code{R}. -} -\examples{ -conv_str_logi <- getFromNamespace("conv_str_logi", "teal.reporter") -conv_str_logi("TRUE") -conv_str_logi("True") - -conv_str_logi("off") -conv_str_logi("n") - -conv_str_logi("sth") -} -\keyword{internal} diff --git a/man/dot-code_to_card.Rd b/man/dot-code_to_card.Rd new file mode 100644 index 000000000..2557d48c2 --- /dev/null +++ b/man/dot-code_to_card.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/teal_card.R +\name{.code_to_card} +\alias{.code_to_card} +\title{Builds \code{teal_card} from code and outputs in \code{qenv} object} +\usage{ +.code_to_card(x, code_block_opts = list()) +} +\arguments{ +\item{x}{(\code{list}) object from \code{qenv@code}.} + +\item{code_block_opts}{(\code{list}) Additional options for the R code chunk in R Markdown.} +} +\value{ +A \code{teal_card} built from the code and outputs in a \code{qenv} object. +} +\description{ +Builds a \code{teal_card} from the code and outputs of a \code{teal_data} +object, preserving the order of code execution and output display. +} +\keyword{internal} diff --git a/man/dot-convert_teal_card_input.Rd b/man/dot-convert_teal_card_input.Rd new file mode 100644 index 000000000..a7a69461e --- /dev/null +++ b/man/dot-convert_teal_card_input.Rd @@ -0,0 +1,30 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/teal_card.R +\name{.convert_teal_card_input} +\alias{.convert_teal_card_input} +\title{Internal helper for `teal_card`` input conversion} +\usage{ +.convert_teal_card_input(x) +} +\arguments{ +\item{x}{(\code{object}) An object to be converted.} +} +\value{ +The processed object, possibly converted or left unchanged. +} +\description{ +Converts input values to a format compatible with \code{teal_card}. +This function is used internally to handle common inputs, such as \code{ggplot} objects, +ensuring they are appropriately converted to evaluable output blocks that can +be saved to \code{RDS} file efficiently. +} +\details{ +This function performs the following conversions: +\itemize{ +\item \code{ggplot} objects are converted to \code{recordedplot} objects. +} + +If the R option \code{teal.reporter.disable_teal_card_conversion} is set to \code{TRUE}, +no conversion is applied. +} +\keyword{internal} diff --git a/man/download_report_button.Rd b/man/download_report_button.Rd index 515d7f322..dfa5fad4b 100644 --- a/man/download_report_button.Rd +++ b/man/download_report_button.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/DownloadModule.R +% Please edit documentation in R/download.R \name{download_report_button} \alias{download_report_button} \alias{download_report_button_ui} diff --git a/man/eval_code-teal_report.Rd b/man/eval_code-teal_report.Rd new file mode 100644 index 000000000..3e9b1dce3 --- /dev/null +++ b/man/eval_code-teal_report.Rd @@ -0,0 +1,44 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/teal_report-eval_code.R +\name{eval_code-teal_report} +\alias{eval_code-teal_report} +\alias{eval_code,teal_report-method} +\title{Evaluate code in \code{qenv}} +\usage{ +\S4method{eval_code}{teal_report}(object, code, code_block_opts = list(), ...) +} +\arguments{ +\item{object}{(\code{teal_report})} + +\item{code}{(\code{character}, \code{language} or \code{expression}) code to evaluate. +It is possible to preserve original formatting of the \code{code} by providing a \code{character} or an +\code{expression} being a result of \code{parse(keep.source = TRUE)}.} + +\item{code_block_opts}{(\code{list}) Additional options for the R code chunk in R Markdown.} + +\item{...}{(\code{\link{dots}}) additional arguments passed to future methods.} +} +\value{ +\code{teal_reporter} environment with the code evaluated and the outputs added +to the card or \code{qenv.error} if evaluation fails. +} +\description{ +Evaluate code in \code{qenv} +} +\details{ +\code{eval_code()} evaluates given code in the \code{qenv} environment and appends it to the \code{code} slot. +Thus, if the \code{qenv} had been instantiated empty, contents of the environment are always a result of the stored code. +} +\examples{ +td <- teal.data::teal_data() +td <- teal.code::eval_code(td, "iris <- iris") +tr <- as.teal_report(td) +tr <- teal.code::eval_code(tr, "a <- 1") +tr <- teal.code::eval_code(tr, "b <- 2L # with comment") +tr <- teal.code::eval_code(tr, quote(library(checkmate))) +tr <- teal.code::eval_code(tr, expression(assert_number(a))) +teal_card(tr) +} +\seealso{ +\link[teal.code]{within.qenv} +} diff --git a/man/get_yaml_field.Rd b/man/get_yaml_field.Rd deleted file mode 100644 index 4ae4ea47b..000000000 --- a/man/get_yaml_field.Rd +++ /dev/null @@ -1,22 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/yaml_utils.R -\name{get_yaml_field} -\alias{get_yaml_field} -\title{Extract field from \code{yaml} text} -\usage{ -get_yaml_field(yaml_text, field_name) -} -\arguments{ -\item{yaml_text}{(\code{rmd_yaml_header} or \code{character}) vector containing the \code{yaml} text.} - -\item{field_name}{(\code{character}) the name of the field to extract.} -} -\value{ -If the field is a list, it returns the names of elements in the list; otherwise, -it returns the extracted field. -} -\description{ -Parses \code{yaml} text, extracting the specified field. Returns list names if it's a list; -otherwise, the field itself. -} -\keyword{internal} diff --git a/man/md_header.Rd b/man/md_header.Rd deleted file mode 100644 index 54cc69460..000000000 --- a/man/md_header.Rd +++ /dev/null @@ -1,27 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/yaml_utils.R -\name{md_header} -\alias{md_header} -\title{Create \code{markdown} header from \code{yaml} string} -\usage{ -md_header(x) -} -\arguments{ -\item{x}{(\code{character}) \code{yaml} formatted string.} -} -\description{ -This function wraps a \code{yaml}-formatted string in Markdown header delimiters. -} -\examples{ -library(yaml) -yaml_quoted <- getFromNamespace("yaml_quoted", "teal.reporter") -yaml <- list( - author = yaml_quoted("NEST"), - title = yaml_quoted("Report"), - date = yaml_quoted("07/04/2019"), - output = list(pdf_document = list(keep_tex = TRUE)) -) -md_header <- getFromNamespace("md_header", "teal.reporter") -md_header(as.yaml(yaml)) -} -\keyword{internal} diff --git a/man/metadata-set.Rd b/man/metadata-set.Rd new file mode 100644 index 000000000..075652ae0 --- /dev/null +++ b/man/metadata-set.Rd @@ -0,0 +1,31 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/teal_card.R +\name{metadata<-} +\alias{metadata<-} +\alias{metadata<-.teal_card} +\alias{metadata<-.ReportCard} +\title{Set metadata for a \code{teal_card} or \code{ReportCard}} +\usage{ +metadata(object, which = NULL) <- value + +\method{metadata}{teal_card}(object, which = NULL) <- value + +\method{metadata}{ReportCard}(object, which) <- value +} +\arguments{ +\item{object}{(\code{teal_card} or \code{ReportCard}) The object to modify.} + +\item{which}{(\code{character}) The name of the metadata field to set.} + +\item{value}{The value to assign to the specified metadata field.} +} +\value{ +The modified object with updated metadata. +} +\description{ +This function allows you to set or modify metadata fields in a \code{teal_card} or \code{ReportCard} object. +It can be used to add new metadata or update existing fields. +} +\details{ +The \code{ReportCard} class only supports the \code{title} field in metadata. +} diff --git a/man/metadata.Rd b/man/metadata.Rd new file mode 100644 index 000000000..dbca1d3b5 --- /dev/null +++ b/man/metadata.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/teal_card.R +\name{metadata} +\alias{metadata} +\alias{metadata.teal_card} +\alias{metadata.ReportCard} +\title{Access metadata from a \code{teal_card} or \code{ReportCard}} +\usage{ +metadata(object, which = NULL) + +\method{metadata}{teal_card}(object, which = NULL) + +\method{metadata}{ReportCard}(object, which = NULL) +} +\arguments{ +\item{object}{(\code{teal_card} or \code{ReportCard}) The object from which to extract metadata.} + +\item{which}{(\code{character} or \code{NULL}) The name of the metadata field to extract.} +} +\value{ +A list of metadata fields or a specific field if \code{which} is provided. +} +\description{ +This function retrieves metadata from a \code{teal_card} or \code{ReportCard} object. +When \code{which} is \code{NULL}, it returns all metadata fields as a list. +} diff --git a/man/print.rmd_yaml_header.Rd b/man/print.rmd_yaml_header.Rd deleted file mode 100644 index 098d864ae..000000000 --- a/man/print.rmd_yaml_header.Rd +++ /dev/null @@ -1,25 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/yaml_utils.R -\name{print.rmd_yaml_header} -\alias{print.rmd_yaml_header} -\title{Print method for the \code{yaml_header} class} -\usage{ -\method{print}{rmd_yaml_header}(x, ...) -} -\arguments{ -\item{x}{(\code{rmd_yaml_header}) class object.} - -\item{...}{optional text.} -} -\value{ -\code{NULL}. -} -\description{ -Print method for the \code{yaml_header} class -} -\examples{ -input <- list(author = "", output = "pdf_document", toc = TRUE, keep_tex = TRUE) -out <- as_yaml_auto(input) -out -print(out) -} diff --git a/man/render.Rd b/man/render.Rd new file mode 100644 index 000000000..7e8c432a5 --- /dev/null +++ b/man/render.Rd @@ -0,0 +1,51 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/render.R +\name{render} +\alias{render} +\title{Render \code{teal_card}} +\usage{ +render( + input, + output_dir = getwd(), + global_knitr = getOption("teal.reporter.global_knitr"), + keep_rmd = TRUE, + ... +) +} +\arguments{ +\item{input}{(\code{teal_report} or \code{teal_code}) object to render.} + +\item{output_dir}{The output directory for the rendered \code{output_file}. +This allows for a choice of an alternate directory to which the output file +should be written (the default output directory of that of the input file). +If a path is provided with a filename in \code{output_file} the directory +specified here will take precedence. Please note that any directory path +provided will create any necessary directories if they do not exist.} + +\item{global_knitr}{(\code{list}) options to apply to every code chunk in a teal_card document. +\href{https://rmarkdown.rstudio.com/lesson-3.html#global-options}{Read more here}.} + +\item{keep_rmd}{(\code{logical(1)}) if \code{.Rmd} should be kept after rendering to desired \code{output_format}.} + +\item{...}{arguments passed to \code{rmarkdown::render}.} +} +\description{ +Render \code{teal_card} +} +\examples{ +report <- teal_report() +teal_card(report) <- c( + teal_card(report), + "## Document section", + "Lorem ipsum dolor sit amet" +) +report <- within(report, a <- 2) +report <- within(report, plot(a)) +metadata(teal_card(report)) <- list( + title = "My Document", + author = "NEST" +) +if (interactive()) { + render(report, output_format = rmarkdown::pdf_document(), global_knitr = list(fig.width = 10)) +} +} diff --git a/man/report_render_and_compress.Rd b/man/report_render_and_compress.Rd index e46723910..cdbd09150 100644 --- a/man/report_render_and_compress.Rd +++ b/man/report_render_and_compress.Rd @@ -1,25 +1,25 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/DownloadModule.R +% Please edit documentation in R/download.R \name{report_render_and_compress} \alias{report_render_and_compress} \title{Render the report} \usage{ report_render_and_compress( reporter, - input_list, + rmd_yaml_args, global_knitr, - file = tempdir() + file = tempfile() ) } \arguments{ \item{reporter}{(\code{Reporter}) instance.} -\item{input_list}{(\code{list}) like \code{shiny} input converted to a regular named list.} +\item{rmd_yaml_args}{(\verb{named list}) with \code{Rmd} \code{yaml} header fields and their values.} \item{global_knitr}{(\code{list}) a global \code{knitr} parameters, like echo. But if local parameter is set it will have priority.} -\item{file}{(\code{character(1)}) where to copy the returned directory.} +\item{file}{(\code{character(1)}) where to copy created zip file.} } \value{ \code{file} argument, invisibly. diff --git a/man/reporter_download_inputs.Rd b/man/reporter_download_inputs.Rd index 4b28049a6..d71200b6f 100644 --- a/man/reporter_download_inputs.Rd +++ b/man/reporter_download_inputs.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/DownloadModule.R +% Please edit documentation in R/download.R \name{reporter_download_inputs} \alias{reporter_download_inputs} \title{Get the custom list of UI inputs} diff --git a/man/reporter_previewer.Rd b/man/reporter_previewer.Rd index 6ecee143d..1c8c0e18f 100644 --- a/man/reporter_previewer.Rd +++ b/man/reporter_previewer.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/Previewer.R +% Please edit documentation in R/previewer_report.R \name{reporter_previewer} \alias{reporter_previewer} \alias{preview_report_button_ui} diff --git a/man/reporter_previewer_deprecated.Rd b/man/reporter_previewer_deprecated.Rd index fd7ef2a71..70449938b 100644 --- a/man/reporter_previewer_deprecated.Rd +++ b/man/reporter_previewer_deprecated.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/Previewer.R +% Please edit documentation in R/previewer_deprecated.R \name{reporter_previewer_deprecated} \alias{reporter_previewer_deprecated} \alias{reporter_previewer_ui} diff --git a/man/reset_report_button.Rd b/man/reset_report_button.Rd index a18b56465..0f9d0d4f1 100644 --- a/man/reset_report_button.Rd +++ b/man/reset_report_button.Rd @@ -13,7 +13,7 @@ reset_report_button_srv(id, reporter) \arguments{ \item{id}{(\code{character(1)}) \code{shiny} module instance id.} -\item{label}{(\code{character(1)}) label of the button. By default it is empty.} +\item{label}{(\code{character(1)}) label of the button. By default \code{NULL}.} \item{reporter}{(\code{Reporter}) instance.} } diff --git a/man/rmd_output_arguments.Rd b/man/rmd_output_arguments.Rd deleted file mode 100644 index 9fa33d2b9..000000000 --- a/man/rmd_output_arguments.Rd +++ /dev/null @@ -1,20 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/yaml_utils.R -\name{rmd_output_arguments} -\alias{rmd_output_arguments} -\title{Get document output arguments from the \code{rmarkdown} package} -\usage{ -rmd_output_arguments(output_name, default_values = FALSE) -} -\arguments{ -\item{output_name}{(\code{character}) \code{rmarkdown} output name.} - -\item{default_values}{(\code{logical(1)}) if to return a default values for each argument.} -} -\description{ -Retrieves the arguments for a specified document output type from the \code{rmarkdown} package. -} -\examples{ -rmd_output_arguments("pdf_document") -rmd_output_arguments("pdf_document", TRUE) -} diff --git a/man/rmd_outputs.Rd b/man/rmd_outputs.Rd deleted file mode 100644 index 8113458bb..000000000 --- a/man/rmd_outputs.Rd +++ /dev/null @@ -1,18 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/yaml_utils.R -\name{rmd_outputs} -\alias{rmd_outputs} -\title{Get document output types from the \code{rmarkdown} package} -\usage{ -rmd_outputs() -} -\value{ -\code{character} vector. -} -\description{ -Retrieves vector of available document output types from the \code{rmarkdown} package, -such as \code{pdf_document}, \code{html_document}, etc. -} -\examples{ -rmd_outputs() -} diff --git a/man/simple_reporter.Rd b/man/simple_reporter.Rd index 2ba353930..d80b9089a 100644 --- a/man/simple_reporter.Rd +++ b/man/simple_reporter.Rd @@ -25,7 +25,7 @@ simple_reporter_srv( \item{reporter}{(\code{Reporter}) instance.} \item{card_fun}{(\code{function}) which returns a \code{\link{ReportCard}} instance, -the function has a \code{card} argument and an optional \code{comment} argument.} +the function has a \code{teal_card} argument and an optional \code{comment} argument.} \item{global_knitr}{(\code{list}) a global \code{knitr} parameters for customizing the rendering process.} diff --git a/man/srv_editor_block.Rd b/man/srv_editor_block.Rd new file mode 100644 index 000000000..e73b417c1 --- /dev/null +++ b/man/srv_editor_block.Rd @@ -0,0 +1,48 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/editor_block.R +\name{ui_editor_block} +\alias{ui_editor_block} +\alias{srv_editor_block} +\title{UI and Server functions for editing report document blocks} +\usage{ +ui_editor_block(id, value, cached_html) + +srv_editor_block(id, value) +} +\arguments{ +\item{id}{(\code{character(1)}) A unique identifier for the module.} + +\item{value}{The content of the block to be edited. It can be a character string or other types.} + +\item{cached_html}{(\code{shiny.tag} or \code{shiny.tag.list}) Cached HTML content to display in the UI.} +} +\description{ +These functions provide a user interface and server logic for editing and extending +the editor functionality to support new data types. +} +\details{ +The methods for this S3 generic can be extended by the app developer to new classes +or even overwritten. +For this a function with the name \verb{srv_editor_block.} and/or \verb{ui_editor_block.} +should be defined in the Global Environment, where \verb{} is the class of +the object to be used in the method. + +For example, to override the default behavior for \code{character} class, you can use: + +\if{html}{\out{
}}\preformatted{ui_editor_block.character <- function(id, value) \{ + # custom implementation + shiny::tagList( + shiny::tags$h6(shiny::icon("pencil", class = "text-muted"), "Editable CUSTOM markdown block"), + shiny::textAreaInput(ns("content"), label = NULL, value = value, width = "100\%") + ) +\} +srv_editor_block.character <- function(id, value) \{ + # custom implementation + # ... +\} +}\if{html}{\out{
}} + +Alternatively, you can register the S3 method using +\code{registerS3method("ui_editor_block", "", fun)} and +\code{registerS3method("srv_editor_block", "", fun)}. +} diff --git a/man/teal_card.Rd b/man/teal_card.Rd new file mode 100644 index 000000000..1b95f6c3e --- /dev/null +++ b/man/teal_card.Rd @@ -0,0 +1,77 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/teal_card.R +\name{teal_card} +\alias{teal_card} +\alias{teal_card<-} +\alias{as.teal_card} +\alias{c.teal_card} +\alias{[.teal_card} +\title{\code{teal_card}: An \code{S3} class for managing \code{teal} reports} +\usage{ +teal_card(...) + +teal_card(x) <- value + +as.teal_card(x) + +\method{c}{teal_card}(...) + +\method{[}{teal_card}(x, i) +} +\arguments{ +\item{...}{Elements from which \code{teal_card} will be combined.} + +\item{x}{Object to convert to teal_card} + +\item{value}{(\code{teal_card}) object to set in the \code{teal_report}.} + +\item{i}{index specifying elements to extract or replace} +} +\value{ +An \code{S3} \code{list} of class \code{teal_card}. + +A teal_card object +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} + +The \code{teal_card} \code{S3} class provides functionality to store, manage, edit, and adjust report contents. +It enables users to create, manipulate, and serialize report-related data efficiently. + +The \code{teal_card()} function serves two purposes: +\enumerate{ +\item When called with a \code{teal_report} object, it acts as a getter and returns the card slot. +\item When called with other arguments, it creates a new \code{teal_card} object from those arguments. +} + +This function ensures that input is converted to a teal_card object. +It accepts various input types and converts them appropriately. +} +\details{ +The \code{teal_card} class supports \code{c()} and \code{x[i]} methods for combining and subsetting elements. +However, these methods only function correctly when the first element is a \code{teal_card}. +} +\examples{ +# Create a new empty card +report <- teal_card() + +# Create a card with content +report <- teal_card("## Headline", "Some text", summary(iris)) + +# Extract card from a teal_report +tr <- teal_report(teal_card = teal_card("## Title")) +doc <- teal_card(tr) + +# Add elements to the report +report <- c(report, list("## Table"), list(summary(mtcars))) + +# Subset the report to keep only the first two elements +report <- report[1:2] + +# Append new elements after the first element +report <- append(report, c(list("## Table 2"), list(summary(mtcars))), after = 1) + +# Verify that the object remains a teal_card +class(report) + +} diff --git a/man/teal_report-class.Rd b/man/teal_report-class.Rd new file mode 100644 index 000000000..67a3f5318 --- /dev/null +++ b/man/teal_report-class.Rd @@ -0,0 +1,58 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/teal_report-class.R +\docType{class} +\name{teal_report-class} +\alias{teal_report-class} +\title{Reproducible report} +\description{ +Reproducible report container class. Inherits code tracking behavior from \code{\link[teal.data:teal_data-class]{teal.data::teal_data}}. +} +\details{ +This class provides an isolated environment in which to store and process data with all code being recorded. +The environment, code, data set names, and data joining keys are stored in their respective slots. +These slots should never be accessed directly, use the provided get/set functions. + +As code is evaluated in \code{teal_data}, messages and warnings are stored in their respective slots. +If errors are raised, a \code{qenv.error} object is returned. +} +\section{Slots}{ + +\describe{ +\item{\code{.xData}}{(\code{environment}) environment containing data sets and possibly +auxiliary variables. +Access variables with \code{\link[=get]{get()}}, \code{\link{$}} or [\code{[[}]. +No setter provided. Evaluate code to add variables into \verb{@.xData}.} + +\item{\code{code}}{(\code{list} of \code{character}) representing code necessary to reproduce the contents of \code{qenv}. +Access with \code{\link[teal.code:get_code]{teal.code::get_code()}}. +No setter provided. Evaluate code to append code to the slot.} + +\item{\code{join_keys}}{(\code{join_keys}) object specifying joining keys for data sets in +\verb{@.xData}. +Access or modify with \code{\link[teal.data:join_keys]{teal.data::join_keys()}}.} + +\item{\code{verified}}{(\code{logical(1)}) flag signifying that code in \verb{@code} has been +proven to yield contents of \verb{@.xData}. +Used internally. See \code{\link[teal.data:verify]{teal.data::verify()}} for more details.} + +\item{\code{card}}{(\code{teal_card})} +}} + +\section{Code}{ + + + + +Each code element is a character representing one call. Each element is named with the random +identifier to make sure uniqueness when joining. Each element has possible attributes: +\itemize{ +\item \code{warnings} (\code{character}) the warnings output when evaluating the code element. +\item \code{messages} (\code{character}) the messages output when evaluating the code element. +\item \code{dependency} (\code{character}) names of objects that appear in this call and gets affected by this call, +separated by \verb{<-} (objects on LHS of \verb{<-} are affected by this line, and objects on RHS are affecting this line). +} + + +} + +\keyword{internal} diff --git a/man/teal_report.Rd b/man/teal_report.Rd new file mode 100644 index 000000000..9538dfb62 --- /dev/null +++ b/man/teal_report.Rd @@ -0,0 +1,46 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/teal_report-class.R +\name{teal_report} +\alias{teal_report} +\alias{as.teal_report} +\title{Comprehensive data integration function for \code{teal} applications} +\usage{ +teal_report( + ..., + teal_card = NULL, + code = character(0), + join_keys = teal.data::join_keys() +) + +as.teal_report(x) +} +\arguments{ +\item{...}{any number of objects (presumably data objects) provided as \code{name = value} pairs.} + +\item{teal_card}{(\code{teal_card}) object containing the report content.} + +\item{code}{(\code{character}, \code{language}) optional code to reproduce the datasets provided in \code{...}. +Note this code is not executed and the \code{teal_data} may not be reproducible + +Use \code{\link[teal.data:verify]{verify()}} to verify code reproducibility.} + +\item{join_keys}{(\code{join_keys} or single \code{join_key_set}) +optional object with datasets column names used for joining. +If empty then no joins between pairs of objects.} + +\item{x}{(\code{qenv} or \code{teal_data}) object to convert to \code{teal_report}.} +} +\value{ +A \code{teal_report} object. +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} + +Initializes a reportable data for \code{teal} application. +} +\examples{ +teal_report(x1 = iris, x2 = mtcars) +} +\seealso{ +\code{\link[teal.data:teal_data]{teal.data::teal_data}} +} diff --git a/man/to_rmd.Rd b/man/to_rmd.Rd new file mode 100644 index 000000000..a131d7382 --- /dev/null +++ b/man/to_rmd.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/to_rmd.R +\name{to_rmd} +\alias{to_rmd} +\title{Convert \code{ReporterCard}/\code{teal_card} content to \code{rmarkdown}} +\usage{ +to_rmd(block, ...) +} +\arguments{ +\item{block}{(\code{any}) content which can be represented in Rmarkdown syntax.} +} +\value{ +\code{character(1)} containing a content or Rmarkdown document. +} +\description{ +This is an S3 generic that is used to generate content in \code{rmarkdown} format +from various types of blocks in a \code{ReporterCard} or \code{teal_card} object. +} +\section{Customise \code{to_rmd}}{ +The methods for this S3 generic can be extended by the app developer or even overwritten. +For this a function with the name \verb{to_rmd.} should be defined in the +Global Environment, where \verb{} is the class of the object to be converted. + +For example, to override the default behavior for \code{code_chunk} class, you can use: + +\if{html}{\out{
}}\preformatted{to_rmd.code_chunk <- function(block, ..., output_format) \{ + # custom implementation + sprintf("### A custom code chunk\\n\\n```\{r\}\\n\%s\\n```\\n", block) +\} +}\if{html}{\out{
}} + +Alternatively, you can register the S3 method using \code{registerS3method("to_rmd", "", fun)} +} + +\keyword{internal} diff --git a/man/yaml_quoted.Rd b/man/yaml_quoted.Rd deleted file mode 100644 index 1dab5fded..000000000 --- a/man/yaml_quoted.Rd +++ /dev/null @@ -1,27 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/yaml_utils.R -\name{yaml_quoted} -\alias{yaml_quoted} -\title{Mark strings for quotation in \code{yaml} serialization} -\usage{ -yaml_quoted(x) -} -\arguments{ -\item{x}{(\code{character})} -} -\description{ -This function is designed for use with the \code{yaml} package to explicitly, -It adds an attribute to character strings, indicating that they should be serialized with double quotes. -} -\examples{ -library(yaml) -yaml_quoted <- getFromNamespace("yaml_quoted", "teal.reporter") -yaml <- list( - author = yaml_quoted("NEST"), - title = yaml_quoted("Report"), - date = yaml_quoted("07/04/2019"), - output = list(pdf_document = list(keep_tex = TRUE)) -) -as.yaml(yaml) -} -\keyword{internal} diff --git a/tests/testthat/helper-Reporter.R b/tests/testthat/helper-Reporter.R new file mode 100644 index 000000000..d3d9c9641 --- /dev/null +++ b/tests/testthat/helper-Reporter.R @@ -0,0 +1,66 @@ +# @param card is the title of the card. Used instead of "title" for compatibility +# with add_card_button_srv +test_card1 <- function(card = NULL) { + testthat::skip_if_not_installed("ggplot2") + plot <- ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + + ggplot2::geom_histogram(binwidth = 0.2) + new_card <- teal_card("## Header 2 text", "A paragraph of default text", plot) + metadata(new_card, "title") <- card + new_card +} + +# @param card is the title of the card. Used instead of "title" for compatibility +# with add_card_button_srv +test_card2 <- local({ + fun <- function(card = NULL) { + lyt <- rtables::analyze(rtables::split_rows_by(rtables::basic_table(), "Day"), "Ozone", afun = mean) + table_res2 <- rtables::build_table(lyt, within(airquality, Day <- factor(Day))) # nolint: object_name. + new_card <- teal_card("## Header 2 text", "A paragraph of default text", table_res2, iris) + metadata(new_card, "title") <- card + new_card + } + cache <- list() + function(card = NULL) { + title_ix <- card %||% "no_title" # mock index for no title + if (is.null(cache[[title_ix]])) cache[[title_ix]] <<- fun(card) + cache[[title_ix]] + } +}) + +test_card1.ReportCard <- function(card = NULL) { # nolint: object_name. + template <- test_card1(card) + new_card <- ReportCard$new() + + metadata(new_card, "title") <- metadata(template, "title") + new_card$append_text(gsub("^#+ ", "", template[[1]]), "header2") + new_card$append_text(template[[2]]) + new_card$append_plot(template[[3]]) + new_card +} + +test_card2.ReportCard <- function(card = NULL) { # nolint: object_name. + template <- test_card2(card) + new_card <- ReportCard$new() + + metadata(new_card, "title") <- metadata(template, "title") + new_card$append_text(gsub("^#+ ", "", template[[1]]), "header2") + new_card$append_text(template[[2]]) + new_card$append_table(template[[3]]) + new_card$append_table(template[[4]]) + new_card +} + +test_reporter.ReportCard <- function(card1 = test_card1.ReportCard(), # nolint: object_name. + card2 = test_card2.ReportCard(), ...) { # nolint: object_name. + new_cards <- append(list(card1, card2), list(...)) + reporter <- Reporter$new() + reporter$append_cards(new_cards) + reporter +} + +test_reporter <- function(card1 = test_card1(), card2 = test_card2(), ...) { + new_cards <- append(list(card1, card2), list(...)) + reporter <- Reporter$new() + reporter$append_cards(new_cards) + reporter +} diff --git a/tests/testthat/helper-waldo_compare.R b/tests/testthat/helper-waldo_compare.R new file mode 100644 index 000000000..d41dc065d --- /dev/null +++ b/tests/testthat/helper-waldo_compare.R @@ -0,0 +1,30 @@ +# Register the `compare_proxy` method for the `Reporter` class only for use in +# testthat. +if (requireNamespace("waldo", quietly = TRUE)) { + registerS3method( + "compare_proxy", + "Reporter", + function(x, path = "x") { + list( + object = list( + "get_cards()" = unname(x$get_cards()), + "get_metadata()" = x$get_metadata(), + "get_id()" = x$get_id(), + "get_template()" = x$get_template() + ), + path = path + ) + }, + envir = asNamespace("waldo") + ) + + registerS3method( + "compare_proxy", + "teal_card", + function(x, path = "x") { + metadata(x) <- metadata(x) # ensure verbose output + list(object = x, path = path) + }, + envir = asNamespace("waldo") + ) +} diff --git a/tests/testthat/helpers-previewer-shinytest2.R b/tests/testthat/helpers-previewer-shinytest2.R new file mode 100644 index 000000000..9200f8dec --- /dev/null +++ b/tests/testthat/helpers-previewer-shinytest2.R @@ -0,0 +1,62 @@ +create_test_reporter <- function(n_cards = 2) { + cards <- lapply(seq_len(n_cards), function(i) { + new_doc <- teal_card(sprintf("Card %d", i)) + metadata(new_doc, "title") <- sprintf("Card %d Title", i) + new_doc + }) + + reporter <- Reporter$new() + reporter$append_cards(cards) + reporter +} + +start_reporter_preview_app <- function(name) { + skip_if_too_deep(5) + skip_if_not(requireNamespace("chromote", quietly = TRUE), "chromote is not available") + + reporter <- create_test_reporter(2) + + # suppressWarnings is necessary to avoid warning "'package:teal.reporter' may not be available when loading" + testapp <- shiny::shinyApp( + ui = shiny::fluidPage( + shinyjs::useShinyjs(), + reporter_previewer_ui("preview") + ), + server = function(input, output, session) { + reporter_previewer_srv( + "preview", + reporter = reporter, + rmd_output = c("html" = "html_document"), + rmd_yaml_args = list( + author = "TEST", + title = "Test Report", + date = as.character(Sys.Date()), + output = "html_document", + toc = FALSE + ) + ) + } + ) + + app <- tryCatch( + suppressWarnings( + shinytest2::AppDriver$new( + testapp, + name = name, + options = list( + chromePath = NULL, + windowSize = c(1000, 800), + browserOptions = list(position = NULL, debug = FALSE) + ), + seed = 123, + timeout = default_idle_timeout + ) + ), + error = function(e) skip(paste("Could not initialize AppDriver:", e$message)) + ) + + withr::defer_parent(try(app$stop(), silent = TRUE)) + + app$wait_for_idle() + app +} diff --git a/tests/testthat/helpers-testing-depth.R b/tests/testthat/helpers-testing-depth.R new file mode 100644 index 000000000..99e129598 --- /dev/null +++ b/tests/testthat/helpers-testing-depth.R @@ -0,0 +1,51 @@ +#' Returns testing depth set by session option or by environmental variable. +#' +#' @details Looks for the session option `TESTING_DEPTH` first. +#' If not set, takes the system environmental variable `TESTING_DEPTH`. +#' If neither is set, then returns 3 by default. +#' If the value of `TESTING_DEPTH` is not a numeric of length 1, then returns 3. +#' +#' @return `numeric(1)` the testing depth. +#' +get_testing_depth <- function() { + default_depth <- 3 + depth <- getOption("TESTING_DEPTH", Sys.getenv("TESTING_DEPTH", default_depth)) + depth <- tryCatch( + as.numeric(depth), + error = function(error) default_depth, + warning = function(warning) default_depth + ) + if (length(depth) != 1) depth <- default_depth + depth +} + +#' Skipping tests in the testthat pipeline under specific scope +#' @description This function should be used per each `testthat::test_that` call. +#' Each of the call should specify an appropriate depth value. +#' The depth value will set the appropriate scope so more/less time consuming tests could be recognized. +#' The environment variable `TESTING_DEPTH` is used for changing the scope of `testthat` pipeline. +#' `TESTING_DEPTH` interpretation for each possible value: +#' \itemize{ +#' \item{0}{no tests at all} +#' \item{1}{fast - small scope - executed on every commit} +#' \item{3}{medium - medium scope - daily integration pipeline} +#' \item{5}{slow - all tests - daily package tests} +#' } +#' @param depth `numeric` the depth of the testing evaluation, +#' has opposite interpretation to environment variable `TESTING_DEPTH`. +#' So e.g. `0` means run it always and `5` means a heavy test which should be run rarely. +#' If the `depth` argument is larger than `TESTING_DEPTH` then the test is skipped. +#' @importFrom testthat skip +#' @return `NULL` or invoke an error produced by `testthat::skip` +#' @note By default `TESTING_DEPTH` is equal to 3 if there is no environment variable for it. +#' By default `depth` argument lower or equal to 3 will not be skipped because by default `TESTING_DEPTH` +#' is equal to 3. To skip <= 3 depth tests then the environment variable has to be lower than 3 respectively. +skip_if_too_deep <- function(depth) { # nolintr + checkmate::assert_numeric(depth, len = 1, lower = 0, upper = 5) + testing_depth <- get_testing_depth() # by default 3 if there are no env variable + if (testing_depth < depth) { + testthat::skip(paste("testing depth", testing_depth, "is below current testing specification", depth)) + } +} + +default_idle_timeout <- 20000 diff --git a/tests/testthat/test-ContentBlock.R b/tests/testthat/test-ContentBlock.R deleted file mode 100644 index 0db7e19f2..000000000 --- a/tests/testthat/test-ContentBlock.R +++ /dev/null @@ -1,75 +0,0 @@ -testthat::test_that("ContentBlock object can be created", { - testthat::expect_no_error(ContentBlock$new()) -}) - -testthat::test_that("new returns an object of type ContentBlock", { - testthat::expect_true(inherits(ContentBlock$new(), "ContentBlock")) -}) - -testthat::test_that("set_content accepts a character object", { - block <- ContentBlock$new() - testthat::expect_no_error(block$set_content("test")) -}) - -testthat::test_that("set_content accepts a list object", { - block <- ContentBlock$new() - testthat::expect_no_error(block$set_content(list("a"))) -}) - -testthat::test_that("set_content returns the ContentBlock object", { - block <- ContentBlock$new() - testthat::expect_identical(block$set_content("test"), block) -}) - -testthat::test_that("get_content returns NULL on a newly initialized ContentBlock", { - testthat::expect_equal(ContentBlock$new()$get_content(), NULL) -}) - -testthat::test_that("The deep copy constructor copies the content file to a new file", { - original_file <- tempfile() - writeLines("Test content", con = original_file) - content_block <- ContentBlock$new()$set_content(original_file) - content_block_copy <- content_block$clone(deep = TRUE) - - testthat::expect_true(original_file != content_block_copy$get_content()) -}) - -testthat::test_that("The deep copy constructor preserves the file extension of the copied file", { - original_file <- tempfile(fileext = ".test_extension") - writeLines("Test content", con = original_file) - content_block <- ContentBlock$new()$set_content(original_file) - content_block_copy <- content_block$clone(deep = TRUE) - split <- strsplit(basename(original_file), split = "\\.") - copied_file_extension <- split[[1]][length(split[[1]])] - - testthat::expect_equal(copied_file_extension, "test_extension") -}) - -testthat::test_that("The deep copy constructor does not find an extension of a file name like .gitignore", { - original_file <- file.path(tempdir(), ".test") - writeLines("Test content", con = original_file) - content_block <- ContentBlock$new()$set_content(original_file) - content_block_copy <- content_block$clone(deep = TRUE) - - testthat::expect_false(grepl(".", basename(content_block_copy$get_content()), fixed = TRUE)) -}) - -testthat::test_that("The deep copy constructor finds an extension of a file name like .gitignore.txt", { - original_file <- file.path(tempdir(), ".test.test_extension") - writeLines("Test content", con = original_file) - content_block <- ContentBlock$new()$set_content(original_file) - content_block_copy <- content_block$clone(deep = TRUE) - split <- strsplit(basename(original_file), split = "\\.") - copied_file_extension <- split[[1]][length(split[[1]])] - - testthat::expect_equal(copied_file_extension, "test_extension") -}) - -testthat::test_that("The shallow copy constructor does not copy the content file to a new file", { - original_file <- tempfile() - writeLines("Test content", con = original_file) - content_block <- ContentBlock$new()$set_content(original_file) - content_block_copy <- content_block$clone(deep = FALSE) - - testthat::expect_true(original_file == content_block_copy$get_content()) -}) diff --git a/tests/testthat/test-DownloadReportModule.R b/tests/testthat/test-DownloadReportModule.R index 857b9a1b1..5c6d5b07e 100644 --- a/tests/testthat/test-DownloadReportModule.R +++ b/tests/testthat/test-DownloadReportModule.R @@ -1,17 +1,7 @@ -testthat::skip_if_not_installed("ggplot2") - -card1 <- ReportCard$new() -card1$append_text("Header 2 text", "header2") -card1$append_text("A paragraph of default text", "header2") -card1$append_plot( - ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + - ggplot2::geom_histogram() -) - -reporter <- Reporter$new() -reporter$append_cards(list(card1)) - testthat::test_that("download_report_button_srv - render and downlaod a document", { + reporter <- Reporter$new() + reporter$append_cards(list(test_card1.ReportCard())) + shiny::testServer( download_report_button_srv, args = list(reporter = reporter), @@ -58,6 +48,9 @@ testthat::test_that("download_report_button_srv - subset of rmd_yaml_args", { wrong3 = list() ) + reporter <- Reporter$new() + reporter$append_cards(list(test_card1.ReportCard())) + for (iset in seq_along(rmd_yaml_args_correct)) { testthat::expect_silent( shiny::testServer( @@ -74,50 +67,29 @@ testthat::test_that("download_report_button_srv - subset of rmd_yaml_args", { shiny::testServer( download_report_button_srv, args = list(reporter = reporter, rmd_yaml_args = rmd_yaml_args_wrong[[iset]]), - expr = { - } + expr = {} ), "Assertion" ) } }) -card1 <- ReportCard$new() -card1$append_text("Header 2 text", "header2") -card1$append_text("A paragraph of default text", "header2") -card1$append_plot( - ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + - ggplot2::geom_histogram() -) - -reporter <- Reporter$new() -reporter$append_cards(list(card1)) - testthat::test_that("download_report_button_ui - returns a tagList", { - testthat::expect_true( - inherits(download_report_button_ui("sth"), c("shiny.tag.list", "list")) - ) + checkmate::expect_multi_class(download_report_button_ui("sth"), c("shiny.tag.list", "shiny.tag")) }) -card1 <- ReportCard$new() -card1$append_text("Header 2 text", "header2") -card1$append_text("A paragraph of default text", "header2") -card1$append_plot( - ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + - ggplot2::geom_histogram() -) - -reporter <- Reporter$new() -reporter$append_cards(list(card1)) -input <- list(author = "NEST", title = "Report", output = "html_document") -knitr_args <- list() -temp_dir <- tempdir() - testthat::test_that("report_render_and_compress - valid arguments", { - testthat::expect_no_error(report_render_and_compress(reporter, input, knitr_args, temp_dir)) + reporter <- Reporter$new() + reporter$append_cards(list(test_card1.ReportCard())) + input <- list(author = "NEST", title = "Report", output = "html_document") + testthat::expect_no_error(report_render_and_compress(reporter, input, list(), withr::local_tempdir())) }) testthat::test_that("report_render_and_compress - invalid arguments", { + input <- list(author = "NEST", title = "Report", output = "html_document") + temp_zip_file <- withr::local_tempfile(pattern = "report_", fileext = ".zip") + reporter <- Reporter$new() + reporter$append_cards(list(test_card1.ReportCard())) testthat::expect_error(report_render_and_compress(reporter, list(), list(), temp_zip)) testthat::expect_error(report_render_and_compress(reporter, input, list(), 2)) testthat::expect_error(report_render_and_compress(reporter, list, list(), "")) @@ -125,10 +97,12 @@ testthat::test_that("report_render_and_compress - invalid arguments", { testthat::test_that("report_render_and_compress - render an html document", { input <- list(author = "NEST", title = "Report", output = "html_document", toc = FALSE) - temp_dir <- tempdir() - knitr_args <- list() - res_path <- report_render_and_compress(reporter, input, knitr_args, temp_dir) + reporter <- Reporter$new() + reporter$append_cards(list(test_card1.ReportCard())) + temp_dir <- withr::local_tempdir() + res_path <- report_render_and_compress(reporter, input, list(), temp_dir) testthat::expect_identical(res_path, temp_dir) + withr::with_dir(res_path, zip::unzip(list.files(pattern = "[.]zip$")[[1]])) # Unzip compressed files files <- list.files(temp_dir, recursive = TRUE) testthat::expect_true(any(grepl("[.]Rmd", files))) testthat::expect_true(any(grepl("[.]html", files))) @@ -136,6 +110,8 @@ testthat::test_that("report_render_and_compress - render an html document", { }) testthat::test_that("any_rcode_block", { + reporter <- Reporter$new() + reporter$append_cards(list(test_card1.ReportCard())) testthat::expect_false(any_rcode_block(reporter)) card_t <- ReportCard$new() card_t$append_text("Header 2 text", "header2") diff --git a/tests/testthat/test-FileBlock.R b/tests/testthat/test-FileBlock.R deleted file mode 100644 index 24b07b65e..000000000 --- a/tests/testthat/test-FileBlock.R +++ /dev/null @@ -1,62 +0,0 @@ -testthat::test_that("FileBlock object can be created", { - testthat::expect_no_error(FileBlock$new()) -}) - -testthat::test_that("new returns an object of type FileBlock", { - testthat::expect_true(inherits(FileBlock$new(), "FileBlock")) -}) - -testthat::test_that("destructor removes the file", { - temp_file <- tempfile(fileext = ".png") - file.create(temp_file) - testthat::expect_true(file.exists(temp_file)) - block <- FileBlock$new()$set_content(temp_file) - rm(block) - gc() - testthat::expect_false(file.exists(temp_file)) -}) - -testthat::test_that("to_list returns a named list with a one field", { - block <- FileBlock$new() - temp_dir <- tempdir() - testthat::expect_equal(block$to_list(temp_dir), list(basename = character(0))) -}) - -testthat::test_that("to_list with base_path arg", { - block <- TableBlock$new() - testthat::expect_identical( - block$to_list(dirname(block$get_content())), - list(basename = character(0)) - ) -}) - -testthat::test_that("to_list copies a file to a target directory", { - temp_dir_name <- file.path(tempdir(), "test") - dir.create(temp_dir_name) - temp_file <- tempfile(fileext = ".png") - file.create(temp_file) - block <- FileBlock$new()$set_content(temp_file) - block$to_list(temp_dir_name) - - testthat::expect_true(file.exists(file.path(temp_dir_name, basename(block$get_content())))) - - unlink(temp_dir_name, recursive = TRUE) - unlink(temp_file) -}) - -testthat::test_that("from_list copies a file from a target directory", { - temp_dir_name <- file.path(tempdir(), "test") - dir.create(temp_dir_name) - - temp_file <- tempfile(fileext = ".rds") - file.create(temp_file) - - block <- FileBlock$new()$set_content(temp_file) - file.copy(block$get_content(), file.path(temp_dir_name, basename(block$get_content()))) - - new_block <- block$from_list(list(basename = basename(block$get_content())), temp_dir_name) - testthat::expect_true(file.exists(new_block$get_content())) - - unlink(temp_dir_name, recursive = TRUE) - unlink(temp_file) -}) diff --git a/tests/testthat/test-HTMLBlock.R b/tests/testthat/test-HTMLBlock.R deleted file mode 100644 index 8ec130444..000000000 --- a/tests/testthat/test-HTMLBlock.R +++ /dev/null @@ -1,40 +0,0 @@ -testthat::test_that("HTMLBlock object can be created", { - testthat::expect_no_error(HTMLBlock$new()) -}) - -testthat::test_that("new returns an object of type HTMLBlock", { - testthat::expect_true(inherits(HTMLBlock$new(), "HTMLBlock")) -}) - - -testthat::test_that("new accepts a shiny.tag", { - testthat::expect_no_error(HTMLBlock$new(shiny::tags$div())) -}) - -testthat::test_that("new accepts a shiny.tag.list", { - testthat::expect_no_error(HTMLBlock$new(shiny::tagList())) -}) - -testthat::test_that("new doesn't accept character", { - testthat::expect_error(HTMLBlock$new("test"), "'shiny.tag'/'shiny.tag.list'") -}) - -testthat::test_that("get_content returns a html content asis", { - content <- shiny::tags$div() - obj <- HTMLBlock$new(content) - testthat::expect_identical(obj$get_content(), content) -}) - -testthat::test_that("to_list returns a list containing a content (asis)", { - content <- shiny::tags$div() - obj <- HTMLBlock$new(content) - out <- obj$to_list() - testthat::expect_identical(out, list(content = content)) -}) - -testthat::test_that("from_list creates a HTMLBlock", { - list <- list(content = shiny::tags$div()) - obj <- HTMLBlock$new() - obj$from_list(list) - testthat::expect_identical(obj$get_content(), list$content) -}) diff --git a/tests/testthat/test-LoadReporterModule.R b/tests/testthat/test-LoadReporterModule.R index 281ff97b1..08397d6f1 100644 --- a/tests/testthat/test-LoadReporterModule.R +++ b/tests/testthat/test-LoadReporterModule.R @@ -1,23 +1,55 @@ testthat::test_that("report_load_srv - loading reporter restores saved content", { testthat::skip_if_not_installed("ggplot2") - reporter <- Reporter$new() - reporter$set_id("xyz") - card <- teal.reporter::ReportCard$new() + card <- teal.reporter::teal_card( + "## Header 2 text", + "A paragraph of default text", + ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + + ggplot2::geom_histogram(binwidth = 0.2) + ) + + reporter <- Reporter$new()$set_id("xyz") + reporter$append_cards(list(card)) + reporter_path <- reporter$to_jsondir(withr::local_tempdir()) + + temp_zip_file <- tempfile(pattern = "report_", fileext = ".zip") + zip::zipr(temp_zip_file, reporter_path) + shiny::testServer( + report_load_srv, + args = list(reporter = reporter), + expr = { + reporter$reset() + session$setInputs(`reporter_load` = 0) + session$setInputs( + archiver_zip = list(datapath = temp_zip_file, name = basename(temp_zip_file)) + ) + session$setInputs(`reporter_load_main` = 0) + testthat::expect_length(reporter$get_cards(), 1) + testthat::expect_length(reporter$get_blocks(), 4) + + testthat::expect_match(reporter$get_blocks()[[1]], "# .*") # Title is added automatically + testthat::expect_identical(reporter$get_blocks()[[2]], "## Header 2 text") + testthat::expect_identical(reporter$get_blocks()[[3]], "A paragraph of default text") + testthat::expect_s3_class(reporter$get_blocks()[[4]], "ggplot") + } + ) +}) + +testthat::test_that("report_load_srv - loading reporter with ReportCard restores saved content (with old blocks)", { + testthat::skip_if_not_installed("ggplot2") + + card <- teal.reporter::ReportCard$new() card$append_text("Header 2 text", "header2") - card$append_text("A paragraph of default text", "header2") + card$append_text("A paragraph of default text", "header3") card$append_plot( ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + - ggplot2::geom_histogram() + ggplot2::geom_histogram(binwidth = 0.2) ) - reporter$append_cards(list(card)) - - temp_dir <- file.path(tempdir(), "tempdir") - suppressWarnings(dir.create(temp_dir)) - unlink(list.files(temp_dir, recursive = TRUE, full.names = TRUE)) - reporter_path <- reporter$to_jsondir(temp_dir) + reporter <- Reporter$new()$set_id("xyz") + reporter$append_cards(list(card)) + reporter_path <- reporter$to_jsondir(withr::local_tempdir()) temp_zip_file <- tempfile(pattern = "report_", fileext = ".zip") zip::zipr(temp_zip_file, reporter_path) @@ -29,19 +61,16 @@ testthat::test_that("report_load_srv - loading reporter restores saved content", reporter$reset() session$setInputs(`reporter_load` = 0) session$setInputs( - archiver_zip = list( - datapath = temp_zip_file, - name = basename(temp_zip_file) - ) + archiver_zip = list(datapath = temp_zip_file, name = basename(temp_zip_file)) ) session$setInputs(`reporter_load_main` = 0) testthat::expect_length(reporter$get_cards(), 1) - testthat::expect_length(reporter$get_blocks(), 3) - testthat::expect_s3_class(reporter$get_blocks()[[1]], "TextBlock") - testthat::expect_identical(reporter$get_blocks()[[1]]$get_content(), "Header 2 text") - testthat::expect_s3_class(reporter$get_blocks()[[2]], "TextBlock") - testthat::expect_identical(reporter$get_blocks()[[2]]$get_content(), "A paragraph of default text") - testthat::expect_s3_class(reporter$get_blocks()[[3]], "PictureBlock") + testthat::expect_length(reporter$get_blocks(), 4) + testthat::expect_type(reporter$get_blocks()[[2]], "character") + testthat::expect_identical(reporter$get_blocks()[[2]], "## Header 2 text") + testthat::expect_type(reporter$get_blocks()[[3]], "character") + testthat::expect_identical(reporter$get_blocks()[[3]], "### A paragraph of default text") + testthat::expect_s3_class(reporter$get_blocks()[[4]], "ggplot") } ) }) @@ -50,13 +79,8 @@ testthat::test_that("report_load_srv - fail to load a reporter because of differ reporter <- Reporter$new() reporter$set_id("xyz") - temp_dir <- file.path(tempdir(), "tempdir") - suppressWarnings(dir.create(temp_dir)) - unlink(list.files(temp_dir, recursive = TRUE, full.names = TRUE)) - - reporter_path <- reporter$to_jsondir(temp_dir) - - temp_zip_file <- tempfile(pattern = "report_", fileext = ".zip") + reporter_path <- reporter$to_jsondir(withr::local_tempdir()) + temp_zip_file <- withr::local_tempfile(pattern = "report_", fileext = ".zip") zip::zipr(temp_zip_file, reporter_path) reporter <- Reporter$new()$set_id("different") @@ -79,7 +103,6 @@ testthat::test_that("report_load_srv - fail to load a reporter because of differ testthat::expect_true(grepl("Loaded Report id has to match the current instance one", oo)) }) - testthat::test_that("report_load_ui - returns a tagList", { - testthat::expect_s3_class(report_load_ui("sth"), c("shiny.tag.list", "list")) + checkmate::expect_multi_class(report_load_ui("sth"), c("shiny.tag.list", "shiny.tag")) }) diff --git a/tests/testthat/test-NewpageBlock.R b/tests/testthat/test-NewpageBlock.R deleted file mode 100644 index b739ff8f3..000000000 --- a/tests/testthat/test-NewpageBlock.R +++ /dev/null @@ -1,12 +0,0 @@ -testthat::test_that("NewpageBlock object can be created", { - testthat::expect_no_error(NewpageBlock$new()) -}) - -testthat::test_that("new returns an object of type NewpageBlock", { - testthat::expect_true(inherits(NewpageBlock$new(), "NewpageBlock")) -}) - -testthat::test_that("set_content accepts a string", { - block <- NewpageBlock$new() - testthat::expect_no_error(block$get_content()) -}) diff --git a/tests/testthat/test-PictureBlock.R b/tests/testthat/test-PictureBlock.R deleted file mode 100644 index 1c2647744..000000000 --- a/tests/testthat/test-PictureBlock.R +++ /dev/null @@ -1,187 +0,0 @@ -# Constructor -testthat::test_that("PictureBlock object can be created", { - testthat::expect_no_error( - PictureBlock$new() - ) -}) - -testthat::test_that("new returns an object of type PictureBlock", { - testthat::expect_true(inherits(PictureBlock$new(), "PictureBlock")) -}) - -# set_content -testthat::test_that("set_content accepts a plot object", { - testthat::skip_if_not_installed("ggplot2") - - block <- PictureBlock$new() - testthat::expect_no_error( - block$set_content(ggplot2::ggplot(iris)) - ) -}) - -testthat::test_that("set_content asserts the argument is a plot", { - block <- PictureBlock$new() - testthat::expect_error( - block$set_content(7), - regexp = "Must inherit from class 'ggplot" - ) -}) - -testthat::test_that("set_content returns the PictureBlock object", { - testthat::skip_if_not_installed("ggplot2") - - block <- PictureBlock$new() - testthat::expect_identical( - block$set_content(ggplot2::ggplot(iris)), - block - ) -}) - -testthat::test_that("set_content catches a file with the 600x800 size", { - testthat::skip_if_not_installed("ggplot2") - - block <- PictureBlock$new() - testthat::expect_equal( - dim(png::readPNG(block$set_content(ggplot2::ggplot(iris))$get_content()))[c(1, 2)], - c(600L, 800L) - ) -}) - -testthat::test_that("set_content catches a file with a custom size", { - testthat::skip_if_not_installed("ggplot2") - - block <- PictureBlock$new() - testthat::expect_equal( - dim(png::readPNG(block$set_dim(c(1000L, 100L))$set_content(ggplot2::ggplot(iris))$get_content()))[c(1, 2)], - c(100L, 1000L) - ) -}) - -# get_content -testthat::test_that("get_content returns character(0) on a newly initialized PictureBlock", { - testthat::expect_equal( - PictureBlock$new()$get_content(), - character(0) - ) -}) - -# set_title -testthat::test_that("set_title accepts a string", { - testthat::expect_no_error( - PictureBlock$new()$set_title("Test") - ) -}) - - -testthat::test_that("set_title asserts the argument is string", { - testthat::expect_error( - PictureBlock$new()$set_title(8), - regexp = "Must be of type 'string'" - ) -}) - -testthat::test_that("set_title returns self", { - picture_block <- PictureBlock$new() - testthat::expect_identical( - picture_block$set_title("test"), - picture_block - ) -}) - -# get_title -testthat::test_that("get_title returns the set title", { - picture_block <- PictureBlock$new() - picture_block$set_title("test") - testthat::expect_equal( - picture_block$get_title(), - "test" - ) - - picture_block$set_title("New title") - testthat::expect_equal( - picture_block$get_title(), - "New title" - ) -}) - -# set_dim -testthat::test_that("set_dim accepts an array of two numeric values", { - testthat::expect_no_error( - PictureBlock$new()$set_dim(c(0, 0)) - ) -}) - -testthat::test_that("set_dim asserts the argument is an array of two numeric values", { - testthat::expect_error( - PictureBlock$new()$set_dim("test"), - regexp = "Must be of type 'numeric'" - ) - testthat::expect_error( - PictureBlock$new()$set_dim(c(8, 1, 1)), - regexp = "Must have length 2" - ) -}) - -testthat::test_that("set_dim returns self", { - picture_block <- PictureBlock$new() - testthat::expect_identical(picture_block$set_dim(c(0, 0)), picture_block) -}) - -# set_content -testthat::test_that("set_content raises error if the content is not of the supported type", { - testthat::expect_error( - PictureBlock$new()$set_content("unsupported content"), - regexp = "Must inherit from class 'ggplot'/'grob'/'trellis'" - ) -}) - -testthat::test_that("set_content accepts a `ggplot` object", { - testthat::skip_if_not_installed("ggplot2") - - testthat::expect_no_error( - PictureBlock$new()$set_content(ggplot2::ggplot(iris)) - ) -}) - -testthat::test_that("set_content accepts a `grob` object", { - testthat::skip_if_not_installed("ggplot2") - - testthat::expect_no_error( - PictureBlock$new()$set_content(ggplot2::ggplotGrob(ggplot2::ggplot(iris))) - ) -}) - -testthat::test_that("set_content accepts a `trellis` object", { - testthat::skip_if_not_installed("lattice") - - testthat::expect_no_error( - PictureBlock$new()$set_content(lattice::bwplot(1)) - ) -}) - -# to_list -testthat::test_that("to_list returns a named list with a one field, a proper path", { - testthat::skip_if_not_installed("ggplot2") - - pblock <- PictureBlock$new()$set_content(ggplot2::ggplot(iris)) - temp_dir <- tempdir() - testthat::expect_identical( - pblock$to_list(temp_dir), - list(basename = basename(pblock$get_content())) - ) -}) - -# from_list -testthat::test_that("from_list after to_list to save and retrive", { - testthat::skip_if_not_installed("ggplot2") - - pblock <- PictureBlock$new()$set_content(ggplot2::ggplot(iris)) - temp_dir <- tempdir() - testthat::expect_identical( - file.size(PictureBlock$new()$from_list( - pblock$to_list(temp_dir), - dirname(pblock$get_content()) - )$get_content()), - file.size(pblock$get_content()) - ) -}) diff --git a/tests/testthat/test-PreviewerReportModule-shinytest2.R b/tests/testthat/test-PreviewerReportModule-shinytest2.R new file mode 100644 index 000000000..f56b96fed --- /dev/null +++ b/tests/testthat/test-PreviewerReportModule-shinytest2.R @@ -0,0 +1,35 @@ +testthat::describe("reporter_previewer", { + # Sortable raw object is printed in DOM. Upstream ticket: https://github.com/rstudio/sortable/issues/123 + it("card removal works", { + app <- start_reporter_preview_app("reporter_previewer_remove") + + initial_count <- length(app$get_values()$export[["preview-cards"]]) + + remove_card_id <- sprintf( + "preview-cards-%s-actions-remove_action", + names(app$get_values()$export[["preview-cards"]])[[1]] + ) + + app$click(remove_card_id) + app$wait_for_idle() + testthat::expect_equal(length(app$get_values()$export[["preview-cards"]]), initial_count - 1) + }) + + it("card editing modal is being shown", { + app <- start_reporter_preview_app("reporter_previewer_edit") + + edit_card_id <- sprintf( + "preview-cards-%s-actions-edit_action", + names(app$get_values()$export[["preview-cards"]])[[1]] + ) + + app$click(edit_card_id) + app$wait_for_idle() + + modal_visible <- app$get_js(" + !!document.querySelector('.modal.show') && + document.querySelector('.modal-title').textContent.includes('Editing') + ") + testthat::expect_true(modal_visible) + }) +}) diff --git a/tests/testthat/test-PreviewerReportModule.R b/tests/testthat/test-PreviewerReportModule.R index 3aedd2e5c..9eb063ac6 100644 --- a/tests/testthat/test-PreviewerReportModule.R +++ b/tests/testthat/test-PreviewerReportModule.R @@ -4,8 +4,9 @@ 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() + ggplot2::geom_histogram(binwidth = 0.2) ) +card1$set_name("card1") reporter <- Reporter$new() reporter$append_cards(list(card1)) @@ -35,8 +36,7 @@ testthat::test_that("reporter_previewer_srv - subset of rmd_yaml_args", { shiny::testServer( reporter_previewer_srv, args = list(reporter = reporter, rmd_yaml_args = rmd_yaml_args_correct[[iset]]), - expr = { - } + expr = {} ) ) } @@ -46,25 +46,53 @@ testthat::test_that("reporter_previewer_srv - subset of rmd_yaml_args", { shiny::testServer( reporter_previewer_srv, args = list(reporter = reporter, rmd_yaml_args = rmd_yaml_args_wrong[[iset]]), - expr = { - } + expr = {} ), "Assertion" ) } }) +testthat::test_that("reporter_previewer_ui - returns a shiny tag list", { + ui <- reporter_previewer_ui("sth") + testthat::expect_true(inherits(ui, "shiny.tag.list")) +}) -card2 <- ReportCard$new() -card2$append_text("Header 2 text 2", "header2") -card2$append_text("A paragraph of default text 2", "header2") -card2$append_plot( - ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Width)) + - ggplot2::geom_histogram() -) +testthat::test_that("reporter_previewer_srv - previewer_buttons parameter", { + testthat::expect_silent( + shiny::testServer( + reporter_previewer_srv, + args = list( + reporter = reporter, + previewer_buttons = c("download", "load", "reset") + ), + expr = {} + ) + ) -reporter <- Reporter$new() -reporter$append_cards(list(card1, card2)) + testthat::expect_silent( + shiny::testServer( + reporter_previewer_srv, + args = list( + reporter = reporter, + previewer_buttons = "download" + ), + expr = {} + ) + ) + + testthat::expect_error( + shiny::testServer( + reporter_previewer_srv, + args = list( + reporter = reporter, + previewer_buttons = c("load", "reset") + ), + expr = {} + ), + "Assertion" + ) +}) testthat::test_that("reporter_previewer_srv - up with first card and down with last card does not induce change", { shiny::testServer( @@ -97,9 +125,3 @@ testthat::test_that("reporter_previewer_srv - card up and down compensate", { } ) }) - -testthat::test_that("reporter_previewer_ui - returns a tagList", { - testthat::expect_true( - inherits(reporter_previewer_ui("sth"), c("shiny.tag.list")) - ) -}) diff --git a/tests/testthat/test-RcodeBlock.R b/tests/testthat/test-RcodeBlock.R deleted file mode 100644 index 0b4a35030..000000000 --- a/tests/testthat/test-RcodeBlock.R +++ /dev/null @@ -1,70 +0,0 @@ -testthat::test_that("RcodeBlock object can be created", { - testthat::expect_no_error(RcodeBlock$new()) -}) - -testthat::test_that("new returns an object of type RcodeBlock", { - testthat::expect_true(inherits(RcodeBlock$new(), "RcodeBlock")) -}) - -testthat::test_that("set_content accepts a string", { - block <- RcodeBlock$new() - testthat::expect_no_error(block$set_content("test")) -}) - -testthat::test_that("set_content asserts the argument is a string", { - block <- RcodeBlock$new() - testthat::expect_error(block$set_content(7), regexp = "Must be of type 'string'") -}) - -testthat::test_that("set_content returns the RcodeBlock object", { - block <- RcodeBlock$new() - testthat::expect_identical(block$set_content("test"), block) -}) - -testthat::test_that("get_content returns character(0) on a newly initialized RcodeBlock", { - testthat::expect_equal(RcodeBlock$new()$get_content(), character(0)) -}) - -testthat::test_that("get_content returns previously set string", { - testthat::expect_equal(RcodeBlock$new()$set_content("test")$get_content(), "test") -}) - -testthat::test_that("get_available_params returns an array of character", { - testthat::expect_true(checkmate::test_character(RcodeBlock$new()$get_available_params(), any.missing = FALSE)) -}) - -testthat::test_that("set_params accepts one of the styles returned by get_available_params", { - for (param in RcodeBlock$new()$get_available_params()) { - input <- list() - input[[param]] <- NULL - testthat::expect_no_error(RcodeBlock$new()$set_params(input)) - } -}) - -testthat::test_that("set_params returns the RcodeBlock object", { - block <- RcodeBlock$new() - input <- list() - input[[block$get_available_params()[1]]] <- NULL - testthat::expect_identical(block$set_params(input), block) -}) - -testthat::test_that("to_list returns a two field named list", { - testthat::expect_identical( - RcodeBlock$new()$set_content("test")$to_list(), - list(text = "test", params = list()) - ) -}) - -testthat::test_that("from_list returns a similar output to set_content", { - testthat::expect_equal( - RcodeBlock$new()$from_list(list(text = "test", params = list(echo = TRUE))), - RcodeBlock$new()$set_content("test")$set_params(list(echo = TRUE)) - ) -}) - -testthat::test_that("from_list after to_list to save and retrive", { - testthat::expect_equal( - RcodeBlock$new()$from_list(RcodeBlock$new()$set_content("test")$to_list()), - RcodeBlock$new()$set_content("test") - ) -}) diff --git a/tests/testthat/test-Renderer.R b/tests/testthat/test-Renderer.R deleted file mode 100644 index 6df7141bb..000000000 --- a/tests/testthat/test-Renderer.R +++ /dev/null @@ -1,40 +0,0 @@ -testthat::test_that("Renderer object can be created", { - testthat::expect_no_error(Renderer$new()) -}) - -testthat::test_that("new returns an object of type Renderer", { - testthat::expect_true(inherits(Renderer$new(), "Renderer")) -}) - -testthat::skip_if_not_installed("ggplot2") - -text_block1 <- TextBlock$new()$set_content("text")$set_style("header2") -text_block2 <- TextBlock$new()$set_content("text") -png_path <- system.file("img", "Rlogo.png", package = "png") -picture_block <- PictureBlock$new()$set_content(ggplot2::ggplot(iris)) -html_block <- HTMLBlock$new(shiny::tags$div("test")) -# https://github.com/davidgohel/flextable/issues/600 -withr::with_options( - opts_partial_match_old, - table_block <- TableBlock$new()$set_content(iris) -) -newpage_block <- NewpageBlock$new() -blocks <- list(text_block1, text_block2, picture_block, table_block, newpage_block, html_block) - -testthat::test_that("renderRmd asserts the argument is a list of TextBlocks/PictureBlock/NewpageBlock/TableBlock", { - renderer <- Renderer$new() - testthat::expect_error( - renderer$renderRmd(append(blocks, "STH")), - regexp = "May only contain the following types: \\{TextBlock,PictureBlock,NewpageBlock,TableBlock,RcodeBlock,HTMLBlock\\}" # nolint line_length - ) -}) - -testthat::test_that("render returns the same path as get_last_output_file", { - renderer <- Renderer$new() - testthat::expect_true(basename(renderer$render(blocks)) %in% list.files(renderer$get_output_dir())) -}) - -testthat::test_that("render returns the same path as get_last_output_file", { - renderer <- Renderer$new() - testthat::expect_true(basename(renderer$renderRmd(blocks)) %in% list.files(renderer$get_output_dir())) -}) diff --git a/tests/testthat/test-ReportCard.R b/tests/testthat/test-ReportCard.R index 8aa9b4221..7bf57c4f3 100644 --- a/tests/testthat/test-ReportCard.R +++ b/tests/testthat/test-ReportCard.R @@ -62,19 +62,19 @@ testthat::test_that("append_rcode accepts a character", { ) }) - testthat::test_that("append_rcode returns self", { testthat::expect_no_error( ReportCard$new()$append_rcode("x <- 2") ) }) -testthat::test_that("get_content returns a list of ContentBlock objects", { +testthat::test_that("get_content returns a list of objects", { testthat::skip_if_not_installed("ggplot2") card <- ReportCard$new() card$append_text("test")$append_plot(ggplot2::ggplot(iris))$append_metadata("SRC", "A <- plot()") - testthat::expect_true(checkmate::test_list(card$get_content(), types = "ContentBlock")) + testthat::expect_s3_class(card$get_content(), "teal_card") + checkmate::expect_list(card$get_content()) }) testthat::test_that("get_metadata returns a list of mixed objects", { @@ -82,7 +82,7 @@ testthat::test_that("get_metadata returns a list of mixed objects", { card <- ReportCard$new() card$append_metadata("sth", "test")$append_metadata("sth2", ggplot2::ggplot(iris)) - testthat::expect_false(checkmate::test_list(card$get_metadata(), types = "ContentBlock")) + testthat::expect_failure(testthat::expect_s3_class(card$get_metadata(), "teal_card")) }) testthat::test_that("get_metadata returns a named list", { @@ -135,18 +135,15 @@ testthat::test_that("append_metadata throws error if keys are duplicated", { ) }) - -testthat::test_that("The deep copy constructor copies the file in the content blocks", { +testthat::test_that("The deep copy constructor copies the plot object", { testthat::skip_if_not_installed("ggplot2") card <- ReportCard$new() card$append_text("test")$append_plot(ggplot2::ggplot(iris))$append_metadata("SRC", "A <- plot(1)") card_copy <- card$clone(deep = TRUE) - original_filepath <- card$get_content()[[2]]$get_content() - copied_filepath <- card_copy$get_content()[[2]]$get_content() - testthat::expect_true(original_filepath != copied_filepath) + testthat::expect_identical(card$get_content()[[2]], card_copy$get_content()[[2]]) }) -testthat::test_that("The deep copy constructor copies the non ContentBlock objects", { +testthat::test_that("The deep copy constructor copies the objects", { testthat::skip_if_not_installed("ggplot2") card <- ReportCard$new() @@ -166,48 +163,3 @@ testthat::test_that("setting and getting a name to the ReportCard", { character(0) ) }) - -testthat::skip_if_not_installed("ggplot2") - -card <- ReportCard$new() -rcode <- "ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + ggplot2::geom_histogram()" -card$append_text("Header 2 text", "header2") -card$append_text("A paragraph of default text", "header2") -card$append_rcode(rcode) -card$append_plot(eval(str2lang(rcode))) -card$append_html(shiny::tags$div("test")) - -picture_filename <- basename(card$get_content()[[4]]$get_content()) -temp_dir <- file.path(tempdir(), "test") -dir.create(temp_dir) - -testthat::test_that("to_list internally triggers to_list on each Block", { - testthat::expect_identical( - card$to_list(temp_dir), - list(blocks = list( - TextBlock = list(text = "Header 2 text", style = "header2"), - TextBlock = list(text = "A paragraph of default text", style = "header2"), - RcodeBlock = list(text = rcode, params = list()), - PictureBlock = list(basename = picture_filename), - HTMLBlock = list(content = shiny::tags$div("test")) - ), metadata = list(), name = character(0)) - ) - testthat::expect_true(picture_filename %in% list.files(temp_dir)) -}) - -testthat::test_that("from_list", { - cardf <- ReportCard$new()$from_list( - list(blocks = list( - TextBlock = list(text = "Header 2 text", style = "header2"), - TextBlock = list(text = "A paragraph of default text", style = "header2"), - RcodeBlock = list(text = rcode, params = list()), - PictureBlock = list(basename = picture_filename), - HTMLBlock = list(content = shiny::tags$div("test")) - ), metadata = list()), - temp_dir - ) - testthat::expect_true(inherits(cardf, "ReportCard")) - testthat::expect_length(cardf$get_content(), 5L) -}) - -unlink(temp_dir, recursive = TRUE) diff --git a/tests/testthat/test-Reporter.R b/tests/testthat/test-Reporter.R index 0640d056e..57f507710 100644 --- a/tests/testthat/test-Reporter.R +++ b/tests/testthat/test-Reporter.R @@ -6,84 +6,109 @@ testthat::test_that("new returns an object of type Reporter", { testthat::expect_true(inherits(Reporter$new(), "Reporter")) }) -testthat::skip_if_not_installed("ggplot2") - -card1 <- 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 <- 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) -# https://github.com/davidgohel/flextable/issues/600 -withr::with_options( - opts_partial_match_old, - { - card2$append_table(table_res2) - card2$append_table(iris) - } -) - -reporter <- Reporter$new() -reporter$append_cards(list(card1, card2)) - testthat::test_that("default reporter id", { - testthat::expect_identical(reporter$get_id(), "") + testthat::expect_identical(Reporter$new()$get_id(), "") }) testthat::test_that("set_id sets the reporter id and returns reporter", { + reporter <- test_reporter() testthat::expect_s3_class(reporter$set_id("xyz"), "Reporter") testthat::expect_identical(reporter$set_id("xyz")$get_id(), "xyz") }) +testthat::describe("Reporter with ReportCard", { + card1 <- test_card1.ReportCard() + card2 <- test_card2.ReportCard() + reporter <- test_reporter.ReportCard(card1, card2) + it("get_cards returns the same cards which was added to reporter", { + testthat::expect_equal(unname(reporter$get_cards()), list(test_card1(), test_card2()), ignore_attr = "names") + }) + + it("get_blocks returns the same blocks which was added to reporter, sep = NULL", { + testthat::expect_equal( + reporter$get_blocks(sep = NULL), + c( + teal_card("# _Unnamed Card (1)_"), + card1$get_content(), + "# _Unnamed Card (2)_", + card2$get_content() + ), + ignore_attr = "names" + ) + }) + + it("get_blocks by default adds 'newpage' between cards", { + reporter <- test_reporter.ReportCard(card1 <- test_card1.ReportCard(), card2 <- test_card2.ReportCard()) + reporter_blocks <- reporter$get_blocks() + reporter_blocks2 <- c(teal_card("# _Unnamed Card (1)_"), reporter$get_cards()[[1]], "\\newpage") + reporter_blocks2 <- c(reporter_blocks2, "# _Unnamed Card (2)_", reporter$get_cards()[[2]]) + testthat::expect_equal( + reporter$get_blocks(), + reporter_blocks2, + ignore_attr = "names" + ) + }) + + it("get_blocks returns the same blocks which was added to reporter, sep = NULL", { + reporter <- test_reporter.ReportCard(card1 <- test_card1.ReportCard(), card2 <- test_card2.ReportCard()) + testthat::expect_equal( + unname(reporter$get_blocks(sep = NULL)), + unname(c(teal_card("# _Unnamed Card (1)_"), card1$get_content(), "# _Unnamed Card (2)_", card2$get_content())) + ) + }) +}) + testthat::test_that("get_cards returns the same cards which was added to reporter", { - testthat::expect_identical(unname(reporter$get_cards()), list(card1, card2)) + reporter <- test_reporter(card1 <- test_card1(), card2 <- test_card2()) + testthat::expect_equal(unname(reporter$get_cards()), list(card1, card2)) }) testthat::test_that("get_blocks returns the same blocks which was added to reporter, sep = NULL", { - testthat::expect_identical(reporter$get_blocks(sep = NULL), append(card1$get_content(), card2$get_content())) + reporter <- test_reporter(card1 <- test_card1("A title"), card2 <- test_card2("Another title")) + testthat::expect_equal( + reporter$get_blocks(sep = NULL), + as.teal_card( + append( + c(sprintf("# %s", metadata(card1, "title")), card1), + c(sprintf("# %s", metadata(card2, "title")), card2) + ) + ), + ignore_attr = "names" + ) }) -reporter_blocks <- reporter$get_blocks() -reporter_blocks2 <- append(reporter_blocks[1:3], NewpageBlock$new()) -reporter_blocks2 <- append(reporter_blocks2, reporter_blocks[5:8]) +testthat::test_that("get_blocks by default adds 'newpage' between cards", { + card1 <- test_card1("A title") + card2 <- test_card2("Another title") + reporter <- test_reporter(card1, card2) -testthat::test_that("get_blocks by default adds NewpageBlock$new() between cards", { - testthat::expect_equal(reporter$get_blocks(), reporter_blocks2) -}) + reporter_1 <- Reporter$new()$append_cards(card1) + reporter_2 <- Reporter$new()$append_cards(card2) -reporter2 <- Reporter$new() + reporter_blocks <- reporter$get_blocks() + reporter_blocks2 <- append(reporter_1$get_blocks(), "\\newpage") + reporter_blocks2 <- append(reporter_blocks2, reporter_2$get_blocks()) + testthat::expect_equal(reporter$get_blocks(), reporter_blocks2, ignore_attr = "names") +}) -testthat::test_that("get_blocks and get_cards return empty list by default", { - testthat::expect_identical(reporter2$get_blocks(), list()) - testthat::expect_identical(reporter2$get_cards(), list()) +testthat::test_that("get_blocks and get_cards return empty teal_card by default", { + reporter <- Reporter$new() + testthat::expect_identical(reporter$get_blocks(), teal_card()) + testthat::expect_identical(reporter$get_cards(), structure(list(), names = character(0L))) }) testthat::test_that("The deep copy constructor copies the content files to new files", { - card <- ReportCard$new()$append_plot(ggplot2::ggplot(iris)) - reporter <- Reporter$new()$append_cards(list(card)) + testthat::skip_if_not_installed("ggplot2") + card <- teal_card(ggplot2::ggplot(iris)) + reporter <- Reporter$new()$append_cards(card) reporter_copy <- reporter$clone(deep = TRUE) - original_content_file <- reporter$get_blocks()[[1]]$get_content() - copied_content_file <- reporter_copy$get_blocks()[[1]]$get_content() - - testthat::expect_false(original_content_file == copied_content_file) -}) - + original_content_file <- reporter$get_blocks() + copied_content_file <- reporter_copy$get_blocks() -testthat::test_that("reactive_add_card", { - reporter <- Reporter$new() - testthat::expect_error(reporter$get_reactive_add_card()) - testthat::expect_identical(shiny::isolate(reporter$get_reactive_add_card()), 0) - reporter$append_cards(list(card1)) - testthat::expect_identical(shiny::isolate(reporter$get_reactive_add_card()), 1L) + testthat::expect_failure( + testthat::expect_equal(rlang::obj_address(original_content_file), rlang::obj_address(copied_content_file)) + ) + testthat::expect_equal(original_content_file, copied_content_file, ignore_attr = "names") }) testthat::test_that("append_metadata accept only named list", { @@ -129,77 +154,240 @@ testthat::test_that("from_reporter persists the reactive_add_card count", { ) }) -testthat::test_that("to_list require the existing directory path", { - testthat::expect_error(reporter1$to_list(), 'argument "output_dir" is missing, with no default') - testthat::expect_error(reporter1$to_list("/path/WRONG"), "Directory '/path/WRONG' does not exist.") -}) - -temp_dir <- file.path(tempdir(), "test") -unlink(temp_dir, recursive = TRUE) -dir.create(temp_dir) - -testthat::test_that("to_list returns a list.", { - testthat::expect_equal( - list(name = "teal Reporter", version = "1", id = "", cards = list(), metadata = list()), - Reporter$new()$to_list(temp_dir) - ) -}) - -testthat::test_that("to_list and from_list could be used to save and retrive a Reporter ", { - testthat::expect_identical( - length(reporter1$get_cards()), - length(Reporter$new()$from_list(reporter1$to_list(temp_dir), temp_dir)$get_cards()) - ) - testthat::expect_identical( - length(reporter1$get_blocks()), - length(Reporter$new()$from_list(reporter1$to_list(temp_dir), temp_dir)$get_blocks()) - ) -}) - - -testthat::test_that("from_reporter returns identical/equal object from the same reporter", { - testthat::expect_identical(reporter, reporter$from_reporter(reporter)) -}) - -reporter1 <- Reporter$new() -reporter1$append_cards(list(card1, card2)) -reporter2 <- Reporter$new() - -testthat::test_that("from_reporter does not return identical/equal object form other reporter", { - testthat::expect_false(identical(reporter1, reporter2$from_reporter(reporter1))) +testthat::describe("metadata", { + it("append_metadata accept only named list", { + reporter <- Reporter$new() + testthat::expect_no_error(reporter$append_metadata(list(sth = "sth"))) + testthat::expect_error(reporter$append_metadata("sth"), "'list', not 'character'") + testthat::expect_error(reporter$append_metadata(list("sth")), "Must have names") + }) + + it("append_metadata accept only unique names which could not be repeated", { + reporter <- Reporter$new() + testthat::expect_error(reporter$append_metadata(list(sth = "sth", sth = 2)), "but element 2 is duplicated") + reporter <- Reporter$new() + testthat::expect_no_error(reporter$append_metadata(list(sth = "sth"))) + testthat::expect_error(reporter$append_metadata(list(sth = "sth")), "failed: Must be TRUE") + }) + + it("get_metadata", { + reporter <- Reporter$new() + testthat::expect_no_error(reporter$append_metadata(list(sth = "sth"))) + testthat::expect_identical(reporter$get_metadata(), list(sth = "sth")) + }) }) -testthat::test_that("from_reporter persists the cards structure", { - testthat::expect_identical(unname(reporter1$get_cards()), unname(reporter2$from_reporter(reporter1)$get_cards())) +testthat::describe("from_reporter", { + it("from_reporter returns identical/equal object from the same reporter", { + reporter <- test_reporter() + testthat::expect_identical(reporter, reporter$from_reporter(reporter)) + }) + + it("from_reporter does not return identical/equal object form other reporter", { + reporter1 <- test_reporter(test_card1(), test_card2()) + reporter2 <- Reporter$new() + + testthat::expect_false(identical(reporter1, reporter2$from_reporter(reporter1))) + }) + + it("from_reporter persists the cards structure, but not the name", { + reporter1 <- test_reporter(test_card1(), test_card2()) + reporter2 <- Reporter$new() + testthat::expect_identical( + unname(reporter1$get_cards()), + unname(reporter2$from_reporter(reporter1)$get_cards()) + ) + }) }) -testthat::test_that("from_reporter persists the reactive_add_card count", { - testthat::expect_identical( - shiny::isolate(reporter1$get_reactive_add_card()), - shiny::isolate(reporter2$from_reporter(reporter1)$get_reactive_add_card()) - ) +testthat::describe("to_list", { + it("require the existing directory path", { + reporter1 <- test_reporter(test_card1(), test_card2()) + testthat::expect_error(reporter1$to_list(), 'argument "output_dir" is missing, with no default') + testthat::expect_error(reporter1$to_list("/path/WRONG"), "Directory '/path/WRONG' does not exist.") + }) + + it("returns a list.", { + temp_dir <- withr::local_tempdir() + testthat::expect_equal( + list(name = "teal Reporter", version = "1", id = "", cards = list(), metadata = list()), + Reporter$new()$to_list(temp_dir) + ) + }) + + it("to_list and from_list could be used to save and retrieve a Reporter card", { + temp_dir <- withr::local_tempdir() + reporter1 <- test_reporter(test_card1(), test_card2()) + testthat::expect_identical( + length(reporter1$get_cards()), + length(Reporter$new()$from_list(reporter1$to_list(temp_dir), temp_dir)$get_cards()) + ) + testthat::expect_identical( + length(reporter1$get_blocks()), + length(Reporter$new()$from_list(reporter1$to_list(temp_dir), temp_dir)$get_blocks()) + ) + }) + + it("to_list and from_list could be used to save and retrieve a Reporter blocks", { + temp_dir <- withr::local_tempdir() + reporter1 <- test_reporter(test_card1(), test_card2()) + testthat::expect_identical( + length(reporter1$get_blocks()), + length(Reporter$new()$from_list(reporter1$to_list(temp_dir), temp_dir)$get_blocks()) + ) + }) }) -testthat::test_that("to_jsondir require the existing directory path", { - testthat::expect_error(reporter$to_jsondir(), 'argument "output_dir" is missing, with no default') - testthat::expect_error(reporter$to_jsondir("/path/WRONG"), "Directory '/path/WRONG' does not exist.") +testthat::describe("from_reporter", { + it("returns same object from the same reporter", { + shiny::reactiveConsole(TRUE) + reporter <- test_reporter(card1 <- test_card1(), card2 <- test_card2()) + testthat::expect_identical(reporter, (Reporter$new()$from_reporter(reporter))) + }) + + # TODO: Q: is this test valid? in other words should override id when using "from_reporter"? + it("returns different object if id has already been set", { + reporter1 <- test_reporter(test_card1(), test_card2()) + reporter2 <- teal.reporter::Reporter$new() + reporter1$set_id("a_id") + testthat::expect_failure( + testthat::expect_identical(reporter1, (reporter2$from_reporter(reporter1))), + "not identical to" + ) + }) + + it("from_reporter persists the cards structure", { + reporter1 <- test_reporter(test_card1(), test_card2()) + reporter2 <- teal.reporter::Reporter$new() + testthat::expect_equal( + reporter1$get_cards(), + reporter2$from_reporter(reporter1)$get_cards(), + ignore_attr = "names" + ) + }) }) -temp_dir <- file.path(tempdir(), "test") -unlink(temp_dir, recursive = TRUE) -dir.create(temp_dir) - -testthat::test_that("to_jsondir returns the same dir it was provided to it", { - testthat::expect_identical(temp_dir, reporter$to_jsondir(temp_dir)) +testthat::describe("to_jsondir", { + it("to_jsondir require the existing directory path", { + reporter <- test_reporter(test_card1(), test_card2()) + testthat::expect_error(reporter$to_jsondir(), 'argument "output_dir" is missing, with no default') + testthat::expect_error(reporter$to_jsondir("/path/WRONG"), "Directory '/path/WRONG' does not exist.") + }) + + it("to_jsondir returns the same dir it was provided to it", { + temp_dir <- withr::local_tempdir() + reporter <- test_reporter(test_card1(), test_card2()) + testthat::expect_identical(temp_dir, reporter$to_jsondir(temp_dir)) + }) + + it("from_jsondir returns identical/equal object", { + temp_dir <- withr::local_tempdir() + reporter <- test_reporter(test_card1(), test_card2()) + reporter$to_jsondir(temp_dir) + testthat::expect_identical(reporter, reporter$from_jsondir(temp_dir)) + }) + + it("to_jsondir and from_jsondir could be used to save and retrive a Reporter", { + temp_dir <- withr::local_tempdir() + reporter <- test_reporter(test_card1(), test_card2()) + reporter_arch <- reporter$from_jsondir(reporter$to_jsondir(temp_dir)) + testthat::expect_identical(reporter$get_cards(), reporter_arch$get_cards()) + testthat::expect_identical(reporter$get_metadata(), reporter_arch$get_metadata()) + }) }) -testthat::test_that("from_jsondir returns identical/equal object", { - unlink(list.files(temp_dir), recursive = TRUE) - testthat::expect_identical(reporter, reporter$from_jsondir(temp_dir)) +testthat::describe("reorder_cards", { + card1 <- teal_card("# Section 1") + metadata(card1, "title") <- "Card1" + card2 <- teal_card("# Section A") + metadata(card2, "title") <- "Card2" + card3 <- teal_card("# Section I") + metadata(card3, "title") <- "Card3" + card4 <- teal_card("# Section i") + metadata(card4, "title") <- "Card4" + + it("returns the correct order", { + reporter <- teal.reporter::Reporter$new() # prefix needed in "it" to avoid testthat::Reporter + reporter$append_cards(list(card1, card2, card3)) + + names_before <- names(reporter$get_cards()) + reporter$reorder_cards(rev(names_before)) + names_after <- names(reporter$get_cards()) + + testthat::expect_equal(names_after, rev(names_before)) + }) + + it("returns the correct order after removal", { + reporter <- teal.reporter::Reporter$new() # prefix needed in "it" to avoid testthat::Reporter + reporter$append_cards(list(card1, card2, card3)) + + names_before <- names(reporter$get_cards()) + reporter$reorder_cards(rev(names_before)) + name_to_remove <- sample(names_before, 1) # Random pick to avoid any bias + reporter$remove_cards(name_to_remove) + + names_after <- names(reporter$get_cards()) + testthat::expect_equal(names_after, rev(names_before[names_before != name_to_remove])) + }) + + it("returns the correct order after adding (new card at the end)", { + reporter <- teal.reporter::Reporter$new() # prefix needed in "it" to avoid testthat::Reporter + reporter$append_cards(list(card1, card2, card3)) + + names_before <- names(reporter$get_cards()) + reporter$reorder_cards(rev(names_before)) + reporter$append_cards(card4) + + names_after <- names(reporter$get_cards()) + testthat::expect_equal(names_after, c(rev(names_before), setdiff(names_after, names_before))) + }) }) -testthat::test_that("to_jsondir and from_jsondir could be used to save and retrive a Reporter", { - reporter_arch <- reporter$from_jsondir(reporter$to_jsondir(temp_dir)) - testthat::expect_identical(reporter$get_cards(), reporter_arch$get_cards()) - testthat::expect_identical(reporter$get_metadata(), reporter_arch$get_metadata()) +# nolint start: commented_code. +# TODO: averissimo fix test +# testthat::test_that("from_reporter persists the cards structure", { +# testthat::expect_identical(unname(reporter1$get_cards()), unname(reporter2$from_reporter(reporter1)$get_cards())) +# }) +# nolint end: commented_code. + +testthat::describe("Reporter with custom template function", { + it("modifies teal_cards on append", { + card <- teal_card("## A Header", "A paragraph") + reporter <- Reporter$new() + + template_fun <- function(card) c(teal_card("Here comes disclaimer text"), card) + + reporter$set_template(template_fun) + reporter$append_cards(card) + + testthat::expect_equal(reporter$get_cards()[[1]][[1]], "Here comes disclaimer text") + }) + + it("removes chunk_outputs and code_chunk", { + tr <- within(teal_report(), 1 + 1) + teal_card(tr) <- c(teal_card(tr), "A separator") + tr <- within(tr, iris <- iris) + teal_card(tr) <- c(teal_card(tr), "A footer") + + reporter <- Reporter$new() + + template_fun <- function(card) { + Filter( + f = function(x) !(inherits(x, "chunk_output") || inherits(x, "code_chunk")), + x = card + ) + } + + reporter$set_template(template_fun) + reporter$append_cards(teal_card(tr)) + + expected <- teal_card("A separator", "A footer") + metadata(expected) <- list() + + testthat::expect_equal( + unname(reporter$get_cards()[[1]]), + unname(expected), + ignore_attr = TRUE + ) + }) }) diff --git a/tests/testthat/test-ResetModule.R b/tests/testthat/test-ResetModule.R index 7c9ba794d..87844a37f 100644 --- a/tests/testthat/test-ResetModule.R +++ b/tests/testthat/test-ResetModule.R @@ -1,28 +1,72 @@ -testthat::skip_if_not_installed("ggplot2") +testthat::test_that("simple_reporter_srv - reset a reporter (ReporterCard)", { + testthat::skip_if_not_installed("ggplot2") -card_fun <- function(card = ReportCard$new(), comment = NULL) { - card$append_text("Header 2 text", "header2") - card$append_text("A paragraph of default text", "header2") - card$append_plot( - ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + - ggplot2::geom_histogram() - ) - card -} + card_fun <- function(card = ReportCard$new(), comment = NULL) { + card$append_text("Header 2 text", "header2") + card$append_text("A paragraph of default text", "header2") + card$append_plot( + ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + + ggplot2::geom_histogram(binwidth = 0.2) + ) + card + } -card1 <- card_fun() -reporter <- Reporter$new() -reporter$append_cards(list(card1)) + card1 <- card_fun() + reporter <- Reporter$new() + reporter$append_cards(list(card1)) -testthat::test_that("reset_report_button_srv - reset a reporter", { - shiny::testServer( - reset_report_button_srv, - args = list(reporter = reporter), - expr = { - testthat::expect_identical(unname(reporter$get_cards()), list(card1)) - session$setInputs(`reset_reporter` = 0) - session$setInputs(`reset_reporter_ok` = 0) - testthat::expect_identical(reporter$get_blocks(), list()) - } - ) + # nolint start: commented_code. + # # TODO: averissimo check this test + # <<<<<<< HEAD + # ======= + # testthat::test_that("reset_report_button_srv - reset a reporter", { + # >>>>>>> origin/main + # shiny::testServer( + # reset_report_button_srv, + # args = list(reporter = reporter), + # expr = { + # <<<<<<< HEAD + # testthat::expect_identical(unname(reporter$get_cards()), list(card1$get_content())) + # session$setInputs(`reset_button_simple-reset_reporter` = 0) + # session$setInputs(`reset_button_simple-reset_reporter_ok` = 0) + # testthat::expect_identical(reporter$get_blocks(), teal_card()) + # } + # ) + # }) + + # testthat::test_that("simple_reporter_srv - reset a reporter", { + # testthat::skip_if_not_installed("ggplot2") + + # card_fun <- function(card = teal_card(), comment = NULL) { + # card <- c(card, "## Header 2 text") + # card <- c(card, "## A paragraph of default text") + # card <- c( + # card, + # ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + + # ggplot2::geom_histogram(binwidth = 0.2) + # ) + # card + # } + + # card1 <- card_fun() + # reporter <- Reporter$new() + # reporter$append_cards(list(card1)) + + # shiny::testServer( + # simple_reporter_srv, + # args = list(reporter = reporter, card_fun = card_fun), + # expr = { + # testthat::expect_identical(unname(reporter$get_cards()), list(card1)) + # session$setInputs(`reset_button_simple-reset_reporter` = 0) + # session$setInputs(`reset_button_simple-reset_reporter_ok` = 0) + # testthat::expect_identical(reporter$get_blocks(), teal_card()) + # ======= + # testthat::expect_identical(unname(reporter$get_cards()), list(card1)) + # session$setInputs(`reset_reporter` = 0) + # session$setInputs(`reset_reporter_ok` = 0) + # testthat::expect_identical(reporter$get_blocks(), list()) + # >>>>>>> origin/main + # } + # ) + # nolint end: commented_code. }) diff --git a/tests/testthat/test-SimpleReporter.R b/tests/testthat/test-SimpleReporter.R index cdc11afcf..99ce9430f 100644 --- a/tests/testthat/test-SimpleReporter.R +++ b/tests/testthat/test-SimpleReporter.R @@ -1,23 +1,7 @@ -testthat::skip_if_not_installed("ggplot2") - -card_fun0 <- function(card = ReportCard$new()) { - card$append_text("Header 2 text", "header2") - card$append_text("A paragraph of default text", "header2") - card$append_plot( - ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + - ggplot2::geom_histogram() - ) - card -} - - -reporter <- Reporter$new() -reporter$append_cards(list(card_fun0())) - testthat::test_that("simple_reporter_srv - render and downlaod a document", { shiny::testServer( simple_reporter_srv, - args = list(reporter = reporter, card_fun = card_fun0), + args = list(reporter = test_reporter(), card_fun = test_card1), expr = { session$setInputs(`download_button_simple` = 0) session$setInputs(`download_button_simple-output` = "html_document") @@ -25,8 +9,7 @@ testthat::test_that("simple_reporter_srv - render and downlaod a document", { session$setInputs(`download_button_simple-author` = "AUTHOR") session$setInputs(`download_button_simple-download_data` = 0) - - f <- output$`download_button_simple-download_data` + f <- output[["download_button_simple-download_data"]] testthat::expect_true(file.exists(f)) tmp_dir <- tempdir() output_dir <- file.path(tmp_dir, sprintf("report_test_%s", gsub("[.]", "", format(Sys.time(), "%Y%m%d%H%M%OS4")))) @@ -39,26 +22,42 @@ testthat::test_that("simple_reporter_srv - render and downlaod a document", { ) }) -reporter <- Reporter$new() +testthat::test_that("simple_reporter_srv - add a Card (ReportCard) to Reporter", { + card_fun0 <- function(card = ReportCard$new()) { + card$append_text("Header 2 text", "header2") + card$append_text("A paragraph of default text", "header2") + card$append_plot(ggplot2::ggplot(iris, ggplot2::aes(x = Petal.Length)) + + ggplot2::geom_histogram(binwidth = 0.2)) + card + } -testthat::test_that("simple_reporter_srv - add a Card to Reporter", { shiny::testServer( simple_reporter_srv, - args = list(reporter = reporter, card_fun = card_fun0), + args = list(reporter = Reporter$new(), card_fun = card_fun0), expr = { - card_len <- length(card_fun0()$get_content()) session$setInputs(`add_report_card_simple-add_report_card_button` = 0) session$setInputs(`add_report_card_simple-comment` = "Comment Body") session$setInputs(`add_report_card_simple-add_card_ok` = 0) + # get_blocks() adds title, comment and comment body + testthat::expect_identical(length(reporter$get_blocks()), length(card_fun()) + 3L) + } + ) +}) - testthat::expect_identical( - length(reporter$get_blocks()), - card_len + 2L - ) +testthat::test_that("simple_reporter_srv - add a Card (teal_card) to Reporter", { + shiny::testServer( + simple_reporter_srv, + args = list(reporter = Reporter$new(), card_fun = test_card1), + expr = { + session$setInputs(`add_report_card_simple-add_report_card_button` = 0) + session$setInputs(`add_report_card_simple-comment` = "Comment Body") + session$setInputs(`add_report_card_simple-add_card_ok` = 0) + # get_blocks() adds title, comment and comment body + testthat::expect_identical(length(reporter$get_blocks()), length(card_fun()) + 3L) } ) }) testthat::test_that("simple_reporter_ui - returns a shiny.tag", { - testthat::expect_true(inherits(simple_reporter_ui("sth"), "shiny.tag.list")) + checkmate::expect_multi_class(simple_reporter_ui("sth"), c("shiny.tag", "shiny.tag.list")) }) diff --git a/tests/testthat/test-TableBlock.R b/tests/testthat/test-TableBlock.R deleted file mode 100644 index bdc66539d..000000000 --- a/tests/testthat/test-TableBlock.R +++ /dev/null @@ -1,97 +0,0 @@ -testthat::test_that("TableBlock object can be created", { - testthat::expect_no_error(TableBlock$new()) -}) - -testthat::test_that("new returns an object of type TableBlock", { - testthat::expect_true(inherits(TableBlock$new(), "TableBlock")) -}) - -testthat::test_that("set_content accepts a table object", { - block <- TableBlock$new() - # https://github.com/davidgohel/flextable/issues/600 - withr::with_options( - opts_partial_match_old, - testthat::expect_no_error(block$set_content(iris)) - ) -}) - -testthat::test_that("set_content asserts the argument is a plot", { - block <- TableBlock$new() - testthat::expect_error(block$set_content(7), regexp = "Must inherit from class 'data.frame'/'rtables'") -}) - -testthat::test_that("set_content returns the TableBlock object", { - block <- TableBlock$new() - # https://github.com/davidgohel/flextable/issues/600 - withr::with_options( - opts_partial_match_old, - testthat::expect_identical(block$set_content(iris), block) - ) -}) - -testthat::test_that("get_content returns character(0) on a newly initialized TableBlock", { - testthat::expect_equal(TableBlock$new()$get_content(), character(0)) -}) - -temp_dir <- tempdir() - -testthat::test_that("to_list returns a named list with a one field, a proper file name", { - # https://github.com/davidgohel/flextable/issues/600 - withr::with_options( - opts_partial_match_old, - block <- TableBlock$new()$set_content(iris) - ) - testthat::expect_equal(block$to_list(temp_dir), list(basename = basename(block$get_content()))) -}) - -# to_list -testthat::test_that("to_list returns a named list with a one field, a proper path", { - # https://github.com/davidgohel/flextable/issues/600 - withr::with_options( - opts_partial_match_old, - tblock <- TableBlock$new()$set_content(iris) - ) - testthat::expect_identical(tblock$to_list(temp_dir), list(basename = basename(tblock$get_content()))) -}) - -# from_list -testthat::test_that("from_list after to_list to save and retrive", { - # https://github.com/davidgohel/flextable/issues/600 - withr::with_options( - opts_partial_match_old, - tblock <- TableBlock$new()$set_content(iris) - ) - testthat::expect_identical( - file.size(TableBlock$new()$from_list( - tblock$to_list(temp_dir), - dirname(tblock$get_content()) - )$get_content()), - file.size(tblock$get_content()) - ) -}) - -testthat::test_that("set_content supports data.frame object", { - block <- TableBlock$new() - # https://github.com/davidgohel/flextable/issues/600 - withr::with_options( - opts_partial_match_old, - testthat::expect_no_error(block$set_content(iris)) - ) -}) - -testthat::test_that("set_content supports rtables object", { - block <- TableBlock$new() - l <- rtables::basic_table() %>% - rtables::split_cols_by("Species") %>% - rtables::analyze("Sepal.Length", afun = function(x) { - list( - "mean (sd)" = rtables::rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"), - "range" = diff(range(x)) - ) - }) - # https://github.com/davidgohel/flextable/issues/600 - withr::with_options( - opts_partial_match_old, - testthat::expect_no_error(block$set_content(rtables::build_table(l, iris))) - ) -}) diff --git a/tests/testthat/test-TextBlock.R b/tests/testthat/test-TextBlock.R deleted file mode 100644 index a01fe0c03..000000000 --- a/tests/testthat/test-TextBlock.R +++ /dev/null @@ -1,80 +0,0 @@ -testthat::test_that("TextBlock object can be created", { - testthat::expect_no_error(TextBlock$new()) -}) - -testthat::test_that("new returns an object of type TextBlock", { - testthat::expect_true(inherits(TextBlock$new(), "TextBlock")) -}) - -testthat::test_that("set_content accepts a string", { - block <- TextBlock$new() - testthat::expect_no_error(block$set_content("test")) -}) - -testthat::test_that("set_content asserts the argument is a string", { - block <- TextBlock$new() - testthat::expect_error(block$set_content(7), regexp = "Must be of type 'string'") -}) - -testthat::test_that("set_content returns the TextBlock object", { - block <- TextBlock$new() - testthat::expect_identical(block$set_content("test"), block) -}) - -testthat::test_that("get_content returns character(0) on a newly initialized TextBlock", { - testthat::expect_equal(TextBlock$new()$get_content(), character(0)) -}) - -testthat::test_that("get_content returns previously set string", { - testthat::expect_equal(TextBlock$new()$set_content("test")$get_content(), "test") -}) - -testthat::test_that("get_available_styles returns an array of character", { - testthat::expect_true(checkmate::test_character(TextBlock$new()$get_available_styles(), any.missing = FALSE)) -}) - -testthat::test_that("set_style accepts one of the styles returned by get_available_styles", { - for (style in TextBlock$new()$get_available_styles()) { - testthat::expect_no_error(TextBlock$new()$set_style(!!style)) - } -}) - -testthat::test_that("set_style asserts the argument is one of styles in get_available_styles", { - testthat::expect_error( - TextBlock$new()$set_style("test"), - regexp = "'arg' should be one" - ) -}) - -testthat::test_that("set_style returns the TextBlock object", { - block <- TextBlock$new() - testthat::expect_identical(block$set_style(block$get_available_styles()[1]), block) -}) - -testthat::test_that("get_style returns the set style", { - testthat::expect_equal( - TextBlock$new()$set_style(TextBlock$new()$get_available_styles()[1])$get_style(), - TextBlock$new()$get_available_styles()[1] - ) -}) - -testthat::test_that("to_list returns a two field named list", { - testthat::expect_identical( - TextBlock$new()$set_content("test")$to_list(), - list(text = "test", style = "default") - ) -}) - -testthat::test_that("from_list returns a similar output to set_content", { - testthat::expect_equal( - TextBlock$new()$from_list(list(text = "test", style = "default")), - TextBlock$new()$set_content("test") - ) -}) - -testthat::test_that("from_list after to_list to save and retrive", { - testthat::expect_equal( - TextBlock$new()$from_list(TextBlock$new()$set_content("test")$to_list()), - TextBlock$new()$set_content("test") - ) -}) diff --git a/tests/testthat/test-addCardModule.R b/tests/testthat/test-addCardModule.R index 4f6c31766..be6483ee7 100644 --- a/tests/testthat/test-addCardModule.R +++ b/tests/testthat/test-addCardModule.R @@ -14,10 +14,7 @@ testthat::test_that("add_card_button_srv - add a Card to the Reporter", { session$setInputs(comment = "Comment Body") session$setInputs(`add_card_ok` = 0) - testthat::expect_identical( - length(reporter$get_blocks()), - card_len - ) + testthat::expect_length(reporter$get_blocks(), card_len + 1) # + 1 due to title } ) }) @@ -46,10 +43,7 @@ testthat::test_that("add_card_button_srv supports custom ReportCard classes", { session$setInputs(`add_report_card_button` = 0) session$setInputs(`add_card_ok` = 0) - testthat::expect_identical( - length(reporter$get_blocks()), - card_len - ) + testthat::expect_length(reporter$get_blocks(), card_len + 1) # + 1 due to title } ) }) @@ -68,48 +62,33 @@ testthat::test_that("add_card_button_srv supports passing no default object to t session$setInputs(`add_report_card_button` = 0) session$setInputs(`add_card_ok` = 0) - testthat::expect_identical( - length(reporter$get_blocks()), - card_len - ) + testthat::expect_length(reporter$get_blocks(), card_len + 1) # + 1 due to title } ) }) testthat::test_that("add_card_button_srv try the card_fun", { - card_fun <- function(card) { - stop("ARTIFICIAL ERROR") - } - shiny::testServer( add_card_button_srv, - args = list(reporter = Reporter$new(), card_fun = card_fun), + args = list(reporter = Reporter$new(), card_fun = function(card) stop("ARTIFICIAL ERROR")), expr = { session$setInputs(`add_report_card_button` = 0) testthat::expect_warning(session$setInputs(`add_card_ok` = 0)) } ) - card_fun <- function(card, comment) { - stop("ARTIFICIAL ERROR") - } - shiny::testServer( add_card_button_srv, - args = list(reporter = Reporter$new(), card_fun = card_fun), + args = list(reporter = Reporter$new(), card_fun = function(card, comment) stop("ARTIFICIAL ERROR")), expr = { session$setInputs(`add_report_card_button` = 0) testthat::expect_warning(session$setInputs(`add_card_ok` = 0)) } ) - card_fun <- function() { - stop("ARTIFICIAL ERROR") - } - shiny::testServer( add_card_button_srv, - args = list(reporter = Reporter$new(), card_fun = card_fun), + args = list(reporter = Reporter$new(), card_fun = function(card) stop("ARTIFICIAL ERROR")), expr = { session$setInputs(`add_report_card_button` = 0) testthat::expect_warning(session$setInputs(`add_card_ok` = 0)) @@ -132,10 +111,7 @@ testthat::test_that("add_card_button_srv supports passing card_fun with any of t session$setInputs(`add_report_card_button` = 0) session$setInputs(`add_card_ok` = 0) - testthat::expect_identical( - length(reporter$get_blocks()), - card_len - ) + testthat::expect_length(reporter$get_blocks(), card_len + 1) # + 1 due to title } ) @@ -153,10 +129,7 @@ testthat::test_that("add_card_button_srv supports passing card_fun with any of t session$setInputs(`add_report_card_button` = 0) session$setInputs(`add_card_ok` = 0) - testthat::expect_identical( - length(reporter$get_blocks()), - card_len - ) + testthat::expect_length(reporter$get_blocks(), card_len + 1) # + 1 due to title } ) @@ -174,10 +147,7 @@ testthat::test_that("add_card_button_srv supports passing card_fun with any of t session$setInputs(`add_report_card_button` = 0) session$setInputs(`add_card_ok` = 0) - testthat::expect_identical( - length(reporter$get_blocks()), - card_len - ) + testthat::expect_length(reporter$get_blocks(), card_len + 1) # + 1 due to title } ) @@ -195,10 +165,7 @@ testthat::test_that("add_card_button_srv supports passing card_fun with any of t session$setInputs(`add_report_card_button` = 0) session$setInputs(`add_card_ok` = 0) - testthat::expect_identical( - length(reporter$get_blocks()), - card_len - ) + testthat::expect_length(reporter$get_blocks(), card_len + 1) # + 1 due to title } ) }) diff --git a/tests/testthat/test-render.R b/tests/testthat/test-render.R new file mode 100644 index 000000000..cb07c64e2 --- /dev/null +++ b/tests/testthat/test-render.R @@ -0,0 +1,203 @@ +with_temp_wd <- function() { + new_dir <- tempfile() + dir.create(new_dir, recursive = TRUE) + old_dir <- setwd(new_dir) + withr::defer(setwd(old_dir), envir = parent.frame(2)) +} + +testthat::describe("render() accepts", { + with_temp_wd() + it("empty teal_report object", { + testthat::expect_no_error(render(teal_report(), quiet = TRUE)) + }) + it("empty teal_card object", { + testthat::expect_no_error(render(teal_card(), quiet = TRUE)) + }) + it("teal_report containing code chunks and outputs", { + r <- within(teal_report(), { + a <- 1:10 + plot(a) + }) + testthat::expect_no_error(render(r, quiet = TRUE)) + }) +}) + +testthat::describe("render() by default", { + it("outputs and keeps report.Rmd file in the working directory", { + with_temp_wd() + render(teal_report(), quiet = TRUE) + testthat::expect_true(file.exists("report.Rmd")) + }) + + it("renders report.html file in the working directory", { + with_temp_wd() + render(teal_report(), quiet = TRUE) + testthat::expect_true(file.exists("report.html")) + }) + + it("outputs report.Rmd file containing knitr::opts_chunk$set with tidy options set", { + with_temp_wd() + render(teal_report(), quiet = TRUE) + lines <- base::readLines("report.Rmd", warn = FALSE) + testthat::expect_identical( + lines, + c( + "```{R, include=FALSE}", + "knitr::opts_chunk$set(list(tidy.opts = list(width.cutoff = 60), tidy = TRUE))", + "```" + ) + ) + }) +}) + +testthat::describe("render() outputs report.Rmd with", { + withr::local_options(teal.reporter.global_knitr = list()) + it("output_dir set to other location then working directory", { + tr <- teal_report() + temp_dir <- tempfile() + render(tr, output_dir = temp_dir, quiet = TRUE) + testthat::expect_true(file.exists(file.path(temp_dir, "report.Rmd"))) + }) + + it("markdown content added to teal_card", { + with_temp_wd() + tr <- teal_report() + teal_card(tr) <- c(teal_card(tr), "# test heading", "Lorem ipsum") + render(tr, quiet = TRUE) + lines <- base::readLines("report.Rmd", warn = FALSE) + testthat::expect_identical(lines, c("# test heading", "", "Lorem ipsum")) + }) + + it("yaml header containing entries set through metadata", { + with_temp_wd() + tr <- teal_report() + teal_card(tr) <- c(teal_card(tr), "# test heading") + metadata(teal_card(tr)) <- list(title = "test title", author = "me is tot") + render(tr, quiet = TRUE) + lines <- base::readLines("report.Rmd", warn = FALSE) + testthat::expect_identical( + lines, + c( + "---", + "title: test title", + "author: me is tot", + "---", + "", + "# test heading" + ) + ) + }) + + it("code_chunk with knitr::opts_chunk$set call using value from teal.reporter.global_knitr", { + with_temp_wd() + withr::local_options(teal.reporter.global_knitr = list(eval = TRUE, echo = FALSE)) + tr <- teal_report() + teal_card(tr) <- c(teal_card(tr), "# test heading") + render(tr, quiet = TRUE) + lines <- base::readLines("report.Rmd", warn = FALSE) + testthat::expect_identical( + lines, + c( + "```{R, include=FALSE}", + "knitr::opts_chunk$set(list(eval = TRUE, echo = FALSE))", + "```", + "", + "# test heading" + ) + ) + }) + + it("code_chunk with knitr::opts_chunk$set call using value from global_knitr argument", { + with_temp_wd() + tr <- teal_report() + teal_card(tr) <- c(teal_card(tr), "# test heading") + render(tr, global_knitr = list(echo = TRUE, eval = TRUE), quiet = TRUE) + lines <- base::readLines("report.Rmd", warn = FALSE) + testthat::expect_identical( + lines, + c( + "```{R, include=FALSE}", + "knitr::opts_chunk$set(list(echo = TRUE, eval = TRUE))", + "```", + "", + "# test heading" + ) + ) + }) + + it("arbitrary code chunk with additional parameters", { + with_temp_wd() + tr <- teal_report() + teal_card(tr) <- c(teal_card(tr), "# test heading", code_chunk("a <- 1L", eval = FALSE, echo = FALSE)) + render(tr, quiet = TRUE) + lines <- base::readLines("report.Rmd", warn = FALSE) + testthat::expect_identical( + lines, + c( + "# test heading", + "", + "```{R, eval=FALSE, echo=FALSE}", + "a <- 1L", + "```" + ) + ) + }) + + it("arbitrary code cunk but chunk_output is missing", { + with_temp_wd() + tr <- teal_report() + tr <- teal.code::eval_code(tr, "plot(1:10)") + render(tr, quiet = TRUE) + lines <- base::readLines("report.Rmd", warn = FALSE) + testthat::expect_identical( + lines, + c( + "```{R}", + "plot(1:10)", + "```" + ) + ) + }) +}) + +testthat::describe("render() renders output based on metadata$output field:", { + with_temp_wd() + withr::local_options(teal.reporter.global_knitr = list()) + it("- md_document containing markdown content, code chunks and their outputs", { + tr <- teal_report() + teal_card(tr) <- c(teal_card(tr), "# test heading", "Lorem ipsum") + tr <- within(tr, plot(1:10)) + metadata(teal_card(tr)) <- list(output = "md_document") + render(tr, quiet = TRUE) + lines <- base::readLines("report.md", warn = FALSE) + testthat::expect_identical( + lines, + c( + "# test heading", + "", + "Lorem ipsum", + "", + " plot(1:10)", + "", + sprintf("![](report_files/figure-markdown_strict/unnamed-chunk-3-1.png)") + ) + ) + }) + + it("- md_document containing relative path to a plot even if output_dir is set to absolute path", { + temp_dir <- tempfile() + tr <- teal_report() + tr <- within(tr, plot(1:10)) + metadata(teal_card(tr)) <- list(output = "md_document") + render(tr, output_dir = temp_dir, quiet = TRUE) + lines <- base::readLines(file.path(temp_dir, "report.md"), warn = FALSE) + testthat::expect_identical( + lines, + c( + " plot(1:10)", + "", + sprintf("![](report_files/figure-markdown_strict/unnamed-chunk-3-1.png)") + ) + ) + }) +}) diff --git a/tests/testthat/test-teal_card.R b/tests/testthat/test-teal_card.R new file mode 100644 index 000000000..6c2c11da4 --- /dev/null +++ b/tests/testthat/test-teal_card.R @@ -0,0 +1,319 @@ +testthat::describe("teal_card", { + testthat::it("creates empty teal_card when no arguments set", { + doc <- teal_card() + testthat::expect_identical(doc, structure(list(), class = "teal_card")) + }) + + it("returns the same object for if teal_card is passed", { + doc <- teal_card("a", "b") + testthat::expect_identical(teal_card(doc), doc) + }) + + it("extracts teal_card object from teal_report if teal_report is passed", { + tr <- within(teal_report(), a <- 1) + testthat::expect_identical(teal_card(tr), tr@teal_card) + }) + + it("converts qenv@code elements into teal_card and returns teal_card if qenv is passed", { + q <- within(teal.code::qenv(), a <- 1) + testthat::expect_identical( + unname(teal_card(q)), + unname(teal_card(code_chunk("a <- 1"))) + ) + }) + + it("keeps list if given as argument", { + card <- teal_card(list(1, 2)) + testthat::expect_equal(card, structure(list(list(1, 2)), class = "teal_card"), ignore_attr = "names") + }) +}) + +testthat::describe("teal_card with multiple arguments", { + testthat::it("combines arguments in teal_card and sets them random unique names", { + doc <- teal_card("a", "b", "c", "d") + testthat::expect_identical(unname(doc), structure(list("a", "b", "c", "d"), class = "teal_card")) + testthat::expect_true(all(!duplicated(names(doc)))) + }) + + testthat::it("doesn't ignore NULL and adds it to teal_card", { + doc <- unname(teal_card("a", NULL)) + testthat::expect_identical(doc, structure(list("a", NULL), class = "teal_card")) + }) + + testthat::it("keeps conditions", { + doc <- unname(teal_card(simpleCondition("test"))) + testthat::expect_identical(doc, structure(list(simpleCondition("test")), class = "teal_card")) + }) + + testthat::it("appends each element asis (no list unwrapping)", { + doc <- unname(teal_card("a", list(1, list(2)), code_chunk("print('hi')"))) + testthat::expect_identical( + doc, + structure( + list("a", list(1, list(2)), code_chunk("print('hi')")), + class = "teal_card" + ) + ) + }) + + it("appends each argument to teal_card and keep original names if teal_card is a first argument", { + tc <- teal_card("a", "b") + out <- teal_card(tc, "c", "d") + testthat::expect_equal(unname(out), unname(teal_card("a", "b", "c", "d"))) + testthat::expect_identical(names(out)[1:2], names(tc)) + }) + + it("appends each argument to real_report@teal_card and keep original names if teal_card is a first argument", { + tr <- teal_report() + teal_card(tr) <- teal_card("a", "b") + out <- teal_card(tr, "c", "d") + testthat::expect_equal(unname(out), unname(teal_card("a", "b", "c", "d"))) + testthat::expect_identical(names(out)[1:2], names(tr@teal_card)) + }) +}) + +testthat::describe("c.teal_card combines", { + it("two empty teal_card(s)", { + testthat::expect_identical(c(teal_card(), teal_card()), teal_card()) + }) + + it("empty teal_card with non-empty", { + doc2 <- teal_card(TRUE) + testthat::expect_identical(c(teal_card(), doc2), doc2) + }) + + it("with empty teal_card - remains the same", { + doc <- teal_card("a", "b") + testthat::expect_identical(c(doc, teal_card()), doc) + }) + + it("with character - adds as a new element", { + doc_result <- c(teal_card("a", "b"), "c") + testthat::expect_equal(doc_result, teal_card("a", "b", "c"), ignore_attr = "names") + }) + + it("with list - adds each list element separately (unwraps list)", { + doc_result <- c(teal_card("a", "b"), list(1, 2)) + testthat::expect_equal(doc_result, teal_card("a", "b", 1, 2), ignore_attr = "names") + }) + + it("with teal_card containing a list - append this list asis (doesn't unwrap list)", { + doc_result <- c(teal_card("a", "b"), teal_card(list(1, 2))) + testthat::expect_equal(doc_result, teal_card("a", "b", list(1, 2)), ignore_attr = "names") + }) + + it("with NULL - remains the same (ignores NULL)", { + doc_result <- c(teal_card("a", "b"), NULL) + testthat::expect_equal(doc_result, teal_card("a", "b"), ignore_attr = "names") + }) + + it("with character(0) - adds as a new element", { + doc_result <- c(teal_card("a", "b"), character(0)) + testthat::expect_equal(doc_result, teal_card("a", "b", character(0)), ignore_attr = "names") + }) + + it("with ggplot - adds as a new element", { + rlang::local_options("teal.reporter.disable_teal_card_conversion" = TRUE) + plot <- ggplot2::ggplot(iris) + doc_result <- c(teal_card("a", "b"), plot) + testthat::expect_equal(doc_result, teal_card("a", "b", plot), ignore_attr = "names") + }) + + it("with new teal_card - adds new elements asis", { + doc_result <- c(teal_card("a", "b"), teal_card("c", "d")) + testthat::expect_equal(doc_result, teal_card("a", "b", "c", "d"), ignore_attr = "names") + }) + + it("with new teal_card containing ggplot - adds new elements asis", { + rlang::local_options("teal.reporter.disable_teal_card_conversion" = TRUE) + plot <- ggplot2::ggplot(iris) + + ggplot2::geom_point(ggplot2::aes(x = Sepal.Length, y = Sepal.Width)) + doc_result <- c(teal_card("a", "b"), teal_card("# Plot", plot)) + testthat::expect_equal(doc_result, teal_card("a", "b", "# Plot", plot), ignore_attr = "names") + }) + + it("with teal_card containing new and old items - adds only new", { + doc1 <- teal_card("a", "b") + doc2 <- c(doc1, "c", "d") + testthat::expect_equal(c(doc1, doc2), teal_card("a", "b", "c", "d"), ignore_attr = "names") + }) + + it("with teal_card containing new and old items - adds even if their order is different", { + doc1 <- teal_card("a", "b") + doc2 <- c(doc1, "c", "d") + doc2 <- doc2[c(3, 1, 4, 2)] + testthat::expect_equal(c(doc1, doc2), teal_card("c", "a", "d", "b"), ignore_attr = "names") + }) + + it("with teal_card with new and missing old items - restores original items, adds new at the end and warn", { + doc1 <- teal_card("a", "b") + doc2 <- c(doc1, "c", "d")[c(4, 3, 2)] + testthat::expect_warning( + testthat::expect_equal(c(doc1, doc2), teal_card("a", "b", "d", "c"), ignore_attr = "names") + ) + }) + + it("with a `teal_card` - keeps original metadata", { + doc <- teal_card("a", "b") + metadata(doc) <- list(title = "A Title", a = "test") + doc_result <- c(doc, teal_card("new content")) + testthat::expect_identical(metadata(doc_result), list(title = "A Title", a = "test")) + }) + + it("new `teal_card` - combines metadata and overwrites original", { + doc1 <- teal_card("a", "b") + metadata(doc1) <- list(title = "A Title", a = "test") + doc2 <- teal_card("new content") + metadata(doc2) <- list(title = "A New Title", b = "test2") + doc_result <- c(doc1, doc2) + testthat::expect_identical(metadata(doc_result), list(title = "A New Title", a = "test", b = "test2")) + }) +}) + +testthat::it("[.card subsets and", { + it("retains class", { + doc <- teal_card("a", "b", "c", "d") + sub_doc <- doc[c(1, 3)] + testthat::expect_s3_class(sub_doc, "teal_card") + testthat::expect_length(sub_doc, 2) + testthat::expect_equal(sub_doc[[1]], "a") + testthat::expect_equal(sub_doc[[2]], "c") + + empty_sub_doc <- doc[0] + testthat::expect_s3_class(empty_sub_doc, "teal_card") + testthat::expect_length(empty_sub_doc, 0) + }) +}) + +testthat::describe("as.teal_card", { + it("converts a simple list with each element being converted to a report content", { + simple_list <- list("a", "b", "c") + doc <- as.teal_card(simple_list) + testthat::expect_equal(doc, teal_card("a", "b", "c"), ignore_attr = "names") + }) + + it("converts a custom list class with many elements into single-element-teal_card", { + custom_list <- list("a", "b", "c", "d") + class(custom_list) <- "extra class" + doc <- as.teal_card(custom_list) + testthat::expect_equal(doc, teal_card(custom_list), ignore_attr = "names") + }) + + it("converts a ggplot2 to a teal_card with only 1 report content", { + testthat::skip_if_not_installed("ggplot2") + plot <- ggplot2::ggplot(iris) + + ggplot2::geom_point(ggplot2::aes(x = Sepal.Length, y = Sepal.Width)) + doc <- as.teal_card(plot) + testthat::expect_equal(doc, teal_card(plot), ignore_attr = "names") + }) +}) + +testthat::describe("metadata", { + it("can be assigned individually to `teal_card` object using 'which' argument", { + doc <- teal_card("a", "b") + metadata(doc, "title") <- "A Title" + testthat::expect_equal(metadata(doc, "title"), "A Title") + }) + + it("can be assigned individually to `teal_card` using `$`", { + doc <- teal_card("a", "b") + metadata(doc)$title <- "A Title" + testthat::expect_equal(metadata(doc, "title"), "A Title") + }) + + it("can be assigned as named list to `teal_card` object", { + doc <- teal_card("a", "b") + metadata(doc) <- list(title = "A Title") + testthat::expect_equal(metadata(doc, "title"), "A Title") + }) + + it("can be assigned individually to `ReportCard` object", { + doc <- ReportCard$new() + metadata(doc, "title") <- "A Title" + testthat::expect_equal(metadata(doc, "title"), "A Title") + testthat::expect_equal(doc$get_name(), "A Title") + }) + + it("can be assigned as named list to `ReportCard` object if only has title", { + doc <- ReportCard$new() + metadata(doc) <- list(title = "A Title") + testthat::expect_equal(metadata(doc, "title"), "A Title") + testthat::expect_equal(doc$get_name(), "A Title") + }) + + it("assignment throws warning when named list has other elements than title", { + doc <- ReportCard$new() + testthat::expect_warning( + fixed = TRUE, + metadata(doc) <- list(title = "A Title", prop = "A property"), + "ReportCard class only supports `title` in metadata" + ) + testthat::expect_equal(metadata(doc, "title"), "A Title") + testthat::expect_equal(doc$get_name(), "A Title") + }) + + it("assignment throws warning when named list has element, but not title", { + doc <- ReportCard$new() + testthat::expect_warning( + fixed = TRUE, + metadata(doc) <- list(prop = "A property"), + "ReportCard class only supports `title` in metadata" + ) + testthat::expect_equal(metadata(doc), list(title = character(0L))) + }) + + it("only supports assigning `title` in `ReportCard` object", { + doc <- ReportCard$new() + testthat::expect_warning( + fixed = TRUE, + metadata(doc, "prop") <- "A Property", + "ReportCard class only supports `title` in metadata" + ) + }) +}) + +testthat::test_that("teal_card index assignment converts to unique identifier", { + card <- teal_card("# Header", "A paragraph") + card[[2]] <- "Override" + + testthat::expect_equal(card[[2]], "Override") + checkmate::expect_names(names(card), type = "unique") +}) + +testthat::describe("teal_card converts", { + testthat::it("ggplot2 objects to recordedplot", { + testthat::skip_if_not_installed("ggplot2") + sample_plot <- ggplot2::ggplot(iris) + + ggplot2::geom_histogram(ggplot2::aes(x = Sepal.Length), binwidth = .1) + testthat::expect_s3_class(teal_card(sample_plot)[[1]], "recordedplot") + }) + + testthat::it("ggplot2 objects to recordedplot when using `c()`", { + testthat::skip_if_not_installed("ggplot2") + sample_plot <- ggplot2::ggplot(iris) + + ggplot2::geom_histogram(ggplot2::aes(x = Sepal.Length), binwidth = .1) + + card <- c(teal_card("A header"), sample_plot) + testthat::expect_s3_class(card[[2]], "recordedplot") + }) + + testthat::it("ggplot2 objects to recordedplot when using assigning", { + testthat::skip_if_not_installed("ggplot2") + sample_plot <- ggplot2::ggplot(iris) + + ggplot2::geom_histogram(ggplot2::aes(x = Sepal.Length), binwidth = .1) + + card <- teal_card("A header") + card[[1]] <- sample_plot + testthat::expect_s3_class(card[[1]], "recordedplot") + }) + + testthat::it("ggplot2 objects to recordedplot when using assigning with new name", { + testthat::skip_if_not_installed("ggplot2") + sample_plot <- ggplot2::ggplot(iris) + + ggplot2::geom_histogram(ggplot2::aes(x = Sepal.Length), binwidth = .1) + + card <- teal_card("A header") + card[["a new name"]] <- sample_plot + testthat::expect_s3_class(card[["a new name"]], "recordedplot") + }) +}) diff --git a/tests/testthat/test-teal_report-c.R b/tests/testthat/test-teal_report-c.R new file mode 100644 index 000000000..c53817831 --- /dev/null +++ b/tests/testthat/test-teal_report-c.R @@ -0,0 +1,38 @@ +testthat::describe("c.teal_report combines", { + it("two empty teal_report objects", { + testthat::expect_equal(c(teal_report(), teal_report()), teal_report()) + }) + + it("empty and non-empty teal_report by appending elements of teal_card", { + treport1 <- teal_report() + treport2 <- teal_report(teal_card = teal_card("Text 2")) + testthat::expect_equal( + teal_card(c(treport1, treport2)), + teal_card("Text 2"), + ignore_attr = TRUE + ) + }) + + it("two teal_report by combining elements of teal_card", { + treport1 <- teal_report(teal_card = teal_card("Text 1")) + treport2 <- teal_report(teal_card = teal_card("Text 2")) + testthat::expect_equal( + teal_card(c(treport1, treport2)), + teal_card("Text 1", "Text 2"), + ignore_attr = TRUE + ) + }) + + it("multiple teal_report by combining elements of teal_card", { + treport1 <- teal_report(teal_card = teal_card("Text 1")) + treport2 <- teal_report(teal_card = teal_card("Text 2")) + treport3 <- teal_report() + treport4 <- teal_report(teal_card = teal_card("Text 2")) + + testthat::expect_equal( + teal_card(c(treport1, treport2, treport3, treport4)), + teal_card("Text 1", "Text 2", "Text 2"), + ignore_attr = TRUE + ) + }) +}) diff --git a/tests/testthat/test-teal_report-class.R b/tests/testthat/test-teal_report-class.R new file mode 100644 index 000000000..6377ffe03 --- /dev/null +++ b/tests/testthat/test-teal_report-class.R @@ -0,0 +1,44 @@ +testthat::describe("teal_card built from teal_data", { + code <- c( + "aa <- 1", + "bb <- 2", + "mtcars <- mtcars", + "iris <- iris", + "aa", + "bb", + "plot(1:10)" + ) + + it("is identical when running via eval_code with teal_report object", { + td <- eval_code(teal.data::teal_data(), code) + tr <- eval_code(teal_report(), code) + + testthat::expect_equal(unname(teal_card(td)), unname(teal_card(tr))) + }) + + it("is identical when calling as.teal_report", { + td <- eval_code(teal.data::teal_data(), code) + tr <- eval_code(teal_report(), code) + + testthat::expect_equal(unname(teal_card(as.teal_report(td))), unname(teal_card(tr))) + }) + + it("is identical when calling as.teal_report with multiple calls", { + td <- Reduce(f = eval_code, init = teal.data::teal_data(), x = code) + tr <- Reduce(f = eval_code, init = teal_report(), x = code) + + testthat::expect_equal(unname(teal_card(as.teal_report(td))), unname(teal_card(tr))) + }) + + it("drops conditions produced in a code-chunk evaluation", { + td <- eval_code(teal.data::teal_data(), "warning(1)") + testthat::expect_equal(unname(teal_card(td)), unname(teal_card(code_chunk("warning(1)")))) + }) +}) + +testthat::test_that("teal_data converts to teal_report when assigning teal_card", { + td <- teal.data::teal_data() + teal_card(td) <- teal_card("# A title") + + testthat::expect_s4_class(td, "teal_report") +}) diff --git a/tests/testthat/test-teal_report-eval_code.R b/tests/testthat/test-teal_report-eval_code.R new file mode 100644 index 000000000..c9ef33382 --- /dev/null +++ b/tests/testthat/test-teal_report-eval_code.R @@ -0,0 +1,57 @@ +testthat::describe("eval_code appends code_chunks to the teal_card", { + it("code as code_chunk", { + q <- eval_code(teal_report(), "a <- 1L;b <- 2L;c <- 3L") + testthat::expect_equal( + teal_card(q), + teal_card( + code_chunk("a <- 1L"), + code_chunk("b <- 2L"), + code_chunk("c <- 3L") + ), + ignore_attr = "names" + ) + }) + + it("code as code_chunk and its output as chunk_output", { + q <- eval_code(teal_report(), "a <- 1L;a") + testthat::expect_equal( + teal_card(q), + c( + teal_card(), + code_chunk("a <- 1L"), + code_chunk("a"), + structure(list(1L), class = c("chunk_output")) + ), + ignore_attr = "names" + ) + }) + + it("code as code_chunk and condition is excluded from output", { + q <- eval_code(teal_report(), "warning('test')") + testthat::expect_equal( + teal_card(q), + c(teal_card(), code_chunk("warning('test')")), + ignore_attr = "names" + ) + }) +}) + +testthat::describe("within appends to teal_card", { + it("code as code_chunk", { + q <- within(teal_report(), { + a <- 1L + b <- 2L + c <- 3L + }) + testthat::expect_equal( + teal_card(q), + c( + teal_card(), + code_chunk("a <- 1L"), + code_chunk("b <- 2L"), + code_chunk("c <- 3L") + ), + ignore_attr = "names" + ) + }) +}) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index a74f3787c..5f8df4671 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -39,3 +39,22 @@ testthat::test_that("split_text_block - splits text block into blocks no longer result <- split_text_block(block_text, n) testthat::expect_equal(result, list(block_text)) }) + +testthat::describe("format.code_chunk", { + it("generates the corresponding R language chunk", { + chunk_str <- format(code_chunk("1+1", lang = "R")) + testthat::expect_match(chunk_str, "^```\\{R\\}.*```$") + }) + it("generates the corresponding yaml language chunk", { + chunk_str <- format(code_chunk("1+1", lang = "yaml")) + testthat::expect_match(chunk_str, "^```yaml.*```$") + }) + it("generates the corresponding parameters", { + chunk_str <- format(code_chunk("1+1", echo = TRUE)) + testthat::expect_match(chunk_str, "^```\\{R, echo=TRUE\\}.*```$") + }) + it("generates the corresponding multiple parameters", { + chunk_str <- format(code_chunk("1+1", echo = TRUE, another = "\"param\"")) + testthat::expect_match(chunk_str, "^```\\{R, echo=TRUE, another=\\\"param\\\"\\}.*```$") + }) +}) diff --git a/tests/testthat/test-yaml_utils.R b/tests/testthat/test-yaml_utils.R deleted file mode 100644 index ce700ae9e..000000000 --- a/tests/testthat/test-yaml_utils.R +++ /dev/null @@ -1,147 +0,0 @@ -testthat::test_that("yaml_quoted adds the `quoted` attribute equal to `TRUE`", { - object <- "test" - yaml_quoted_object <- yaml_quoted(object) - testthat::expect_equal(attr(yaml_quoted_object, "quoted"), TRUE) -}) - -testthat::test_that("yaml_quoted does not modify the value of the object", { - object <- "test" - yaml_quoted_object <- yaml_quoted(object) - testthat::expect_equivalent(object, yaml_quoted_object) -}) - - -testthat::test_that("conv_str_logi - accept only a string", { - testthat::expect_error(conv_str_logi(2)) - testthat::expect_no_error(conv_str_logi("string")) -}) - -testthat::test_that("conv_str_logi - not influence the regular character", { - testthat::expect_identical(conv_str_logi("sth"), "sth") -}) - -testthat::test_that("conv_str_logi - character TRUE to logical", { - testthat::expect_true(isTRUE(conv_str_logi("TRUE"))) - testthat::expect_true(isTRUE(conv_str_logi("true"))) - testthat::expect_true(isTRUE(conv_str_logi("True"))) - testthat::expect_true(isTRUE(conv_str_logi("yes"))) - testthat::expect_true(isTRUE(conv_str_logi("y"))) - testthat::expect_true(isTRUE(conv_str_logi("Y"))) - testthat::expect_true(isTRUE(conv_str_logi("on"))) -}) - -testthat::test_that("conv_str_logi - character FALSE to logical", { - testthat::expect_true(isFALSE(conv_str_logi("FALSE"))) - testthat::expect_true(isFALSE(conv_str_logi("false"))) - testthat::expect_true(isFALSE(conv_str_logi("False"))) - testthat::expect_true(isFALSE(conv_str_logi("no"))) - testthat::expect_true(isFALSE(conv_str_logi("n"))) - testthat::expect_true(isFALSE(conv_str_logi("N"))) - testthat::expect_true(isFALSE(conv_str_logi("off"))) -}) - - -testthat::test_that("rmd_outputs - all returned out in the rmarkdown namespace", { - testthat::expect_true(all(rmd_outputs() %in% ls(asNamespace("rmarkdown")))) -}) - -testthat::test_that("rmd_output_arguments - accepts only string from possible rmarkdown outputs", { - testthat::expect_error(rmd_output_arguments("random_text")) - testthat::expect_no_error(rmd_output_arguments("pdf_document")) - testthat::expect_no_error(rmd_output_arguments("pdf_document", TRUE)) -}) - -testthat::test_that("rmd_output_arguments - returned all pdf_document arguments", { - testthat::expect_identical( - rmd_output_arguments("pdf_document"), - names(formals(asNamespace("rmarkdown")[["pdf_document"]])) - ) -}) - -testthat::test_that("rmd_output_arguments - returned all pdf_document arguments and their defaults", { - testthat::expect_identical( - rmd_output_arguments("pdf_document", TRUE), - formals(asNamespace("rmarkdown")[["pdf_document"]]) - ) -}) - -testthat::test_that("as_yaml_auto - accept a named list (optionally nested)", { - testthat::expect_error(as_yaml_auto(list(1))) - testthat::expect_error(as_yaml_auto("sth")) - - testthat::expect_no_error(as_yaml_auto(list(author = "", output = list(pdf_document = list(toc = TRUE))))) - testthat::expect_no_error(as_yaml_auto(list(author = "", output = "pdf_document", toc = TRUE, keep_tex = TRUE))) -}) - -testthat::test_that("as_yaml_auto - works the same as yaml::as.yaml for a nested list when as_header is FALSE", { - testthat::expect_identical( - as_yaml_auto(list(author = "", output = list(pdf_document = list(toc = TRUE))), as_header = FALSE), - structure(yaml::as.yaml(list(author = "", output = list(pdf_document = list(toc = TRUE)))), - class = "rmd_yaml_header" - ) - ) -}) - -input_list <- list(author = "", output = "pdf_document", toc = TRUE, keep_tex = TRUE, date = as.Date("2022-04-29")) - -testthat::test_that("as_yaml_auto - parse", { - testthat::expect_identical( - as_yaml_auto(input_list), - structure( - "---\nauthor: ''\ndate: '2022-04-29'\noutput:\n pdf_document:\n toc: yes\n keep_tex: yes\n---\n", - class = "rmd_yaml_header" - ) - ) -}) - -testthat::test_that("as_yaml_auto - warning for not accepted argument and skip it", { - testthat::expect_warning(testthat::expect_identical( - as_yaml_auto(list(author = "", output = "pdf_document", toc = TRUE, keep_tex = TRUE, wrong = 2)), - structure( - "---\nauthor: ''\noutput:\n pdf_document:\n toc: yes\n keep_tex: yes\n---\n", - class = "rmd_yaml_header" - ) - )) -}) - -testthat::test_that("as_yaml_auto - silent the warning for not accepted argument and skip it", { - testthat::expect_identical( - as_yaml_auto(list(author = "", output = "pdf_document", toc = TRUE, keep_tex = TRUE, wrong = 2), silent = TRUE), - structure("---\nauthor: ''\noutput:\n pdf_document:\n toc: yes\n keep_tex: yes\n---\n", - class = "rmd_yaml_header" - ) - ) -}) - -testthat::test_that("as_yaml_auto - convert character logical to logical", { - testthat::expect_identical( - as_yaml_auto(list(author = "", output = "pdf_document", toc = TRUE, keep_tex = "True"), silent = TRUE), - structure("---\nauthor: ''\noutput:\n pdf_document:\n toc: yes\n keep_tex: yes\n---\n", - class = "rmd_yaml_header" - ) - ) -}) - - -testthat::test_that("as_yaml_auto - do not accept multi outputs without the multi_output argument", { - testthat::expect_error( - as_yaml_auto(list(author = "", output = "pdf_document", output = "html_document", toc = TRUE, keep_tex = TRUE), - silent = TRUE - ) - ) -}) - -testthat::test_that("as_yaml_auto - accept multi outputs with the multi_output argument", { - testthat::expect_no_error( - as_yaml_auto(list(author = "", output = "pdf_document", output = "html_document", toc = TRUE, keep_tex = TRUE), - silent = TRUE, multi_output = TRUE - ) - ) -}) - -testthat::test_that("get_yaml_field returns the correct result", { - yaml_text <- "---\nauthor: ''\ndate: '2022-04-29'\noutput:\n pdf_document:\n toc: yes\n keep_tex: yes\n---\n" - field_name <- "output" - result <- get_yaml_field(yaml_text, field_name) - testthat::expect_equal(result, "pdf_document") -}) diff --git a/vignettes/teal-report-class.Rmd b/vignettes/teal-report-class.Rmd new file mode 100644 index 000000000..1f077ab36 --- /dev/null +++ b/vignettes/teal-report-class.Rmd @@ -0,0 +1,127 @@ +--- +title: "teal_report Class" +author: "NEST CoreDev" +output: + rmarkdown::html_vignette: + toc: true +vignette: > + %\VignetteIndexEntry{teal_report Class} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +## Introduction + +The `teal_report` class in `teal.reporter` provides a way to create reproducible documents step by step by adding markdown content alongside code chunks evaluation. + +The `teal_report` class is built on top of [`teal_data`](https://insightsengineering.github.io/teal.data/latest-tag/articles/teal-data.html), inheriting all its reproducibility and code-tracking capabilities while adding reporting-specific functionality through `teal_card()`. + +This vignette shows you how to build `teal_report` object, add and remove its content. + +## Creating a teal_report + +A `teal_report` is an object where developers can add, edit and remove various content (e.g. markdown content, plots, tables), add and evaluate code chunks. It provides a framework for building reproducible reports by combining content management with automatic code tracking. + +To ensure complete reproducibility, it's recommended to start with an empty `teal_report` and build up your data and analysis using `eval_code()`: + +```{r basic-usage} +library(teal.reporter) +report <- teal_report() +``` + +## Adding content to the `teal_report` + +### Adding arbitrary markdown content + +Think of a `teal_report` as a list Rmarkdown elements built and evaluated step by step. Use `teal_card(report)` to access and change elements of the document. +To add a new element in the `teal_card` one can use `c` method. + +```{r} +teal_card(report) <- c( + teal_card(report), + "## Document section", + "Lorem ipsum dolor sit amet" +) + +teal_card(report) +``` + +### Adding reproducible code chunks + +`teal_report` inherits all methods from `teal_data`. The class supports `within()` and `teal.code::eval_code()`, which execute arbitrary code in its environment. Consider this as executing a code chunk in a Rmarkdown document. +In the same time you can access objects created during code execution. + +```{r} +report <- within(report, { + a <- 2 +}) +report$a +teal_card(report) +``` + +In the above chunk of code `a` is created but nothing has been output to the console nor to the graphic devices. In case one decides to print or plot `teal_report` automatically captures outputs, which can be retrieved using `teal.code::get_outputs()`. + +```{r} +report <- within(report, { + head_of_iris <- head(iris) + head_of_iris +}) + +teal.code::get_outputs(report) # returns a list of all outputs +``` + +## Modify `teal_report` content + +`teal_report` allows to modify its content. Depending on the needs, one can add, remove and replace element in the same way as one modifies a list. + +```{r} +# adding element in the beginnning of the document +teal_card(report) <- append(teal_card(report), "# My report", after = 0) + +# removing code_chunk(s) +teal_card(report) <- Filter( + function(x) !inherits(x, "code_chunk"), + teal_card(report) +) + +# replace an element +teal_card(report)[[1]] <- "# My report (replaced)" + +teal_card(report) +``` + +### Document metadata + +In Rmarkdown it is possible specify certain parameters as a YAML header. `teal_report` allows to specify metadata using +`metadata()`. + +```{r} +metadata(teal_card(report)) <- list( + title = "My Document", + author = "NEST" +) +``` + +## Output teal_report + +`teal_report` supports several output formats. `render` for `teal_report` utilizes `rmarkdown::render` so it supports the same [output formats](https://pkgs.rstudio.com/rmarkdown/reference/index.html#output-formats) and arguments. + +```{r eval=FALSE} +render(report, output_format = rmarkdown::pdf_document(), global_knitr = list(fig.width = 10)) +``` + +## Key Benefits + +Using `teal_report` in your modules provides several advantages: + +1. **Reproducibility**: All code is automatically captured via the underlying `teal_data` infrastructure +2. **Consistency**: Standardized way to create reports across modules +3. **Flexibility**: Easy to add different types of content to reports +4. **Integration**: Works seamlessly with the teal reporter infrastructure +5. **Code Tracking**: Inherited `eval_code()` functionality ensures all computations are reproducible + +## Further Reading + +For more details on the underlying `teal_data` functionality, see the [Introduction to teal.data](https://insightsengineering.github.io/teal.data/latest-tag/articles/teal-data.html). + +For more information on the `teal_report` class usage in `teal`, see the [Managing Reproducible Report Documents in teal](https://insightsengineering.github.io/teal/latest-tag/articles/managing-reproducible-report-documents-in-teal.html). diff --git a/vignettes/teal-reporter-blocks-overview.Rmd b/vignettes/teal-reporter-blocks-overview.Rmd index 0fbd1b2a0..e37668bdc 100644 --- a/vignettes/teal-reporter-blocks-overview.Rmd +++ b/vignettes/teal-reporter-blocks-overview.Rmd @@ -70,7 +70,6 @@ classDiagram FileBlock <|-- PictureBlock FileBlock <|-- TableBlock - namespace Blocks { class ContentBlock class FileBlock @@ -93,7 +92,6 @@ style ReportCard fill:lightblue ) ``` - ## Global `knitr` Options To ensure consistency and control over the rendering of markdown elements within reports, teal.reporter adheres to the following default global `knitr` options: