tests/testthat/helper-outpack.R

In orderly: Lightweight Reproducible Reporting

create_random_packet <- function(root, name = "data", parameters = NULL,
                                 id = NULL, n_files = 1) {
  src <- fs::dir_create(tempfile())
  on.exit(fs::dir_delete(src))
  for (n in seq_len(n_files)) {
    file_name <- sprintf("data%s.rds", if (n > 1) n else "")
    saveRDS(runif(10), file.path(src, file_name))
  }
  p <- outpack_packet_start_quietly(
    src, name, parameters = parameters, id = id, root = root)
  outpack_packet_end_quietly(p)
  p$id
}


create_deterministic_packet <- function(root, name = "data",
                                        parameters = NULL) {
  src <- fs::dir_create(tempfile())
  on.exit(fs::dir_delete(src))
  saveRDS(1:10, file.path(src, "data.rds"))
  p <- outpack_packet_start_quietly(
    src, name, parameters = parameters, root = root)
  outpack_packet_end_quietly(p)
  p$id
}


mock_metadata_depends <- function(id, depends = character(0)) {
  ret <- list(list(id = id, depends = data_frame(packet = depends)))
  names(ret) <- id
  ret
}


## Creates a simple chain of packets a, b, c, ... that depend on each
## other.
create_random_packet_chain <- function(root, length, base = NULL) {
  src <- fs::dir_create(tempfile())
  on.exit(fs::dir_delete(src), add = TRUE)

  id <- character()
  suppressMessages({
    for (i in seq_len(length)) {
      nm <- letters[[i]]
      p <- file.path(src, nm)
      fs::dir_create(p)
      packet <- outpack_packet_start(p, nm, root = root)
      id[[nm]] <- packet$id

      if (i == 1 && is.null(base)) {
        saveRDS(runif(10), file.path(p, "data.rds"))
      } else {
        code <- sprintf("saveRDS(readRDS('input.rds') * %d, 'data.rds')", i)
        writeLines(code, file.path(p, "script.R"))
        id_use <- if (i > 1) id[[letters[i - 1]]] else base
        outpack_packet_use_dependency(packet, id_use,
                                      c("input.rds" = "data.rds"))
        outpack_packet_run(packet, "script.R")
      }
      outpack_packet_end(packet)
    }
  })

  id
}


create_random_dependent_packet <- function(root, name, dependency_ids) {
  src <- fs::dir_create(tempfile())
  on.exit(fs::dir_delete(src), add = TRUE)

  p <- outpack_packet_start_quietly(src, name, root = root)

  len <- length(dependency_ids)
  if (len == 0) {
    saveRDS(runif(10), file.path(p, "data.rds"))
  } else {
    inputs <- paste0(sprintf("readRDS('input%s.rds')", seq_len(len)),
                     collapse = " * ")
    code <- sprintf("saveRDS(%s , 'data.rds')", inputs)
    writeLines(code, file.path(src, "script.R"))
    for (num in seq_len(len)) {
      input_name <- sprintf("input%s.rds", num)
      outpack_packet_use_dependency(p, dependency_ids[[num]],
                                    stats::setNames("data.rds", input_name))
    }
    outpack_packet_run(p, "script.R")
  }
  outpack_packet_end_quietly(p)

  p$id
}


create_temporary_root <- function(...) {
  path <- tempfile()
  withr::defer_parent(fs::dir_delete(path))
  suppressMessages(orderly_init(path, ...))
  root_open(path, require_orderly = FALSE)
}


## A really simple example that we use in a few places
create_temporary_simple_src <- function() {
  path <- tempfile()
  withr::defer_parent(fs::dir_delete(path))
  fs::dir_create(path)

  path <- tempfile()
  fs::dir_create(path)
  writeLines(c(
    "d <- read.csv('data.csv')",
    "png('zzz.png')",
    "plot(d)",
    "dev.off()"),
    file.path(path, "script.R"))
  write.csv(data.frame(x = 1:10, y = runif(10)),
            file.path(path, "data.csv"),
            row.names = FALSE)

  path
}


temp_file <- function() {
  path <- tempfile()
  withr::defer_parent({
    if (fs::file_exists(path)) {
      fs::file_delete(path)
    }
  })
  path
}


helper_add_git <- function(path) {
  gert::git_init(path)
  if (file.exists(file.path(path, ".outpack"))) {
    suppressMessages(orderly_gitignore_update("(root)", path))
  }
  gert::git_add(".", repo = path)
  user <- "author <author@example.com>"
  sha <- gert::git_commit("initial", author = user, committer = user,
                          repo = path)
  branch <- gert::git_branch(repo = path)
  url <- "https://example.com/git"
  gert::git_remote_add(url, repo = path)
  list(user = user, branch = branch, sha = sha, url = url)
}


helper_remove_outpack <- function(path) {
  unlink(file.path(path, ".outpack"), recursive = TRUE)
}


## This matches the old semantics of outpack_root, and is used to
## create a root that does not have the orderly bits.
outpack_init_no_orderly <- function(...) {
  path <- orderly_init_quietly(...)
  fs::file_delete(file.path(path, "orderly_config.json"))
  outpack_root$new(path, NULL)
}


outpack_packet_run <- function(packet, script, envir = NULL) {
  if (is.null(envir)) {
    envir <- new.env(parent = .GlobalEnv)
  }
  packet <- check_current_packet(packet)
  withr::with_dir(packet$path,
                  source_echo(script, envir = envir, echo = FALSE))
}


outpack_packet_start_quietly <- function(...) {
  suppressMessages(outpack_packet_start(...))
}


outpack_packet_end_quietly <- function(...) {
  suppressMessages(outpack_packet_end(...))
}

forcibly_truncate_file <- function(path) {
  permissions <- fs::file_info(path)$permissions
  fs::file_delete(path)
  fs::file_create(path)
  fs::file_chmod(path, permissions)
}

str_replace_all <- function(x, from, to) {
  for (i in seq_along(from)) {
    x <- gsub(from[[i]], to[[i]], x)
  }
  x
}

#' Scrub packets from an output.
#'
#' This returns a transformation suitable to be passed to `expect_snapshot`.
#' The specified packet IDs are removed from the output, and replaced with
#' stable strings of the same length.
#'
#' @param ... the list of packet IDs to remove from the output.
#' @noRd
scrub_packets <- function(...) {
  ids <- c(...)
  replacements <- sprintf("19700101-000000-%08x", seq_along(ids))
  function(x) str_replace_all(x, ids, replacements)
}