185 fixing table formatting in PPT outputs

.pre-commit-config.yaml

@@ -26,6 +26,7 @@ repos:
           - shinyWidgets
           - yaml
           - zip
+          - flextable
       - id: spell-check
         name: Check spelling with `spelling`
         exclude: >

DESCRIPTION

@@ -27,7 +27,8 @@ Imports:
     shiny (>= 1.6.0),
     shinyWidgets (>= 0.5.1),
     yaml (>= 1.1.0),
-    zip (>= 1.1.0)
+    zip (>= 1.1.0),
+    flextable (>= 0.9.2)
 Suggests:
     DT (>= 0.13),
     ggplot2 (>= 3.4.0),
@@ -43,9 +44,9 @@ RdMacros:
 Config/Needs/verdepcheck: rstudio/bslib, mllg/checkmate,
     rstudio/htmltools, yihui/knitr, r-lib/lifecycle, r-lib/R6,
     rstudio/rmarkdown, rstudio/shiny, dreamRs/shinyWidgets,
-    yaml=vubiostat/r-yaml, r-lib/zip, rstudio/DT, tidyverse/ggplot2,
-    deepayan/lattice, cran/png, insightsengineering/rtables,
-    r-lib/testthat, rstudio/tinytex
+    yaml=vubiostat/r-yaml, r-lib/zip, davidgohel/flextable, 
+    rstudio/DT, tidyverse/ggplot2, deepayan/lattice, cran/png,
+    insightsengineering/rtables, r-lib/testthat, rstudio/tinytex
 Config/Needs/website: insightsengineering/nesttemplate
 Encoding: UTF-8
 Language: en-US

NEWS.md

@@ -5,6 +5,7 @@
 ### Miscellaneous
 
 * Specify minimal version of dependent packages.
+* Updated `TableBlock` to convert tables into `flextables` to show in rendered report.
 * Fixed CRAN requirements for the first CRAN submission.
 * Removed manual pages for non-exported objects.
 

R/Previewer.R

