use rtables pkg function for generating report

.github/workflows/check.yaml

@@ -27,7 +27,7 @@ jobs:
     with:
       additional-env-vars: |
         _R_CHECK_CRAN_INCOMING_REMOTE_=false
-        _R_CHECK_EXAMPLE_TIMING_THRESHOLD_=10
+        _R_CHECK_EXAMPLE_TIMING_THRESHOLD_=11
       additional-r-cmd-check-params: --as-cran
       enforce-note-blocklist: true
       note-blocklist: |

DESCRIPTION

@@ -30,7 +30,9 @@ Imports:
     knitr (>= 1.34),
     lifecycle (>= 0.2.0),
     R6,
+    rlistings (>= 0.2.8),
     rmarkdown (>= 2.19),
+    rtables (>= 0.5.1),
     shiny (>= 1.6.0),
     shinybusy (>= 0.3.2),
     shinyWidgets (>= 0.5.1),
@@ -39,24 +41,24 @@ Imports:
 Suggests:
     DT (>= 0.13),
     formatR (>= 1.5),
+    formatters,
     ggplot2 (>= 3.4.0),
-    lattice (>= 0.18-4),
     png,
-    rtables (>= 0.5.1),
+    lattice (>= 0.18-4),
     testthat (>= 3.1.5),
     tinytex,
     withr (>= 2.0.0)
 VignetteBuilder:
     knitr
 RdMacros:
     lifecycle
-Config/Needs/verdepcheck: rstudio/bslib, mllg/checkmate,
-    davidgohel/flextable, rstudio/htmltools, yihui/knitr, r-lib/lifecycle,
-    r-lib/R6, rstudio/rmarkdown, rstudio/shiny, dreamRs/shinybusy,
-    dreamRs/shinyWidgets, yaml=vubiostat/r-yaml, r-lib/zip, rstudio/DT,
-    yihui/formatR, tidyverse/ggplot2, deepayan/lattice, cran/png,
-    insightsengineering/rtables, r-lib/testthat, rstudio/tinytex,
-    r-lib/withr
+Config/Needs/verdepcheck: rstudio/bslib, mllg/checkmate, 
+    davidgohel/flextable, cran/grid, rstudio/htmltools, yihui/knitr, 
+    r-lib/lifecycle, cran/png, r-lib/R6, insightsengineering/rlistings,
+    rstudio/rmarkdown, insightsengineering/rtables, rstudio/shiny, 
+    dreamRs/shinybusy, dreamRs/shinyWidgets, vubiostat/r-yaml, r-lib/zip,
+    rstudio/DT, yihui/formatR, tidyverse/ggplot2, deepayan/lattice, 
+    r-lib/testthat, rstudio/tinytex, r-lib/withr
 Config/Needs/website: insightsengineering/nesttemplate
 Encoding: UTF-8
 Language: en-US

R/LoadReporterModule.R

@@ -132,7 +132,6 @@ load_json_report <- function(reporter, zip_path, filename) {
         )
       }
     )
-
   } else {
     shiny::showNotification("Failed to load the Reporter file.", type = "error")
   }

R/SimpleReporter.R

@@ -36,9 +36,7 @@ NULL
 
 #' @rdname simple_reporter
 #' @export
