merge back from main

Merge branch 'main' into 169_wrap_rcode@main

# Conflicts:
#	R/Renderer.R

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: teal.reporter
 Title: Reporting Tools for 'shiny' Modules
-Version: 0.2.1.9004
-Date: 2023-09-28
+Version: 0.2.1.9005
+Date: 2023-09-29
 Authors@R: c(
     person("Dawid", "Kaledkowski", , "[email protected]", role = "cre"),
     person("Maciej", "Nasinski", role = "aut"),

NEWS.md

@@ -1,4 +1,4 @@
-# teal.reporter 0.2.1.9004
+# teal.reporter 0.2.1.9005
 
 * Supports automatic `Rcode` formatting using the suggested `formatR` package in reports.
 

R/DownloadModule.R

@@ -34,13 +34,13 @@ download_report_button_ui <- function(id) {
 #' @param id `character(1)` this `shiny` module's id.
 #' @param reporter [`Reporter`] instance.
 #' @param global_knitr `list` a global `knitr` parameters for customizing the rendering process.
-#' Defaults to `list(echo = TRUE, tidy.opts = list(width.cutoff = 60), tidy = TRUE)`.
+#' Defaults to `list(echo = TRUE, tidy.opts = list(width.cutoff = 60), tidy = FALSE)`.
 #' @inheritParams reporter_download_inputs
 #' @return `shiny::moduleServer`
 #' @export
 download_report_button_srv <- function(id,
                                        reporter,
-                                       global_knitr = list(echo = TRUE, tidy.opts = list(width.cutoff = 60), tidy = TRUE),
+                                       global_knitr = list(echo = TRUE, tidy.opts = list(width.cutoff = 60), tidy = FALSE),
                                        rmd_output = c(
                                          "html" = "html_document", "pdf" = "pdf_document",
                                          "powerpoint" = "powerpoint_presentation", "word" = "word_document"

R/Previewer.R

@@ -32,12 +32,12 @@ reporter_previewer_ui <- function(id) {
 #' @param id `character(1)` this `shiny` module's id.
 #' @param reporter `Reporter` instance
 #' @param global_knitr `list` a global `knitr` parameters for customizing the rendering process.
-#' Defaults to `list(echo = TRUE, tidy.opts = list(width.cutoff = 60), tidy = TRUE)`.
+#' Defaults to `list(echo = TRUE, tidy.opts = list(width.cutoff = 60), tidy = FALSE)`.
 #' @inheritParams reporter_download_inputs
 #' @export
 reporter_previewer_srv <- function(id,
                                    reporter,
-                                   global_knitr = list(echo = TRUE, tidy.opts = list(width.cutoff = 60), tidy = TRUE),
+                                   global_knitr = list(echo = TRUE, tidy.opts = list(width.cutoff = 60), tidy = FALSE),
                                    rmd_output = c(
                                      "html" = "html_document", "pdf" = "pdf_document",
                                      "powerpoint" = "powerpoint_presentation",

R/Renderer.R

@@ -28,7 +28,7 @@ Renderer <- R6::R6Class( # nolint: object_name_linter.
     #' Defaults to empty `list()`.
     #'
     #' @return `character` a `Rmd` text (`yaml` header + body), ready to be rendered.
-    renderRmd = function(blocks, yaml_header, global_knitr = list(echo = TRUE, tidy.opts = list(width.cutoff = 60), tidy = TRUE)) {
+    renderRmd = function(blocks, yaml_header, global_knitr = list(echo = TRUE, tidy.opts = list(width.cutoff = 60), tidy = FALSE)) {
       checkmate::assert_list(blocks, c("TextBlock", "PictureBlock", "NewpageBlock", "TableBlock", "RcodeBlock"))
       checkmate::assert_list(global_knitr)
 
@@ -40,13 +40,40 @@ Renderer <- R6::R6Class( # nolint: object_name_linter.
       if (missing(yaml_header)) {
         yaml_header <- md_header(yaml::as.yaml(list(title = "Report")))
       }
-      parsed_yaml <- yaml_header
-      if (!requireNamespace("formatR", quietly = TRUE)) {
+      if (requireNamespace("formatR", quietly = TRUE)) {
+        global_knitr[["tidy"]] <- TRUE
+      } else {
         message("For better code formatting, consider installing the formatR package.")
       }
+
+      private$report_type <- get_yaml_field(yaml_header, "output")
+      format_code_block_function <- paste0(
+        c(
+          "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",
+          "}"
+        ),
+        collapse = "\n"
+      )
+
       parsed_global_knitr <- sprintf(
-        "\n```{r setup, include=FALSE}\nknitr::opts_chunk$set(%s)\n```\n",
-        capture.output(dput(global_knitr))
+        "\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
+        } else {
+          ""
+        }
       )
 
       parsed_blocks <- paste(
@@ -56,7 +83,7 @@ Renderer <- R6::R6Class( # nolint: object_name_linter.
         collapse = "\n\n"
       )
 
-      rmd_text <- paste0(parsed_yaml, "\n", parsed_global_knitr, "\n", parsed_blocks, "\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,
@@ -70,11 +97,11 @@ Renderer <- R6::R6Class( # nolint: object_name_linter.
     #' @param blocks `list` of `c("TextBlock", "PictureBlock", "NewpageBlock")` objects.
     #' @param yaml_header `character` an `rmarkdown` `yaml` header.
     #' @param global_knitr `list` a global `knitr` parameters for customizing the rendering process.
-    #' Defaults to `list(echo = TRUE, tidy.opts = list(width.cutoff = 60), tidy = TRUE)`.
+    #' Defaults to `list(echo = TRUE, tidy.opts = list(width.cutoff = 60), tidy = FALSE)`.
     #' @param ... `rmarkdown::render` arguments, `input` and `output_dir` should not be updated.z
     #'
     #' @return `character` path to the output
-    render = function(blocks, yaml_header, global_knitr = list(echo = TRUE, tidy.opts = list(width.cutoff = 60), tidy = TRUE), ...) {
+    render = function(blocks, yaml_header, global_knitr = list(echo = TRUE, tidy.opts = list(width.cutoff = 60), tidy = FALSE), ...) {
       args <- list(...)
       input_path <- self$renderRmd(blocks, yaml_header, global_knitr)
       args <- append(args, list(
@@ -97,6 +124,7 @@ Renderer <- R6::R6Class( # nolint: object_name_linter.
   ),
   private = list(
     output_dir = character(0),
+    report_type = NULL,
     # factory method
     block2md = function(block) {
       if (inherits(block, "TextBlock")) {
@@ -128,18 +156,22 @@ Renderer <- R6::R6Class( # nolint: object_name_linter.
     rcodeBlock2md = function(block) {
       params <- block$get_params()
       params <- lapply(params, function(l) if (is.character(l)) shQuote(l) else l)
-      block_content <- block$get_content()
-      paste(
-        sep = "\n",
-        collapse = "\n",
-        "### ",
+      if (identical(private$report_type, "powerpoint_presentation")) {
+        block_content_list <- split_text_block(block$get_content(), 30)
+        paste(
+          sprintf(
+            "---\n\n```{r, echo=FALSE}\ncode_block(\n%s)\n```\n",
+            shQuote(block_content_list, type = "cmd")
+          ),
+          collapse = "\n\n"
+        )
+      } else {
         sprintf(
-          "```{r, %s}", paste(names(params), params, sep = "=", collapse = ", ")
-        ),
-        block_content,
-        "```",
-        ""
-      )
+          "--- \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())

R/SimpleReporter.R

@@ -47,14 +47,14 @@ simple_reporter_ui <- function(id) {
 #' @param card_fun `function` which returns a [`ReportCard`] instance,
 #' the function has a `card` argument and an optional `comment` argument.
 #' @param global_knitr `list` a global `knitr` parameters for customizing the rendering process.
-#' Defaults to `list(echo = TRUE, tidy.opts = list(width.cutoff = 60), tidy = TRUE)`.
+#' Defaults to `list(echo = TRUE, tidy.opts = list(width.cutoff = 60), tidy = FALSE)`.
 #' @inheritParams reporter_download_inputs
 #' @return `shiny::moduleServer`
 #' @export
 simple_reporter_srv <- function(id,
                                 reporter,
                                 card_fun,
-                                global_knitr = list(echo = TRUE, tidy.opts = list(width.cutoff = 60), tidy = TRUE),
+                                global_knitr = list(echo = TRUE, tidy.opts = list(width.cutoff = 60), tidy = FALSE),
                                 rmd_output = c(
                                   "html" = "html_document", "pdf" = "pdf_document",
                                   "powerpoint" = "powerpoint_presentation", "word" = "word_document"

R/utils.R

@@ -115,7 +115,7 @@ panel_item <- function(title, ..., collapsed = TRUE, input_id = NULL) {
 #' Indent the row names by 10 times indentation
 #'
 #' @param content Supported formats: `data.frame`, `rtables`, `TableTree`, `ElementaryTable`, `listing_df`
-
+#'
 #' @return (`flextable`)
 #'
 #' @keywords internal
@@ -185,6 +185,7 @@ to_flextable <- function(content) {
 #'
 #' @keywords internal
 custom_theme <- function(ft) {
+  checkmate::assert_class(ft, "flextable")
   ft <- flextable::fontsize(ft, size = 8, part = "body")
   ft <- flextable::bold(ft, part = "header")
   ft <- flextable::theme_booktabs(ft)
@@ -247,3 +248,32 @@ padding_lst <- function(ft, indents) {
     flextable::padding(ft, s, 1, padding.left = (indents[s] + 1) * 10)
   }, seq_len(length(indents)), ft)
 }
+
+#' Split a text block into smaller blocks with a specified number of lines.
+#'
+#' Divide text block into smaller blocks.
+#'
+#' A single character string containing a text block of multiple lines (separated by `\n`)
+#' is split into multiple strings with n or less lines each.
+#'
+#' @param block_text `character` string containing the input block of text
+#' @param n `integer` number of lines per block
+#'
+#' @return
+#' List of character strings with up to `n` lines in each element.
+#'
+#' @keywords internal
+split_text_block <- function(x, n) {
+  checkmate::assert_string(x)
+  checkmate::assert_integerish(n, lower = 1L, len = 1L)
+
+  lines <- strsplit(x, "\n")[[1]]
+
+  if (length(lines) <= n) {
+    return(list(x))
+  }
+
+  nblocks <- ceiling(length(lines) / n)
+  ind <- rep(1:nblocks, each = n)[seq_along(lines)]
+  unname(lapply(split(lines, ind), paste, collapse = "\n"))
+}

R/yaml_utils.R

@@ -238,3 +238,26 @@ as_yaml_auto <- function(input_list,
 print.rmd_yaml_header <- function(x, ...) {
   cat(x, ...)
 }
+
+#' Parses `yaml` text, extracting the specified field. Returns list names if it's a list;
+#' otherwise, the field itself.
+#'
+#' @param yaml_text A character vector containing the `yaml` text.
+#' @param field_name 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
+}