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.