-simple_reporter_ui <- function(
-    id
-) {
+simple_reporter_ui <- function(id) {
   ns <- shiny::NS(id)
   shiny::tagList(
     shiny::singleton(
@@ -73,8 +71,7 @@ simple_reporter_srv <- function(
       author = "NEST", title = "Report",
       date = as.character(Sys.Date()), output = "html_document",
       toc = FALSE
-    )
-) {
+    )) {
   shiny::moduleServer(
     id,
     function(input, output, session) {

R/utils.R

@@ -124,76 +124,31 @@ panel_item <- function(title, ..., collapsed = TRUE, input_id = NULL) {
 #'
 #' @keywords internal
 to_flextable <- function(content) {
-  if (inherits(content, c("rtables", "TableTree", "ElementaryTable", "listing_df"))) {
-    mf <- rtables::matrix_form(content)
+  if (inherits(content, c("rtables", "TableTree", "ElementaryTable"))) {
+    ft <- rtables::tt_to_flextable(content)
+  } else if (inherits(content, "listing_df")) {
+    mf <- rlistings::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)
-
-    # Add titles
-    ft <- flextable::set_caption(ft, flextable::as_paragraph(
-      flextable::as_b(mf$main_title), "\n", paste(mf$subtitles, collapse = "\n")
-    ),
-    align_with_table = FALSE
-    )
-
-    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)
-    ft <- custom_theme(ft)
-
-    # Add footers
-    ft <- flextable::add_footer_lines(ft, flextable::as_paragraph(
-      flextable::as_chunk(mf$main_footer, props = flextable::fp_text_default(font.size = 8))
-    ))
-    if (length(mf$main_footer) > 0 && length(mf$prov_footer) > 0) ft <- flextable::add_footer_lines(ft, c("\n"))
-    ft <- flextable::add_footer_lines(ft, flextable::as_paragraph(
-      flextable::as_chunk(mf$prov_footer, props = flextable::fp_text_default(font.size = 8))
-    ))
+    ft <- rtables::df_to_tt(df)
+    if (length(mf$main_title) != 0) {
+      rtables::main_title(ft) <- mf$main_title
+    }
+    rtables::subtitles(ft) <- mf$subtitles
+    rtables::main_footer(ft) <- mf$main_footer
+    rtables::prov_footer(ft) <- mf$prov_footer
+    rtables::header_section_div(ft) <- mf$header_section_div
+    ft <- rtables::tt_to_flextable(ft, total_width = c(grDevices::pdf.options()$width - 1))
   } else if (inherits(content, "data.frame")) {
-    ft <- flextable::flextable(content)
-    ft <- custom_theme(ft)
+    ft <- rtables::tt_to_flextable(
+      rtables::df_to_tt(content)
+    )
   } else {
     stop(paste0("Unsupported class `(", format(class(content)), ")` when exporting table"))
   }
 
-  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) {
-  checkmate::assert_class(ft, "flextable")
-  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
 }
 
@@ -214,40 +169,6 @@ get_merge_index_single <- function(span) {
   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)
-}
-
 #' Divide text block into smaller blocks
 #'
 #' Split a text block into smaller blocks with a specified number of lines.

tests/testthat/test-utils.R

@@ -6,57 +6,31 @@ testthat::test_that("panel_item", {
   testthat::expect_s3_class(panel_item("LABEL", shiny::tags$div()), "shiny.tag")
 })
 
-testthat::test_that("to_flextable: supported class", {
+testthat::test_that("to_flextable: supported class `data.frame`", {
   data_frame <- data.frame(A = 1:3, B = 4:6)
-  # https://github.com/davidgohel/flextable/issues/600
-  withr::with_options(
-    opts_partial_match_old,
-    flextable_output <- to_flextable(data_frame)
-  )
+  flextable_output <- to_flextable(data_frame)
   testthat::expect_s3_class(flextable_output, "flextable")
 })
 
-testthat::test_that("to_flextable: unsupported class", {
-  unsupported_data <- list(a = 1, b = 2)
-  testthat::expect_error(to_flextable(unsupported_data), "Unsupported class")
-})
-
-testthat::test_that("custom_theme to flextable", {
-  sample_ft <- flextable::qflextable(head(mtcars))
-  themed_ft <- custom_theme(sample_ft)
-  testthat::expect_is(themed_ft, "flextable")
-})
-
-testthat::test_that("get_merge_index_single", {
-  sample_span <- c(1, 2, 1, 3)
-  merge_index <- get_merge_index_single(sample_span)
-  testthat::expect_is(merge_index, "list")
-})
-
-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)
-  testthat::expect_is(merge_index, "list")
+testthat::test_that("to_flextable: supported class `rtables`", {
+  tbl <- rtables::basic_table() %>%
+    rtables::analyze("AGE", afun = mean) %>%
+    rtables::build_table(formatters::DM)
+  flextable_output <- to_flextable(tbl)
+  testthat::expect_s3_class(flextable_output, "flextable")
 })
 
-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")
-  testthat::expect_is(merged_ft, "flextable")
+testthat::test_that("to_flextable: supported class `listing_df`", {
+  lsting <- rlistings::as_listing(formatters::ex_adae[1:50, ])
+  flextable_output <- to_flextable(lsting)
+  testthat::expect_s3_class(flextable_output, "flextable")
 })
 
-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)
-  testthat::expect_is(padded_ft, "flextable")
+testthat::test_that("to_flextable: unsupported class", {
+  unsupported_data <- list(a = 1, b = 2)
+  testthat::expect_error(to_flextable(unsupported_data), "Unsupported class")
 })
 
-
 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")