diff --git a/.github/workflows/check.yaml b/.github/workflows/check.yaml index 2dd9646c..a1782d4e 100644 --- a/.github/workflows/check.yaml +++ b/.github/workflows/check.yaml @@ -27,6 +27,7 @@ jobs: with: additional-env-vars: | _R_CHECK_CRAN_INCOMING_REMOTE_=false + _R_CHECK_EXAMPLE_TIMING_THRESHOLD_=10 additional-r-cmd-check-params: --as-cran enforce-note-blocklist: true note-blocklist: | diff --git a/R/Renderer.R b/R/Renderer.R index 79831c2a..1ce2be5b 100644 --- a/R/Renderer.R +++ b/R/Renderer.R @@ -33,10 +33,35 @@ 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 + + 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( @@ -46,7 +71,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, @@ -88,6 +113,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")) { @@ -119,18 +145,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()) diff --git a/R/utils.R b/R/utils.R index aaba1d1f..59064a22 100644 --- a/R/utils.R +++ b/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")) +} diff --git a/R/yaml_utils.R b/R/yaml_utils.R index 869c96cc..de19c87c 100644 --- a/R/yaml_utils.R +++ b/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 +} diff --git a/man/get_yaml_field.Rd b/man/get_yaml_field.Rd new file mode 100644 index 00000000..eab2ac67 --- /dev/null +++ b/man/get_yaml_field.Rd @@ -0,0 +1,23 @@ +% 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{Parses \code{yaml} text, extracting the specified field. Returns list names if it's a list; +otherwise, the field itself.} +\usage{ +get_yaml_field(yaml_text, field_name) +} +\arguments{ +\item{yaml_text}{A character vector containing the \code{yaml} text.} + +\item{field_name}{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/split_text_block.Rd b/man/split_text_block.Rd new file mode 100644 index 00000000..42a11461 --- /dev/null +++ b/man/split_text_block.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{split_text_block} +\alias{split_text_block} +\title{Split a text block into smaller blocks with a specified number of lines.} +\usage{ +split_text_block(x, n) +} +\arguments{ +\item{n}{\code{integer} number of lines per block} + +\item{block_text}{\code{character} string containing the input block of text} +} +\value{ +List of character strings with up to \code{n} lines in each element. +} +\description{ +Divide text block into smaller blocks. +} +\details{ +A single character string containing a text block of multiple lines (separated by \verb{\\n}) +is split into multiple strings with n or less lines each. +} +\keyword{internal} diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index b8306850..b2c47f7b 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -17,37 +17,51 @@ testthat::test_that("to_flextable: unsupported class", { expect_error(to_flextable(unsupported_data), "Unsupported class") }) -test_that("custom_theme to flextable", { +testthat::test_that("custom_theme to flextable", { sample_ft <- flextable::qflextable(head(mtcars)) themed_ft <- custom_theme(sample_ft) - expect_is(themed_ft, "flextable") + testthat::expect_is(themed_ft, "flextable") }) -test_that("get_merge_index_single", { +testthat::test_that("get_merge_index_single", { sample_span <- c(1, 2, 1, 3) merge_index <- get_merge_index_single(sample_span) - expect_is(merge_index, "list") + testthat::expect_is(merge_index, "list") }) -test_that("get_merge_index", { +testthat::test_that("get_merge_index", { sample_spans <- matrix(c(1, 2, 1, 3, 2, 1, 1, 1), ncol = 2) merge_index <- get_merge_index(sample_spans) - expect_is(merge_index, "list") + testthat::expect_is(merge_index, "list") }) -test_that("merge_at_indice", { +testthat::test_that("merge_at_indice", { sample_ft <- flextable::qflextable(head(mtcars)) merge_indices <- list( list(i = 1, j = 1:2), list(i = 2, j = 3:4) ) merged_ft <- merge_at_indice(sample_ft, lst = merge_indices, part = "body") - expect_is(merged_ft, "flextable") + testthat::expect_is(merged_ft, "flextable") }) -test_that("padding_lst applies padding to a flextable based on indentation levels", { +testthat::test_that("padding_lst applies padding to a flextable based on indentation levels", { sample_ft <- flextable::qflextable(head(mtcars)) sample_indents <- c(1, 2, 1, 3, 2) padded_ft <- padding_lst(sample_ft, sample_indents) - expect_is(padded_ft, "flextable") + testthat::expect_is(padded_ft, "flextable") +}) + + +testthat::test_that("split_text_block - splits text block into blocks no longer than n lines", { + l <- 5 + block_text <- paste(paste(rep("Line", l), seq_len(l)), collapse = "\n") + n <- 2 + result <- split_text_block(block_text, n) + result_lines <- lapply(result, function(x) strsplit(x, "\n")[[1]]) + lapply(result_lines, function(x) testthat::expect_lte(length(x), n)) + + n <- 5 + result <- split_text_block(block_text, n) + testthat::expect_equal(result, list(block_text)) }) diff --git a/tests/testthat/test-yaml_utils.R b/tests/testthat/test-yaml_utils.R index e831e862..f337dc0c 100644 --- a/tests/testthat/test-yaml_utils.R +++ b/tests/testthat/test-yaml_utils.R @@ -139,3 +139,10 @@ testthat::test_that("as_yaml_auto - accept multi outputs with the multi_output a NA ) }) + +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") +})