R/testing.R

In lorenzwalthert/stylermd: Style Markdown text

#' Run a collection of tests
#'
#' Run transformations on all *-in files in a test directory and compare them
#'   with their *-out counterpart.
#' @inheritParams transform_and_check
#' @param test The test to run. It corresponds to a folder name in
#'   tests/testthat.
#' @param sub_test A regex pattern to further reduce the amount of test files
#'   to be tested in the test. `sub_test` must match the beginning of file
#'   names in tests/testthat. `NULL` matches all files.
#' @details Each file name that matches `test` and `sub_test` and ends with
#'   "-in" is considered as an input to test. Its counterpart,
#'   the reference to compare it against is the *-out file. It is constructed
#'   by taking the substring of the *-in.R file before the
#'   first dash and adding -out.
#' @inheritParams transform_and_check
#' @importFrom purrr flatten_chr pwalk map
#' @keywords internal
test_collection <- function(test, sub_test = NULL,
                            write_back = TRUE,
                            write_tree = FALSE,
                            transformer,
                            pattern = paste0(
                              if (!is.null(sub_test)) paste0("^", sub_test, ".*"),
                              "\\-in\\.*(txt|Rmd)*$"
                            ),
                            pattern_suffix,
                            ...) {
  path <- rprojroot::find_testthat_root_file(test)

  in_names <- list.files(
    file.path(path),
    pattern = pattern,
    full.names = FALSE
  )

  if (length(in_names) < 1) stop("no items to check")

  out_names <- construct_out(in_names)

  out_items <- file.path(path, out_names)
  in_items <- file.path(path, in_names)

  pwalk(list(in_items, out_items, in_names, out_names),
    transform_and_check,
    transformer = transformer,
    write_back = write_back,
    write_tree = write_tree,
    ...
  )
}



#' Construct *-out.R from a *-in.R
#'
#' Multiple *-in.R files can have the same *-out.R file since to create the
#'   *-out.R file, everything after the first dash is replaced by *-out.R.
#' @param in_paths A character vector that denotes paths to *-in.R files.
#' @examples
#' stylermd:::construct_out(c(
#'   "path/to/file/first-in.R",
#'   "path/to/file/first-extended-in.R"
#' ))
#' @keywords internal
construct_out <- function(in_paths) {
  gsub("\\-in([.](txt|Rmd))?$", "\\-out\\1", in_paths)
}


#' Transform a file an check the result
#'
#' Transform an file and check whether it is identical to a reference.
#' @param in_item An path to an file to transform.
#' @param out_item The path to a file that contains the expected result.
#' @param in_name The label of the in_item, defaults to `in_item`.
#' @param out_name The label of the out_item, defaults to `out_item`.
#' @param transformer A function to apply to the content of `in_item`.
#' @param write_back Whether the results of the transformation should be written
#'   to the output file.
#' @param write_tree Whether or not the tree structure of the test should be
#'   computed and written to a file. Note that this needs R >= 3.2
#'   (see `set_arg_write_tree()`. If the argument is set to `NA`, the function
#'   determines whether R >= 3.2 is in use and if so, trees will be written.
#' @param ... Parameters passed to transformer function.
#' @param out_tree Name of tree file if written out.
#' @importFrom utils write.table
#' @keywords internal
transform_and_check <- function(in_item, out_item,
                                in_name = in_item, out_name = out_item,
                                transformer, write_back,
                                write_tree = NA,
                                out_tree = "_tree", ...) {
  read_in <- enc::read_lines_enc(in_item)
  transformed_text <- read_in %>%
    transformer(...) %>%
    unclass()
  transformed <- enc::transform_lines_enc(
    out_item,
    function(x) transformed_text,
    write_back = write_back,
    verbose = FALSE
  )

  if (transformed) {
    warning(
      in_name, " was different from ", out_name,
      immediate. = TRUE, call. = FALSE
    )
  } else {
    message(
      in_name, " was identical to ", out_name
    )
  }
}

#' Create the path to a test that file
#'
#' @param ... Arguments passed to [file.path()] to construct the path after
#'   ".../tests/testthat/"
#' @keywords internal
testthat_file <- function(...) {
  file.path(rprojroot::find_testthat_root_file(), ...)
}