Merge pull request #5 from pharmaR/4-risk-filter-updates

Draft: automatically discover additional available.packages fields

.Rbuildignore

@@ -2,5 +2,6 @@
 ^\.Rproj\.user$
 ^data-raw$
 ^README\.Rmd$
+^README\.html$
 ^LICENSE\.md$
 tmp

.gitignore

@@ -3,3 +3,5 @@
 .RData
 .Ruserdata
 tmp
+
+*.html

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: pharmapkgs
 Title: Installation of Validated Packages
-Version: 0.0.1
+Version: 0.0.1.9000
 Authors@R: c(
     person("Ramiro", "Magno", , "rmagno@pattern.institute", role = c("aut", "cre"),
            comment = c(ORCID = "0000-0001-5226-3441")),
@@ -11,7 +11,7 @@ Description: Routines to list, install and filter risk-assessed packages.
 License: MIT + file LICENSE
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2
 Imports: 
     curl,
     dplyr,
@@ -22,4 +22,4 @@ Imports:
     snakecase,
     tibble
 Remotes:
-    riskscore=git::https://github.com/pharmaR/riskscore.git
+    riskscore=github::pharmaR/riskscore

R/risk_filter.R

@@ -1,14 +1,127 @@
+#' Create a Risk Filter Function
+#'
+#' Create a risk filter function, with the intended purpose of being provided
+#' to [`utils::available.packages()`]'s `filter` argument, or for use with
+#' the `available_packages_filter` option.
+#'
+#' @param ... Conditions to use when specifying a risk criteria. Uses
+#'   non-standard evaluation, treating risk field names as columns of package
+#'   metadata.
+#' @param fields A character vector of field names used in the provided `...`
+#'   conditions. When `NULL`, the default, all known risk field names will be
+#'   considered.
+#'
 #' @export
-risk_filter <- function(...) {
-  conditions <- rlang::quos(...)
+risk_filter <- function(..., fields = risk_filter_fields(...)) {
+  risk_filter_fn <- risk_filter_from_conditions(...)
+
+  # For older version of R, use non-standard evaluation to automatically 
+  # insert additional repository fields
+  if (!has_available_packages_field_option()) {
+    risk_filter_fn <- risk_filter_with_inserted_fields(risk_filter_fn, fields)
+  }
 
   # List of a function as needed by `available.packages()` for filtering.
-  list(function(pkgs) {
-    pkgs |>
+  list(add = TRUE, risk_filter = risk_filter_fn)
+}
+
+#' Retrieve all known risk fields
+#' 
+#' @name risk-filter-helpers
+#' @export
+risk_filter_fields <- function(...) {
+  all_used_names <- unlist(lapply(substitute(...()), all.names))
+  all_fields_files <- list.files(
+    system.file(package = packageName()),
+    pattern = "RISKFIELDS",
+    recursive = TRUE,
+    full.names = TRUE
+  )
+
+  all_fields <- unique(unlist(lapply(dirname(all_fields_files), risk_fields)))
+  intersect(all_used_names, all_fields)
+}
+
+#' Session uses the "available_packages_field" global option
+#' 
+#' Test whether the current session makes use of the 
+#' global option, as discussed in the 
+#' [`R-devel` mailing list](https://stat.ethz.ch/pipermail/r-devel/2024-June/083477.html).
+#' When used, it is expected that this global option is configured to permit
+#' additional fields to be used by filters. This test can be replaced by an
+#' exact version number once available.
+#' 
+#' @name risk-filter-helpers
+has_available_packages_field_option <- function() {
+  # to be changed to patch version upon release
+  ver <- R.Version()
+  as.numeric(ver[["svn rev"]]) >= 86757
+}
+
+#' Generate a random id for a risk filter
+#' 
+#' @name risk-filter-helpers
+risk_filter_id <- function() {
+  paste(as.character(as.raw(sample(0:255, 16))), collapse = "")
+}
+
+#' Generate a function to filter available packages by a set of conditions
+#'
+#' @inheritParams risk_filter
+#'
+#' @name risk-filter-helpers
+risk_filter_from_conditions <- function(...) {
+  conditions <- rlang::quos(...)
+  function(packages) {
+    # TODO: Note that `packages` is the matrix returned by
+    # `available.packages()` which is of type character. We will need to
+    # coerce the risk metrics' columns to appropriate type.
+    packages |>
       tibble::as_tibble() |>
-      # TODO: Note that `pkgs` is the matrix returned by `available.packages()`
-      #       which is of type character. We will need to coerce the risk
-      #       metrics' columns to appropriate type.
       dplyr::filter(!!!conditions)
-  })
+  }
+}
+
+#' Modify a available packages filter function to make use of a set of fields
+#'
+#' @param f A [`utils::available.packages()`] filter function
+#' @inheritParams risk_filter
+#' 
+#' @name risk-filter-helpers
+risk_filter_with_inserted_fields <- function(f, fields) {
+  force(f)
+  id <- risk_filter_id()
+  filter_func <- function(ap) {
+    # deduce which filters were used when calling available.packages
+    ap_call <- match.call(sys.function(-1), sys.call(-1), expand.dots = TRUE)
+    ap_filters <- if (!is.null(ap_call$filters)) {
+      eval(ap_call$filters, envir = parent.frame(2))
+    } else {
+      global_filters()
+    }
+
+    is_risk_filter <- function(x) identical(attr(x, "id"), id)
+    idx_self_filter <- Position(is_risk_filter, ap_filters, 1L)
+    prior_filters <- utils::head(ap_filters, idx_self_filter - 1L)
+
+    # remove trailing list(add = TRUE) if sole remaining element
+    has_prior_fn_filter <- any(vapply(prior_filters, is.function, logical(1L)))
+    is_add <- names(prior_filters) == "add"
+    if (any(is_add) && !has_prior_fn_filter) {
+      prior_filters <- prior_filters[!is_add]
+      # if no filters remain, use defaults
+      if (length(prior_filters) <= 0) {
+        prior_filters <- utils:::available_packages_filters_default
+      }
+    }
+
+    # re-calculate our available.packages with required risk fields
+    ap_call["filters"] <- list(prior_filters)
+    ap_call$fields <- eval(ap_call$fields, envir = parent.frame())
+    ap_call$fields <- unique(c(ap_call$fields, fields))
+    prior_pkgs <- eval(ap_call, envir = parent.frame(2))
+    f(prior_pkgs)
+  }
+
+  structure(filter_func, id = id)
 }

R/utils.R

@@ -0,0 +1,14 @@
+`%||%` <- function(lhs, rhs) {
+  if (is.null(lhs)) rhs else lhs
+}
+
+#' Retrieve global available packages filters
+#' 
+#' @noRd
+global_filters <- function() {
+  getOption(
+    "available_packages_filters",
+    # TODO: find alternative that doesn't use internal function, hardcode?
+    utils:::available_packages_filters_default
+  )
+}

README.Rmd

@@ -82,32 +82,21 @@ Configure a session to leverage a bundled repo.
 repo <- bundled_repos("ubuntu-22.04")
 options(
   # importantly, repo is called CRAN such that pak doesn't insert a CRAN mirror
+  # awaiting feature r-lib/pak#637
   repos = c(CRAN = repo)
 )
 
 nrow(available.packages())
 ```
 
-For ease of use, modify `available.packages` to globally take a default
-value from `options(available_packages_fields)`, allowing the use of those
-fields within `risk_filter()`.
-
-This allows `pak` to leverage the same internal mechanisms for fetching
-packages and ensuring, at the time of download, that packages adhere to the 
-filters that we specify.
-
-```{r}
-formals(available.packages)$fields <-
-  quote(getOption("available_packages_fields", NULL))
-```
+We can provide a filter based on various risk criteria, that will allow `pak` to
+leverage the same internal mechanisms for fetching packages and ensuring, at the
+time of download, that packages adhere to the filters that we specify.
 
 Now apply a filter and observe a reduced subset of available packages.
 
 ```{r}
 options(
-  # ensure additional fields are available for risk filters
-  available_packages_fields = risk_fields(repo),
-  # provide a custom package filter
   available_packages_filters = risk_filter(
     RemoteChecks > 0.9,
     HasNews == "1"
@@ -121,7 +110,7 @@ Install a package, and confirm that the package was pulled from the bundled
 download location, ensuring that the downloaded version of the package is the
 same that was used to derive the risk metrics.
 
-```r
+```{r}
 pak::cache_clean()
 pkg <- "colorspace"
 

README.md

@@ -4,6 +4,7 @@
 # pharmapkgs
 
 <!-- badges: start -->
+
 <!-- badges: end -->
 
 The goal of `{pharmapkgs}` is to facilitate the interfacing with
@@ -101,33 +102,23 @@ Configure a session to leverage a bundled repo.
 repo <- bundled_repos("ubuntu-22.04")
 options(
   # importantly, repo is called CRAN such that pak doesn't insert a CRAN mirror
+  # awaiting feature r-lib/pak#637
   repos = c(CRAN = repo)
 )
 
 nrow(available.packages())
 #> [1] 106
 ```
 
-For ease of use, modify `available.packages` to globally take a default
-value from `options(available_packages_fields)`, allowing the use of
-those fields within `risk_filter()`.
-
-This allows `pak` to leverage the same internal mechanisms for fetching
-packages and ensuring, at the time of download, that packages adhere to
-the filters that we specify.
-
-``` r
-formals(available.packages)$fields <-
-  quote(getOption("available_packages_fields", NULL))
-```
+We can provide a filter based on various risk criteria, that will allow
+`pak` to leverage the same internal mechanisms for fetching packages and
+ensuring, at the time of download, that packages adhere to the filters
+that we specify.
 
 Now apply a filter and observe a reduced subset of available packages.
 
 ``` r
 options(
-  # ensure additional fields are available for risk filters
-  available_packages_fields = risk_fields(repo),
-  # provide a custom package filter
   available_packages_filters = risk_filter(
     RemoteChecks > 0.9,
     HasNews == "1"
@@ -150,5 +141,19 @@ if (pkg %in% rownames(installed.packages()))
   pak::pkg_remove(pkg)
 
 install_stats <- pak::pkg_install(pkg)
+#> ℹ Loading metadata database
+#> ✔ Loading metadata database ... done
+#> 
+#> 
+#> → Will install 1 package.
+#> → Will download 1 package with unknown size.
+#> + colorspace   2.1-0 [dl]
+#> 
+#> ℹ Getting 1 pkg with unknown size
+#> ✔ Got colorspace 2.1-0 (x86_64-pc-linux-gnu-ubuntu-22.04) (2.63 MB)
+#> ✔ Installed colorspace 2.1-0  (73ms)
+#> ✔ 1 pkg: added 1, dld 1 (2.63 MB) [3.3s]
 install_stats$sources
+#> [[1]]
+#> [1] "https://github.com/cran/colorspace/releases/download/2.1-0/colorspace_2.1-0_b1_R4.4_x86_64-pc-linux-gnu-ubuntu-22.04.tar.gz"
 ```