13 export percentil filter

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

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)

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

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)
 }

pkgdown/_pkgdown.yml

@@ -72,6 +72,7 @@ reference:
       A selection of ready-made filters
   - contents:
       - cooldown
+      - percentile
 
   - title: >
       Actions

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")

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 = "<filtered>",
+    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)
+})

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)
+})

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())
+})

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"] == "<filtered>", na.rm = TRUE)
+  expect_true(n_filtered > 0)
+  expect_true(n_filtered < nrow(pkgs))
+})

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))
+})

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)
+})

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"))
+})