@@ -208,7 +208,7 @@ block_to_html <- function(b) {
   } else if (inherits(b, "TableBlock")) {
     b_table <- readRDS(b_content)
     shiny::tags$pre(
-      paste(utils::capture.output(print(b_table)), collapse = "\n")
+      flextable::htmltools_value(b_table)
     )
   } else if (inherits(b, "NewpageBlock")) {
     shiny::tags$br()

R/Renderer.R

@@ -38,6 +38,7 @@ Renderer <- R6::R6Class( # nolint: object_name_linter.
         "\n```{r setup, include=FALSE}\nknitr::opts_chunk$set(%s)\n```\n",
         capture.output(dput(global_knitr))
       )
+
       parsed_blocks <- paste(
         unlist(
           lapply(blocks, function(b) private$block2md(b))
@@ -119,10 +120,16 @@ Renderer <- R6::R6Class( # nolint: object_name_linter.
       params <- block$get_params()
       params <- lapply(params, function(l) if (is.character(l)) shQuote(l) else l)
       block_content <- block$get_content()
-      sprintf(
-        "\n```{r, %s}\n%s\n```\n",
-        paste(names(params), params, sep = "=", collapse = ", "),
-        block_content
+      paste(
+        sep = "\n",
+        collapse = "\n",
+        "### ",
+        sprintf(
+          "```{r, %s}", paste(names(params), params, sep = "=", collapse = ", ")
+        ),
+        block_content,
+        "```",
+        ""
       )
     },
     pictureBlock2md = function(block) {

R/TableBlock.R

@@ -24,6 +24,7 @@ TableBlock <- R6::R6Class( # nolint: object_name_linter.
     #' @return invisibly self
     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)

R/utils.R

@@ -109,3 +109,124 @@ panel_item <- function(title, ..., collapsed = TRUE, input_id = NULL) {
     )
   })
 }
+
+#' Convert content into a `flextable`, merge cells with `colspan` > 1
+#' align columns to the center, and row names to the left
+#' Indent the row names by 10 times indentation
+#'
+#' @param content Supported formats: `data.frame`, `rtables`, `TableTree`, `ElementaryTable`
+
+#' @return (`flextable`)
+#'
+#' @keywords internal
+to_flextable <- function(content) {
+  if (inherits(content, c("rtables", "TableTree", "ElementaryTable"))) {
+    mf <- rtables::matrix_form(content)
+    nr_header <- attr(mf, "nrow_header")
+    non_total_coln <- c(TRUE, !grepl("All Patients", names(content)))
+    df <- as.data.frame(mf$strings[seq(nr_header + 1, nrow(mf$strings)), , drop = FALSE])
+    header_df <- as.data.frame(mf$strings[seq_len(nr_header), , drop = FALSE])
+
+    ft <- flextable::flextable(df)
+    ft <- flextable::delete_part(ft, part = "header")
+    ft <- flextable::add_header(ft, values = header_df)
+
+    merge_index_body <- get_merge_index(mf$spans[seq(nr_header + 1, nrow(mf$spans)), , drop = FALSE])
+    merge_index_header <- get_merge_index(mf$spans[seq_len(nr_header), , drop = FALSE])
+
+    ft <- merge_at_indice(ft, lst = merge_index_body, part = "body")
+    ft <- merge_at_indice(ft, lst = merge_index_header, part = "header")
+    ft <- flextable::align_text_col(ft, align = "center", header = TRUE)
+    ft <- flextable::align(ft, i = seq_len(nrow(content)), j = 1, align = "left")
+    ft <- padding_lst(ft, mf$row_info$indent)
+    ft <- flextable::padding(ft, padding.top = 1, padding.bottom = 1, part = "all")
+    ft <- flextable::autofit(ft, add_h = 0)
+
+    width_vector <- c(
+      dim(ft)$widths[1],
+      rep(sum(dim(ft)$widths[-1]), length(dim(ft)$widths) - 1) / (ncol(mf$strings) - 1)
+    )
+    ft <- flextable::width(ft, width = width_vector)
+  } else if (inherits(content, "data.frame")) {
+    ft <- flextable::flextable(content)
+  } else {
+    stop(paste0("Unsupported class `(", format(class(content)), ")` when exporting table"))
+  }
+
+  ft <- custom_theme(ft)
+  if (flextable::flextable_dim(ft)$widths > 10) {
+    pgwidth <- 10.5
+    width_vector <- dim(ft)$widths * pgwidth / flextable::flextable_dim(ft)$widths
+    ft <- flextable::width(ft, width = width_vector)
+  }
+
+  ft
+}
+
+#' Apply a custom theme to a `flextable`
+#' @noRd
+#'
+#' @keywords internal
+custom_theme <- function(ft) {
+  ft <- flextable::fontsize(ft, size = 8, part = "body")
+  ft <- flextable::bold(ft, part = "header")
+  ft <- flextable::theme_booktabs(ft)
+  ft <- flextable::hline(ft, border = flextable::fp_border_default(width = 1, color = "grey"))
+  ft <- flextable::border_outer(ft)
+  ft
+}
+
+#' Get the merge index for a single span.
+#' This function retrieves the merge index for a single span,
+#' which is used in merging cells.
+#' @noRd
+#'
+#' @keywords internal
+get_merge_index_single <- function(span) {
+  ret <- list()
+  j <- 1
+  while (j < length(span)) {
+    if (span[j] != 1) {
+      ret <- c(ret, list(seq(j, j + span[j] - 1)))
+    }
+    j <- j + span[j]
+  }
+  return(ret)
+}
+
+#' Get the merge index for multiple spans.
+#' This function merges cells in a `flextable` at specified row and column indices.
+#' @noRd
+#'
+#' @keywords internal
+get_merge_index <- function(spans) {
+  ret <- lapply(seq_len(nrow(spans)), function(i) {
+    ri <- spans[i, ]
+    r <- get_merge_index_single(ri)
+    lapply(r, function(s) {
+      list(j = s, i = i)
+    })
+  })
+  unlist(ret, recursive = FALSE, use.names = FALSE)
+}
+
+#' Merge cells in a `flextable` at specified indices
+#' @noRd
+#'
+#' @keywords internal
+merge_at_indice <- function(ft, lst, part) {
+  Reduce(function(ft, ij) {
+    flextable::merge_at(ft, i = ij$i, j = ij$j, part = part)
+  }, lst, ft)
+}
+
+#' Apply padding to a `flextable` based on indentation levels.
+#' This function applies padding to a `flextable` based on indentation levels provided as a vector.
+#' @noRd
+#'
+#' @keywords internal
+padding_lst <- function(ft, indents) {
+  Reduce(function(ft, s) {
+    flextable::padding(ft, s, 1, padding.left = (indents[s] + 1) * 10)
+  }, seq_len(length(indents)), ft)
+}

tests/testthat/test-utils.R

@@ -5,3 +5,49 @@ testthat::test_that("get_bs_version", {
 testthat::test_that("panel_item", {
   testthat::expect_s3_class(panel_item("LABEL", shiny::tags$div()), "shiny.tag")
 })
+
+testthat::test_that("Test to_flextable: supported class", {
+  data_frame <- data.frame(A = 1:3, B = 4:6)
+  flextable_output <- to_flextable(data_frame)
+  testthat::expect_s3_class(flextable_output, "flextable")
+})
+
+testthat::test_that("Test to_flextable: unsupported class", {
+  unsupported_data <- list(a = 1, b = 2)
+  expect_error(to_flextable(unsupported_data), "Unsupported class")
+})
+
+test_that("custom theme to flextable", {
+  sample_ft <- flextable::qflextable(head(mtcars))
+  themed_ft <- custom_theme(sample_ft)
+  expect_is(themed_ft, "flextable")
+})
+
+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")
+})
+
+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")
+})
+
+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")
+})
+
+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")
+})