tests/testthat/setup.R

In flextable: Functions for Tabular Reporting

# Collection of functions and data pre-processing to help with testing
library(officer)
library(xml2)

# xml related functions --------------------------------------------------------
get_docx_xml <- function(x) {
  if (inherits(x, "flextable")) {
    docx_file <- tempfile(fileext = ".docx")
    doc <- read_docx()
    doc <- body_add_flextable(doc, value = x)
    print(doc, target = docx_file)
    x <- docx_file
  }
  redoc <- read_docx(x)
  xml_child(docx_body_xml(redoc))
}

get_pptx_xml <- function(x) {
  if (inherits(x, "flextable")) {
    pptx_file <- tempfile(fileext = ".pptx")
    doc <- read_pptx()
    doc <- add_slide(doc, layout = "Title and Content", master = "Office Theme")
    doc <- ph_with(doc, x, location = ph_location_type(type = "body"))
    print(doc, target = pptx_file)
    x <- pptx_file
  }

  redoc <- read_pptx(x)
  slide <- redoc$slide$get_slide(redoc$cursor)
  xml_child(slide$get())
}

get_html_xml <- function(x) {
  if (inherits(x, "flextable")) {
    html_file <- tempfile(fileext = ".html")
    save_as_html(tab, path = html_file)
    x <- html_file
  }
  doc <- read_html(x)
  xml_child(doc, "body")
}
get_pdf_text <- function(x, extract_fun) {
  stopifnot(grepl("\\.pdf$", x))

  doc <- extract_fun(x)
  txtfile <- tempfile()
  cat(paste0(doc, collapse = "\n"), file = txtfile)
  readLines(txtfile)
}

render_rmd <- function(file, rmd_format) {
  unlink(file, force = TRUE)
  sucess <- FALSE
  tryCatch(
    {
      render(rmd_file,
        output_format = rmd_format,
        output_file = pdf_file,
        envir = new.env(),
        quiet = TRUE
      )
      sucess <- TRUE
    },
    warning = function(e) {
    },
    error = function(e) {
    }
  )
  sucess
}

# Getting snapshots in the _snaps folder for local testing if conditions are met
do_manual_msoffice_snapshot_testing <- FALSE
copy_back_new_snapshots <- FALSE # if snapshots are updated can be rewritten back

# Utility function to manually test local snapshots ----------------------------
skip_if_not_local_testing <- function(min_pandoc_version = "2", check_html = FALSE) {
  skip_on_cran() # When doing manual testing, it should be always skipped on CRAN
  skip_on_ci() # msoffice testing can not be done on ci
  skip_if_not(do_manual_msoffice_snapshot_testing)
  local_edition(3, .env = parent.frame()) # Set the local_edition at 3
  skip_if_not_installed("doconv")
  skip_if_not(doconv::msoffice_available())
  if (!is.null(min_pandoc_version)) { # Can be turned off with NULL
    skip_if_not(rmarkdown::pandoc_version() >= numeric_version(min_pandoc_version))
  }
  if (isTRUE(check_html)) {
    skip_if_not_installed("webshot2")
  }
  invisible(TRUE)
}

handle_manual_snapshots <- function(snapshot_folder, snapshot_name) {
  skip_if_not_installed("withr")
  skip_if_not(do_manual_msoffice_snapshot_testing)

  snapshot_name <- paste0(snapshot_name, ".png")

  # Folder where the snapshots are stored
  main_inst_folder <- system.file("snapshots_for_manual_tests", package = "flextable", mustWork = TRUE)

  snapshot_file <- file.path(main_inst_folder, snapshot_folder, snapshot_name)

  if (!file.exists(snapshot_file)) {
    stop("Following snapshot file not found in {flextable}:", snapshot_file)
  }

  # Construct the path to the _snaps folder
  path_to_snaps <- file.path("_snaps", snapshot_folder)
  if (!dir.exists("_snaps")) {
    dir.create("_snaps")
  }
  if (!dir.exists(path_to_snaps)) {
    dir.create(path_to_snaps)
  }

  # Main copy
  file.copy(snapshot_file, path_to_snaps, overwrite = TRUE)

  # Copying back and cleaning test folder
  withr::defer(
    {
      snap_file <- file.path(path_to_snaps, snapshot_name)
      if (copy_back_new_snapshots) {
        file.copy(snap_file, dirname(snapshot_file), overwrite = TRUE)
      }
      if (file.exists(snap_file)) {
        file.remove(snap_file)
      }
    },
    envir = parent.frame()
  )
}

defer_cleaning_snapshot_directory <- function(snap_folder_test_file) {
  skip_if_not_installed("withr")
  skip_if_not(do_manual_msoffice_snapshot_testing)
  withr::defer({
    last_folder <- file.path("_snaps", snap_folder_test_file)
    files_not_removed_for_error <- list.files(last_folder)
    if (length(files_not_removed_for_error)) {
      lapply(files_not_removed_for_error, file.remove)
    }
    if (dir.exists("_snaps")) {
      unlink("_snaps", recursive = TRUE)
    }
  })
}