make_find_root_file <- function(criterion) {
force(criterion)
eval(bquote(function(..., path = ".") {
find_root_file(..., criterion = criterion, path = path)
}))
}
make_fix_root_file <- function(criterion, path, subdir = NULL) {
root <- find_root(criterion = criterion, path = path)
if (!is.null(subdir)) {
root <- file.path(root, subdir)
}
eval(bquote(function(...) {
if (!missing(..1)) {
abs <- is_absolute_path(..1)
if (all(abs)) {
return(path(...))
}
if (any(abs)) {
stop("Combination of absolute and relative paths not supported.", call. = FALSE)
}
}
path(.(root), ...)
}))
}
#' Is a directory the project root?
#'
#' Objects of the `root_criterion` class decide if a
#' given directory is a project root.
#'
#' Construct criteria using `root_criterion` in a very general fashion
#' by specifying a function with a `path` argument, and a description.
#'
#' @param testfun `[function|list(function)]`\cr
#' A function with one parameter that returns `TRUE`
#' if the directory specified by this parameter is the project root,
#' and `FALSE` otherwise. Can also be a list of such functions.
#' @param desc `[character]`\cr
#' A textual description of the test criterion, of the same length
#' as `testfun`.
#' @param subdir `[character]`\cr
#' If given, the criterion will also be tested in the subdirectories
#' defined by this argument, in the order given.
#' The first existing directory will be used as a starting point.
#' This is used for the [is_testthat] criterion that needs to
#' *descend* into `tests/testthat` if starting at the package root,
#' but stay inside `tests/testthat` if called from a testthat test.
#'
#' @return
#' An S3 object of class `root_criterion` with the following members:
#'
#' @export
#'
#' @examples
#' root_criterion(function(path) file.exists(file.path(path, "somefile")), "has somefile")
#' has_file("DESCRIPTION")
#' is_r_package
#' \dontrun{
#' is_r_package$find_file
#' is_r_package$make_fix_file(".")
#' }
root_criterion <- function(testfun, desc, subdir = NULL) {
testfun <- check_testfun(testfun)
stopifnot(length(desc) == length(testfun))
full_desc <- paste0(
desc,
if (!is.null(subdir)) {
paste0(
" (also look in subdirectories: ",
paste0("`", subdir, "`", collapse = ", "),
")"
)
}
)
criterion <- structure(
list(
#' @return
#' \describe{
#' \item{`testfun`}{The `testfun` argument}
testfun = testfun,
#' \item{`desc`}{The `desc` argument}
desc = full_desc,
#' \item{`subdir`}{The `subdir` argument}
subdir = subdir
),
class = "root_criterion"
)
#' \item{`find_file`}{A function with `...` and `path` arguments
#' that returns a path relative to the root,
#' as specified by this criterion.
#' The optional `path` argument specifies the starting directory,
#' which defaults to `"."`.
#' The function forwards to [find_root_file()],
#' which passes `...` directly to `file.path()`
#' if the first argument is an absolute path.
#' }
criterion$find_file <- make_find_root_file(criterion)
#' \item{`make_fix_file`}{A function with a `path` argument that
#' returns a function that finds paths relative to the root. For a
#' criterion `cr`, the result of `cr$make_fix_file(".")(...)`
#' is identical to `cr$find_file(...)`. The function created by
#' `make_fix_file()` can be saved to a variable to be more independent
#' of the current working directory.
#' }
#' }
criterion$make_fix_file <-
function(path = getwd(), subdir = NULL) {
make_fix_root_file(criterion, path, subdir)
}
criterion
}
check_testfun <- function(testfun) {
if (is.function(testfun)) {
testfun <- list(testfun)
}
for (f in testfun) {
if (!isTRUE(all.equal(names(formals(f)), "path"))) {
stop("All functions in testfun must have exactly one argument 'path'", call. = FALSE)
}
}
testfun
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.