From 258d6cc4abb52e8a407fb73474baf724d009899c Mon Sep 17 00:00:00 2001 From: Rich FitzJohn Date: Thu, 5 Sep 2024 09:28:59 +0100 Subject: [PATCH 1/4] Add allow_null arg --- R/standalone-utils-assert.R | 25 ++++++++++++++++++++++--- tests/testthat/test-util-assert.R | 18 ++++++++++++++++++ 2 files changed, 40 insertions(+), 3 deletions(-) diff --git a/R/standalone-utils-assert.R b/R/standalone-utils-assert.R index a9526b5..2768aa7 100644 --- a/R/standalone-utils-assert.R +++ b/R/standalone-utils-assert.R @@ -76,7 +76,11 @@ assert_nonmissing <- function(x, name = deparse(substitute(x)), assert_scalar_character <- function(x, name = deparse(substitute(x)), - arg = name, call = parent.frame()) { + allow_null = FALSE, + arg = name, call = parent.frame()) { + if (allow_null && is.null(x)) { + return(invisible(x)) + } assert_scalar(x, name, arg = arg, call = call) assert_character(x, name, arg = arg, call = call) assert_nonmissing(x, name, arg = arg, call = call) @@ -84,7 +88,11 @@ assert_scalar_character <- function(x, name = deparse(substitute(x)), assert_scalar_numeric <- function(x, name = deparse(substitute(x)), + allow_null = FALSE, arg = name, call = parent.frame()) { + if (allow_null && is.null(x)) { + return(invisible(x)) + } assert_scalar(x, name, arg = arg, call = call) assert_numeric(x, name, arg = arg, call = call) assert_nonmissing(x, name, arg = arg, call = call) @@ -92,7 +100,11 @@ assert_scalar_numeric <- function(x, name = deparse(substitute(x)), assert_scalar_integer <- function(x, name = deparse(substitute(x)), - tolerance = NULL, arg = name, call = parent.frame()) { + tolerance = NULL, allow_null = FALSE, + arg = name, call = parent.frame()) { + if (allow_null && is.null(x)) { + return(invisible(x)) + } assert_scalar(x, name, arg = arg, call = call) assert_integer(x, name, tolerance = tolerance, arg = arg, call = call) assert_nonmissing(x, name, arg = arg, call = call) @@ -100,16 +112,23 @@ assert_scalar_integer <- function(x, name = deparse(substitute(x)), assert_scalar_logical <- function(x, name = deparse(substitute(x)), + allow_null = FALSE, arg = name, call = parent.frame()) { + if (allow_null && is.null(x)) { + return(invisible(x)) + } assert_scalar(x, name, arg = arg, call = call) assert_logical(x, name, arg = arg, call = call) assert_nonmissing(x, name, arg = arg, call = call) } -assert_scalar_size <- function(x, allow_zero = TRUE, +assert_scalar_size <- function(x, allow_zero = TRUE, allow_null = FALSE, name = deparse(substitute(x)), arg = name, call = parent.frame()) { + if (allow_null && is.null(x)) { + return(invisible(x)) + } assert_scalar_integer(x, name = name, arg = arg, call = call) assert_nonmissing(x, name, arg = arg, call = call) min <- if (allow_zero) 0 else 1 diff --git a/tests/testthat/test-util-assert.R b/tests/testthat/test-util-assert.R index 97517dc..c885f9d 100644 --- a/tests/testthat/test-util-assert.R +++ b/tests/testthat/test-util-assert.R @@ -157,3 +157,21 @@ test_that("assert_scalar_positive integer", { x <- 1.1 expect_error(assert_scalar_positive_integer(x), "Expected 'x' to be integer") }) + + +test_that("assert_scalar_x supports null on request", { + expect_error(assert_scalar_character(NULL), "has length 0") + expect_no_error(assert_scalar_character(NULL, allow_null = TRUE)) + + expect_error(assert_scalar_integer(NULL), "has length 0") + expect_no_error(assert_scalar_integer(NULL, allow_null = TRUE)) + + expect_error(assert_scalar_numeric(NULL), "has length 0") + expect_no_error(assert_scalar_numeric(NULL, allow_null = TRUE)) + + expect_error(assert_scalar_logical(NULL), "has length 0") + expect_no_error(assert_scalar_logical(NULL, allow_null = TRUE)) + + expect_error(assert_scalar_size(NULL), "has length 0") + expect_no_error(assert_scalar_size(NULL, allow_null = TRUE)) +}) From c78b232c9e94af3997cd1df978784b100e263e21 Mon Sep 17 00:00:00 2001 From: Rich FitzJohn Date: Thu, 5 Sep 2024 16:38:46 +0100 Subject: [PATCH 2/4] Import orderly2's file utilities --- R/standalone-utils-assert-path.R | 146 +++++++++++++++++++++++++ tests/testthat/test-util-assert-path.R | 118 ++++++++++++++++++++ 2 files changed, 264 insertions(+) create mode 100644 R/standalone-utils-assert-path.R create mode 100644 tests/testthat/test-util-assert-path.R diff --git a/R/standalone-utils-assert-path.R b/R/standalone-utils-assert-path.R new file mode 100644 index 0000000..7b212a6 --- /dev/null +++ b/R/standalone-utils-assert-path.R @@ -0,0 +1,146 @@ +# --- +# repo: reside/reside.utils +# file: standalone-utils-assert-path.R +# dependencies: standalone-utils-assert.R +# imports: [cli, fs] +# --- +assert_file_exists <- function(files, name = "File", call = parent.frame(), + arg = NULL) { + err <- !file.exists(files) + ## TODO: throughout this file it would be nice to use cli's '.file' + ## class and ector contraction, *but* it renders poorly on default + ## black backgfrounds (dark blue) and makes testing a bit harder + ## because the rendering depends on cli options. + ## + ## TODO: add a canonical case check, as for the relative path bit. + if (any(err)) { + ## Because we interpolate both 'name' and the file list, we need + ## to disambiguate the quantity. + n <- cli::qty(sum(err)) + cli::cli_abort( + "{name}{n}{?s} {?does/do} not exist: {format_file_list(files[err])}", + call = call, arg = arg) + } +} + + +assert_file_exists_relative <- function(files, workdir, name, + call = parent.frame(), + arg = NULL) { + assert_relative_path(files, name, workdir, call) + + assert_character(files, name, call = call) + err <- !file_exists(files, workdir = workdir) + if (any(err)) { + n <- cli::qty(sum(err)) + cli::cli_abort( + c("{name}{n}{?s} {?does/do} not exist: {format_file_list(files[err])}", + i = "Looked within directory '{workdir}'"), + call = call) + } + + files_canonical <- file_canonical_case(files, workdir) + err <- is.na(files_canonical) | fs::path(files) != files_canonical + if (any(err)) { + i <- err & !is.na(files_canonical) + hint_case <- sprintf("For '%s', did you mean '%s'?", + files[i], files_canonical[i]) + names(hint_case) <- rep("i", length(hint_case)) + n <- cli::qty(sum(err)) + cli::cli_abort( + c("{name}{n}{?s} {?does/do} not exist: {format_file_list(files[err])}", + hint_case, + i = paste("If you don't use the canonical case for a file, your code", + "is not portable across different platforms"), + i = "Looked within directory '{workdir}'"), + call = call) + } +} + + +assert_is_directory <- function(path, name = "Directory", call = parent.frame(), + arg = NULL) { + assert_scalar_character(path, arg = arg, call = call) + assert_file_exists(path, name = name, arg = arg, call = call) + if (!fs::is_dir(path)) { + cli::cli_abort("Path exists but is not a directory: {path}", + call = call, arg = arg) + } +} + + +assert_relative_path <- function(files, name, workdir, call = parent.frame(), + arg = NULL) { + err <- fs::is_absolute_path(files) + if (any(err)) { + n <- cli::qty(sum(err)) + files_err <- files[err] + names(files_err) <- rep("x", length(files_err)) + cli::cli_abort( + c("{name}{n}{?s} must be {?a/} relative path{?s}", + files_err, + i = "Path was relative to directory '{workdir}'"), + call = call, arg = arg) + } + + err <- vapply(fs::path_split(files), function(x) any(x == ".."), TRUE) + if (any(err)) { + n <- cli::qty(sum(err)) + files_err <- files[err] + names(files_err) <- rep("x", length(files_err)) + cli::cli_abort( + c("{name}{n}{?s} must not contain '..' (parent directory) components", + files_err, + i = "Path was relative to directory '{workdir}'"), + call = call, arg = arg) + } +} + + +assert_directory_does_not_exist <- function(x, name = "Directory", arg = NULL, + call = parent.frame()) { + ok <- !fs::dir_exists(x) + if (!all(ok)) { + cli::cli_abort("{name}{?s} already exists: {format_file_list(x[!ok])}", + call = call, arg = arg) + } + invisible(x) +} + + +file_canonical_case <- function(path, workdir) { + if (length(path) != 1) { + return(vapply(path, file_canonical_case, "", workdir, USE.NAMES = FALSE)) + } + stopifnot(!fs::is_absolute_path(path)) + path_split <- tolower(fs::path_split(path)[[1]]) + base <- workdir + ret <- character(length(path_split)) + for (i in seq_along(path_split)) { + pos <- dir(base) + j <- which(path_split[[i]] == tolower(pos)) + if (length(j) != 1) { + return(NA_character_) + } + ret[[i]] <- pos[[j]] + base <- file.path(base, pos[[j]]) + } + paste(ret, collapse = "/") +} + + +file_exists <- function(..., workdir = NULL) { + files <- c(...) + if (!is.null(workdir)) { + assert_scalar_character(workdir) + owd <- setwd(workdir) # nolint + on.exit(setwd(owd)) # nolint + } + fs::file_exists(files) +} + + +format_file_list <- function(x) { + cli::cli_vec(sprintf("'%s'", x), + style = list("vec-sep2" = ", ", "vec-last" = ", ")) +} diff --git a/tests/testthat/test-util-assert-path.R b/tests/testthat/test-util-assert-path.R new file mode 100644 index 0000000..109778b --- /dev/null +++ b/tests/testthat/test-util-assert-path.R @@ -0,0 +1,118 @@ +test_that("assert_file_exists", { + tmp <- withr::local_tempdir() + expect_error(assert_file_exists(file.path(tmp, "a")), + "File does not exist") + expect_error(assert_file_exists(file.path(tmp, c("a", "b"), "File")), + "Files do not exist") + file.create(file.path(tmp, c("a", "b"))) + expect_no_error(assert_file_exists(file.path(tmp, "a"))) + expect_no_error(assert_file_exists(file.path(tmp, c("a", "b")))) +}) + + +test_that("assert_file_exists_relative works checks if files exist", { + tmp <- withr::local_tempdir() + file.create(file.path(tmp, "c")) + expect_error(assert_file_exists_relative("a", tmp, "File"), + "File does not exist: 'a'") + expect_error(assert_file_exists_relative(c("a", "b"), tmp, "File"), + "Files do not exist: 'a', 'b'") + expect_error(assert_file_exists_relative(c("a", "b", "c", "d"), tmp, "File"), + "Files do not exist: 'a', 'b', 'd'") + expect_silent(assert_file_exists_relative("c", tmp, "File")) +}) + + +test_that("assert_file_exists_relative informs about case mismatch", { + testthat::skip_if_not_installed("mockery") + mock_file_exists <- mockery::mock(TRUE, cycle = TRUE) + mockery::stub(assert_file_exists_relative, "file_exists", mock_file_exists) + + tmp <- withr::local_tempdir() + file.create(file.path(tmp, "a")) + fs::dir_create(file.path(tmp, "b/c")) + file.create(file.path(tmp, "b/c/d")) + + err <- expect_error( + assert_file_exists_relative("A", tmp, "File"), + "File does not exist: 'A'") + expect_length(err$body, 3) + expect_equal(names(err$body), c("i", "i", "i")) + expect_equal(err$body[[1]], "For 'A', did you mean 'a'?") + expect_match(err$body[[2]], "If you don't use the canonical case for a file") + expect_match(err$body[[3]], "Looked within directory '.+'") + + err <- expect_error( + assert_file_exists_relative(c("A", "b/C/d"), tmp, "File"), + "Files do not exist: 'A', 'b/C/d'") + expect_length(err$body, 4) + expect_equal(names(err$body), c("i", "i", "i", "i")) + expect_equal(err$body[[1]], "For 'A', did you mean 'a'?") + expect_equal(err$body[[2]], "For 'b/C/d', did you mean 'b/c/d'?") + expect_match(err$body[[3]], "If you don't use the canonical case for a file") + expect_match(err$body[[4]], "Looked within directory '.+'") + + err <- expect_error( + assert_file_exists_relative(c("A", "b/X/d"), tmp, "File"), + "Files do not exist: 'A', 'b/X/d'") + expect_length(err$body, 3) + expect_equal(names(err$body), c("i", "i", "i")) + expect_equal(err$body[[1]], "For 'A', did you mean 'a'?") + expect_match(err$body[[2]], "If you don't use the canonical case for a file") + expect_match(err$body[[3]], "Looked within directory '.+'") +}) + + +test_that("assert_is_directory", { + tmp <- withr::local_tempdir() + path <- file.path(tmp, "foo") + expect_error(assert_is_directory(path), "Directory does not exist") + file.create(path) + expect_error(assert_is_directory(path), + "Path exists but is not a directory") + expect_silent(assert_is_directory(".")) +}) + + +test_that("assert_relative_path", { + workdir <- getwd() + expect_error(assert_relative_path(getwd(), "File", workdir), + "File must be a relative path", + fixed = TRUE) + expect_silent(assert_relative_path("relpath", "File", workdir)) + expect_silent(assert_relative_path("a/b/c", "File", workdir)) + + expect_error( + assert_relative_path("../my/path", "File", workdir), + "must not contain '..' (parent directory) components", + fixed = TRUE) + expect_error( + assert_relative_path("my/../../path", "File", workdir), + "must not contain '..' (parent directory) components", + fixed = TRUE) +}) + + +test_that("can convert files to canonical case", { + tmp <- withr::local_tempdir() + p <- file.path(tmp, "a", "b", "c") + fs::dir_create(dirname(p)) + file.create(p) + expect_equal(file_canonical_case("a/b/c", tmp), "a/b/c") + expect_equal(file_canonical_case("a//b//c", tmp), "a/b/c") + expect_equal(file_canonical_case("a/B/c", tmp), "a/b/c") + expect_equal(file_canonical_case("A/B/C", tmp), "a/b/c") + expect_equal(file_canonical_case("A/win~1/C", tmp), NA_character_) + expect_equal(file_canonical_case(c("a/b/c", "a/b/d"), tmp), c("a/b/c", NA)) +}) + + +test_that("can check directories do not exist", { + tmp <- withr::local_tempdir() + path <- file.path(tmp, "a") + expect_no_error(assert_directory_does_not_exist(path)) + dir.create(path) + expect_error( + assert_directory_does_not_exist(path), + "Directory already exists") +}) From f33edf21c6aca2819bf2e496f80b5e0c5ac14fa3 Mon Sep 17 00:00:00 2001 From: Rich FitzJohn Date: Thu, 5 Sep 2024 16:55:20 +0100 Subject: [PATCH 3/4] Declare deps --- DESCRIPTION | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index c89e062..5aa820b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -15,8 +15,10 @@ RoxygenNote: 7.1.1 URL: https://reside-ic.github.io/reside.utils, https://github.com/reside-ic/reside.utils BugReports: https://github.com/reside-ic/reside.utils/issues Imports: - cli + cli, + fs Suggests: + mockery, pkgload, rmarkdown, usethis, From a8a844ac88ed1729af24d8688112d27b1e945ee0 Mon Sep 17 00:00:00 2001 From: Rich FitzJohn Date: Tue, 10 Sep 2024 13:46:55 +0100 Subject: [PATCH 4/4] Propagate name parameter in match_value Originally fixed in https://github.com/mrc-ide/orderly2/pull/175 --- R/standalone-utils-assert.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/standalone-utils-assert.R b/R/standalone-utils-assert.R index 2768aa7..d0b84de 100644 --- a/R/standalone-utils-assert.R +++ b/R/standalone-utils-assert.R @@ -67,7 +67,7 @@ assert_logical <- function(x, name = deparse(substitute(x)), assert_nonmissing <- function(x, name = deparse(substitute(x)), - arg = name, call = parent.frame()) { + arg = name, call = parent.frame()) { if (anyNA(x)) { cli::cli_abort("Expected '{name}' to be non-NA", arg = arg, call = call) } @@ -235,7 +235,7 @@ assert_named <- function(x, unique = FALSE, name = deparse(substitute(x)), match_value <- function(x, choices, name = deparse(substitute(x)), arg = name, call = parent.frame()) { - assert_scalar_character(x, call = call, arg = arg) + assert_scalar_character(x, call = call, name = name, arg = arg) if (!(x %in% choices)) { choices_str <- paste(sprintf("'%s'", choices), collapse = ", ") cli::cli_abort(c("'{name}' must be one of {choices_str}",