dwww Home | Show directory contents | Find package

context("check borders rendering")

skip_on_cran()
skip_on_ci()

init_flextable_defaults()

library(data.table)
set.seed(2)

USUBJID <- sprintf("01-ABC-%04.0f", 1:200)
VISITS <- c("SCREENING 1", "WEEK 2", "MONTH 3")
LBTEST <- c("Albumin", "Sodium")
VISITNUM <- seq_along(VISITS)
LBBLFL <- rep(NA_character_, length(VISITNUM))
LBBLFL[1] <- "Y"

VISIT <- data.frame(VISIT = VISITS, VISITNUM = VISITNUM, LBBLFL = LBBLFL, stringsAsFactors = FALSE)
labdata <- expand.grid(USUBJID = USUBJID,  LBTEST = LBTEST, VISITNUM = VISITNUM, stringsAsFactors = FALSE)
setDT(labdata)
labdata <- merge(labdata, VISIT, by = "VISITNUM")
labdata[, c("LBNRIND"):= list(sample(x = c("LOW", "NORMAL", "HIGH"), size = .N, replace = TRUE, prob = c(.03, .9, .07)))]
setDF(labdata)

SHIFT_TABLE <- shift_table(x = labdata, cn_visit = "VISIT", cn_grade = "LBNRIND", cn_usubjid = "USUBJID",
  cn_lab_cat = "LBTEST", cn_is_baseline = "LBBLFL", baseline_identifier = "Y", grade_levels = c("LOW", "NORMAL", "HIGH"))

SHIFT_TABLE_VISIT <- attr(SHIFT_TABLE, "VISIT_N")
SHIFT_TABLE$VISIT = attr(SHIFT_TABLE, "FUN_VISIT")(SHIFT_TABLE$VISIT)
SHIFT_TABLE$BASELINE = attr(SHIFT_TABLE, "FUN_GRADE")(SHIFT_TABLE$BASELINE)
SHIFT_TABLE$LBNRIND = attr(SHIFT_TABLE, "FUN_GRADE")(SHIFT_TABLE$LBNRIND)
SHIFT_TABLE_VISIT$VISIT = attr(SHIFT_TABLE, "FUN_VISIT")(SHIFT_TABLE_VISIT$VISIT)


tab <- tabulator(x = SHIFT_TABLE,
  hidden_data = SHIFT_TABLE_VISIT,
  row_compose = list(
    VISIT = as_paragraph(VISIT, "\n(N=", N_VISIT, ")")
  ),
  rows = c("LBTEST", "VISIT", "BASELINE"), columns = c("LBNRIND"),
  `n` = as_paragraph(N),
  `%` = as_paragraph(as_chunk(PCT, formatter = function(z) { formatC(z * 100, digits = 1, format = "f", flag = "0", width = 4) }))
)

ft_1 <- as_flextable(x = tab, separate_with = "VISIT", label_rows = c(LBTEST = "Lab Test", VISIT = "Visit", BASELINE = "Reference\nRange\nIndicator"))
ft_1 <- width(ft_1, j = 3, width = 1)

test_that("pptx borders", {
  skip_if_not(pandoc_version() >= numeric_version("2"))
  skip_if_not_installed("doconv")
  library(doconv)
  skip_if_not(doconv::msoffice_available())
  local_edition(3)
  expect_snapshot_doc(x = save_as_pptx(ft_1, path = tempfile(fileext = ".pptx")),
                      name = "pptx-borders", engine = "testthat")
})

test_that("docx borders", {
  skip_if_not(pandoc_version() >= numeric_version("2"))
  skip_if_not_installed("doconv")
  library(doconv)
  skip_if_not(doconv::msoffice_available())
  local_edition(3)
  expect_snapshot_doc(x = save_as_docx(ft_1, path = tempfile(fileext = ".docx")),
                      name = "docx-borders", engine = "testthat")
})

test_that("html borders", {
  local_edition(3)
  skip_if_not(pandoc_version() >= numeric_version("2"))
  skip_if_not_installed("doconv")
  library(doconv)
  skip_if_not_installed("webshot2")
  path <- save_as_html(ft_1, path = tempfile(fileext = ".html"))
  expect_snapshot_html(name = "html-borders", path, engine = "testthat")
})


rmd_file_0 <- "rmd/borders.Rmd"
if (!file.exists(rmd_file_0)) {#just for dev purpose
  rmd_file_0 <- "tests/testthat/rmd/borders.Rmd"
}
rmd_file <- tempfile(fileext = ".Rmd")
file.copy(rmd_file_0, rmd_file, overwrite = TRUE)

html_file <- gsub("\\.Rmd$", ".html", rmd_file)
docx_file <- gsub("\\.Rmd$", ".docx", rmd_file)
pdf_file <- gsub("\\.Rmd$", ".pdf", rmd_file)
pptx_file <- gsub("\\.Rmd$", ".pptx", rmd_file)
source("zzzzz.R")

test_that("pdf complex borders", {
  local_edition(3)
  library(rmarkdown)
  skip_if_not(pandoc_available())
  skip_if_not(pandoc_version() > numeric_version("2.7.3"))
  render(rmd_file,
         output_format = rmarkdown::pdf_document(latex_engine = 'xelatex'),
         output_file = pdf_file,
         envir = new.env(),
         quiet = TRUE
  )
  expect_snapshot_doc(name = "pdf-complex-borders", pdf_file, engine = "testthat")
})

test_that("office complex borders", {
  local_edition(3)
  library(rmarkdown)
  skip_if_not(pandoc_available())
  skip_if_not(pandoc_version() > numeric_version("2.7.3"))
  skip_if_not_installed("doconv")
  skip_if_not(doconv::msoffice_available())
  library(doconv)
  render(rmd_file,
         output_format = rmarkdown::word_document(),
         output_file = docx_file,
         envir = new.env(),
         quiet = TRUE
  )
  expect_snapshot_doc(name = "docx-complex-borders", docx_file, engine = "testthat")
  render(rmd_file,
         output_format = rmarkdown::powerpoint_presentation(),
         output_file = pptx_file,
         envir = new.env(),
         quiet = TRUE
  )
  expect_snapshot_doc(name = "pptx-complex-borders", pptx_file, engine = "testthat")
})


init_flextable_defaults()

Generated by dwww version 1.15 on Sun Jun 16 13:48:12 CEST 2024.