diff --git a/DESCRIPTION b/DESCRIPTION index d36bcfd..f89993c 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -34,9 +34,16 @@ Imports: S7, utils, val.meter +Suggests: + knitr, + rmarkdown, + testthat (>= 3.0.0), + withr Remotes: - val.meter=github::pharmaR/val.meter + val.meter=github::pharmaR/val.meter@58_fixing_metric_coerce Encoding: UTF-8 Roxygen: list(markdown = TRUE) Config/roxygen2/version: 8.0.0 +Config/testthat/edition: 3 RoxygenNote: 7.3.3 +VignetteBuilder: knitr diff --git a/NAMESPACE b/NAMESPACE index 9d6723f..cc245e3 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -6,6 +6,7 @@ export(default_actions) export(last_rejected) export(last_rejected_permit) export(package_filter) +export(percentile) import(S7) import(options) importFrom(stats,ecdf) diff --git a/R/available_packages.R b/R/available_packages.R index 5dde5e8..1ffb546 100644 --- a/R/available_packages.R +++ b/R/available_packages.R @@ -79,7 +79,7 @@ package_filter <- local({ metric_defaults <- as.list(rep_len(NA, length.out = length(metrics()))) names(metric_defaults) <- names(metrics()) - if (!is.na(metric_db)) { + if (is.matrix(metric_db)) { # build our evaluation environemnt and evaluate filter expression db <- db[!is.na(db[, "Package"]), ] db <- as.data.frame(db) @@ -141,7 +141,7 @@ build_filter_envir <- function( values <- as.data.frame(values) } value_envir <- with(values, environment()) - if (!is.na(defaults)) { + if (is.list(defaults)) { defaults_envir <- with(defaults, environment()) parent.env(defaults_envir) <- envir parent.env(value_envir) <- defaults_envir diff --git a/R/transforms.R b/R/transforms.R index 2e9f556..5e8cfcd 100644 --- a/R/transforms.R +++ b/R/transforms.R @@ -1,4 +1,25 @@ +#' Filter Transforms +#' +#' Helper transforms intended for use within a [`package_filter()`] expression, +#' where they are applied to metric fields to express relative criteria. +#' +#' @param x `numeric` vector of metric values, typically a metric field +#' referenced by name from within a filter expression. +#' +#' @return `percentile()` returns a `numeric` vector the same length as `x`, +#' giving each element's empirical cumulative percentile (its +#' [`stats::ecdf()`] evaluated at `x`), between `0` and `1`. +#' +#' @examples +#' percentile(c(10, 20, 30, 40)) +#' +#' # used within a filter to keep only relatively popular packages +#' \dontrun{ +#' package_filter({ percentile(downloads_total) >= 0.25 }) +#' } +#' #' @importFrom stats ecdf +#' @export percentile <- function(x) { ecdf(x)(x) } diff --git a/man/percentile.Rd b/man/percentile.Rd new file mode 100644 index 0000000..f59f5cb --- /dev/null +++ b/man/percentile.Rd @@ -0,0 +1,30 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/transforms.R +\name{percentile} +\alias{percentile} +\title{Filter Transforms} +\usage{ +percentile(x) +} +\arguments{ +\item{x}{\code{numeric} vector of metric values, typically a metric field +referenced by name from within a filter expression.} +} +\value{ +\code{percentile()} returns a \code{numeric} vector the same length as \code{x}, +giving each element's empirical cumulative percentile (its +\code{\link[stats:ecdf]{stats::ecdf()}} evaluated at \code{x}), between \code{0} and \code{1}. +} +\description{ +Helper transforms intended for use within a \code{\link[=package_filter]{package_filter()}} expression, +where they are applied to metric fields to express relative criteria. +} +\examples{ +percentile(c(10, 20, 30, 40)) + +# used within a filter to keep only relatively popular packages +\dontrun{ +package_filter({ percentile(downloads_total) >= 0.25 }) +} + +} diff --git a/pkgdown/_pkgdown.yml b/pkgdown/_pkgdown.yml index 676d6c3..c8c1865 100644 --- a/pkgdown/_pkgdown.yml +++ b/pkgdown/_pkgdown.yml @@ -72,6 +72,7 @@ reference: A selection of ready-made filters - contents: - cooldown + - percentile - title: > Actions diff --git a/tests/testthat.R b/tests/testthat.R new file mode 100644 index 0000000..c5801f7 --- /dev/null +++ b/tests/testthat.R @@ -0,0 +1,12 @@ +# This file is part of the standard setup for testthat. +# It is recommended that you do not modify it. +# +# Where should you do additional test configuration? +# Learn more about the roles of various files in: +# * https://r-pkgs.org/testing-design.html#sec-tests-files-overview +# * https://testthat.r-lib.org/articles/special-files.html + +library(testthat) +library(val.criterion) + +test_check("val.criterion") diff --git a/tests/testthat/test-actions.R b/tests/testthat/test-actions.R new file mode 100644 index 0000000..b45af49 --- /dev/null +++ b/tests/testthat/test-actions.R @@ -0,0 +1,84 @@ +test_that("default_actions describes install-style calls to intercept", { + da <- default_actions() + + expect_s3_class(da, "data.frame") + expect_named(da, c("fn", "arg", "action")) + expect_gte(nrow(da), 5L) + + # `fn` and `action` are stored as unevaluated calls/symbols + expect_true(all(vapply(da$fn, is.call, logical(1L)))) + expect_type(da$arg, "character") + + # the standard installers are covered + fns <- vapply(da$fn, deparse, character(1L)) + expect_true("utils::install.packages" %in% fns) + expect_true("renv::install" %in% fns) +}) + +test_that("set_last_rejected / last_rejected round-trip", { + old <- last_rejected() + withr::defer(set_last_rejected(old)) + + set_last_rejected(c("pkgA", "pkgB")) + expect_identical(last_rejected(), c("pkgA", "pkgB")) +}) + +test_that("last_rejected_permit promotes rejected packages to exceptions", { + old_rejected <- last_rejected() + old_exceptions <- opt("exceptions") + withr::defer({ + set_last_rejected(old_rejected) + opt_set("exceptions", old_exceptions) + }) + + opt_set("exceptions", character(0L)) + set_last_rejected(c("foo", "bar")) + + added <- last_rejected_permit(quiet = TRUE) + expect_setequal(added, c("foo", "bar")) + expect_setequal(opt("exceptions"), c("foo", "bar")) +}) + +test_that("last_rejected_permit only adds packages that are not yet exceptions", { + old_rejected <- last_rejected() + old_exceptions <- opt("exceptions") + withr::defer({ + set_last_rejected(old_rejected) + opt_set("exceptions", old_exceptions) + }) + + opt_set("exceptions", "foo") + set_last_rejected(c("foo", "bar")) + + added <- last_rejected_permit(quiet = TRUE) + expect_identical(added, "bar") +}) + +test_that("action_disallow aborts when a filtered package is required", { + old_rejected <- last_rejected() + withr::defer(set_last_rejected(old_rejected)) + + db <- cbind( + Package = "badpkg", + Version = "1.0", + Repository = "", + Depends = NA_character_, + Imports = NA_character_, + LinkingTo = NA_character_ + ) + rownames(db) <- "badpkg" + + expect_error( + action_disallow("badpkg", db = db), + "excluded due to package filters" + ) + + # the offending package is recorded for later inspection + expect_identical(last_rejected(), "badpkg") +}) + +test_that("handle_actions is a no-op without an installer on the call stack", { + db <- cbind(Package = "p", Repository = "https://example.com") + rownames(db) <- "p" + expect_identical(handle_actions(default_actions(), db), db) +}) diff --git a/tests/testthat/test-available_packages.R b/tests/testthat/test-available_packages.R new file mode 100644 index 0000000..658c4d7 --- /dev/null +++ b/tests/testthat/test-available_packages.R @@ -0,0 +1,27 @@ +test_that("repo_packages_url points at src/contrib/PACKAGES", { + expect_identical( + repo_packages_url("https://cran.r-project.org"), + file.path("https://cran.r-project.org", "src", "contrib", "PACKAGES") + ) +}) + +test_that("repo_packages_url is vectorised over repositories", { + urls <- repo_packages_url(c("https://a.example", "https://b.example")) + expect_length(urls, 2L) + expect_true(all(endsWith(urls, file.path("src", "contrib", "PACKAGES")))) +}) + +test_that("build_filter_envir exposes values, falling back to defaults", { + values <- list(a = 1:3) + defaults <- list(a = NA, b = NA) + e <- build_filter_envir( + values = values, + defaults = defaults, + envir = globalenv() + ) + + # a resolved value shadows its default + expect_identical(get("a", envir = e), 1:3) + # a missing value falls through to the default + expect_identical(get("b", envir = e), NA) +}) diff --git a/tests/testthat/test-class_filter.R b/tests/testthat/test-class_filter.R new file mode 100644 index 0000000..bbe56ec --- /dev/null +++ b/tests/testthat/test-class_filter.R @@ -0,0 +1,22 @@ +test_that("filter_class is the package-namespaced filter string", { + expect_identical(filter_class(), "val.criterion::filter") +}) + +test_that("discover_filter finds a filter in available_packages_filters", { + filt <- package_filter({ TRUE })[[2L]] + withr::local_options(available_packages_filters = list(filt)) + expect_identical(discover_filter(), filt) +}) + +test_that("discover_filter ignores non-filter entries", { + filt <- package_filter({ TRUE })[[2L]] + withr::local_options( + available_packages_filters = list("not a filter", filt) + ) + expect_identical(discover_filter(), filt) +}) + +test_that("discover_filter returns NULL when no filter is registered", { + withr::local_options(available_packages_filters = list()) + expect_null(discover_filter()) +}) diff --git a/tests/testthat/test-filter_pipeline.R b/tests/testthat/test-filter_pipeline.R new file mode 100644 index 0000000..0a9e077 --- /dev/null +++ b/tests/testthat/test-filter_pipeline.R @@ -0,0 +1,42 @@ +# End-to-end regression test for the filtering pipeline. +# +# Guards against two coupled defects that broke `available.packages()` filtering +# whenever a populated metric database was present: +# * `is.na()` guards on a matrix / list erroring "condition has length > 1" +# (val.criterion #12, R/available_packages.R). +# * `percentile()` not being exported, so the filter DSL could not resolve it +# (val.criterion #13, R/transforms.R). +# It also depends on val.meter's `metric_coerce()` handling logical/double +# metrics (val.meter #58). + +test_that("package_filter filters a metric repo end to end", { + skip_if_not_installed("val.meter") + skip_if_not_installed("withr") + + # attach val.meter so its lazy `pkg_words` dataset is reachable by random_repo + withr::local_package("val.meter") + + set.seed(1) + repo <- suppressWarnings(val.meter::random_repo(n = 8)) + withr::defer(unlink(sub("^file://", "", repo), recursive = TRUE)) + + withr::local_options( + repos = repo, + val.criterion.repos = repo, + available_packages_filters = package_filter({ + r_cmd_check_error_count == 0 & percentile(downloads_total) >= 0.25 + }) + ) + + # previously errored with "the condition has length > 1" (#12) and + # "could not find function 'percentile'" (#13) + expect_no_error(pkgs <- available.packages()) + + expect_true(nrow(pkgs) > 0) + expect_true("Repository" %in% colnames(pkgs)) + + # the filter should exclude some, but not all, packages + n_filtered <- sum(pkgs[, "Repository"] == "", na.rm = TRUE) + expect_true(n_filtered > 0) + expect_true(n_filtered < nrow(pkgs)) +}) diff --git a/tests/testthat/test-package_filter.R b/tests/testthat/test-package_filter.R new file mode 100644 index 0000000..4acdfd9 --- /dev/null +++ b/tests/testthat/test-package_filter.R @@ -0,0 +1,29 @@ +test_that("package_filter returns an add flag and a classed filter", { + pf <- package_filter({ r_cmd_check_error_count == 0 }) + + expect_type(pf, "list") + expect_true(pf$add) + + filt <- pf[[2L]] + expect_true(is.function(filt)) + expect_true(inherits(filt, filter_class())) +}) + +test_that("package_filter captures the condition unevaluated", { + pf <- package_filter({ downloads_total > 100 }) + expect_identical(attr(pf[[2L]], "cond"), quote({ downloads_total > 100 })) +}) + +test_that("package_filter honours add = FALSE", { + pf <- package_filter({ TRUE }, add = FALSE) + expect_false(pf$add) +}) + +test_that("package_filter assigns unique, incrementing filter names", { + n1 <- names(package_filter({ TRUE }))[2L] + n2 <- names(package_filter({ TRUE }))[2L] + + expect_match(n1, "^val\\.criterion-filter-[0-9]+$") + expect_match(n2, "^val\\.criterion-filter-[0-9]+$") + expect_false(identical(n1, n2)) +}) diff --git a/tests/testthat/test-transforms.R b/tests/testthat/test-transforms.R new file mode 100644 index 0000000..ea08c12 --- /dev/null +++ b/tests/testthat/test-transforms.R @@ -0,0 +1,16 @@ +test_that("percentile returns ecdf-based quantile positions", { + expect_equal(percentile(c(10, 20, 30, 40)), c(0.25, 0.5, 0.75, 1)) +}) + +test_that("percentile is order-independent per element", { + x <- c(40, 10, 30, 20) + expect_equal(percentile(x), c(1, 0.25, 0.75, 0.5)) +}) + +test_that("percentile handles ties by sharing the higher rank", { + expect_equal(percentile(c(1, 1, 2)), c(2 / 3, 2 / 3, 1)) +}) + +test_that("percentile of a single value is 1", { + expect_equal(percentile(42), 1) +}) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R new file mode 100644 index 0000000..8609ff8 --- /dev/null +++ b/tests/testthat/test-utils.R @@ -0,0 +1,20 @@ +test_that("vlapply returns a logical vector", { + expect_identical(vlapply(1:3, function(x) x > 1L), c(FALSE, TRUE, TRUE)) +}) + +test_that("vcapply returns a character vector", { + expect_identical(vcapply(1:2, as.character), c("1", "2")) +}) + +test_that("viapply returns an integer vector", { + expect_identical(viapply(1:2, function(x) x + 1L), c(2L, 3L)) +}) + +test_that("vnapply returns a numeric vector", { + expect_identical(vnapply(1:2, function(x) x / 2), c(0.5, 1)) +}) + +test_that("the vapply wrappers enforce their return type", { + expect_error(vlapply(1:2, function(x) "not logical")) + expect_error(viapply(1:2, function(x) "not integer")) +})