chore: refactor; add check for upcoming R release

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,

R/risk_filter.R

@@ -12,68 +12,116 @@
 #'   considered.
 #'
 #' @export
-risk_filter <- function(..., fields = NULL) {
-  conditions <- rlang::quos(...)
-  id <- paste(as.character(as.raw(sample(0:255, 16))), collapse = "")
-
-  if (is.null(fields)) {
-    all_fields_files <- list.files(
-      system.file(package = packageName()),
-      pattern = "RISKFIELDS",
-      recursive = TRUE,
-      full.names = TRUE
-    )
+risk_filter <- function(..., fields = risk_filter_fields(...)) {
+  risk_filter_fn <- risk_filter_from_conditions(...)
 
-    fields <- unique(unlist(lapply(dirname(all_fields_files), risk_fields)))
+  # 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)
   }
 
-  req_fields <- intersect(
-    unlist(lapply(conditions, all.names)),
-    fields
+  # List of a function as needed by `available.packages()` for filtering.
+  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
   )
 
-  # List of a function as needed by `available.packages()` for filtering.
-  list(
-    add = TRUE,
-    risk_filter = structure(function(pkgs) {
-      # we'll use the parent call to `available.packages()` to re-evalauate
-      # available.packages as though the appropriate risk fields were included
+  all_fields <- unique(unlist(lapply(dirname(all_fields_files), risk_fields)))
+  intersect(all_used_names, all_fields)
+}
 
-      browser()
+#' 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
+}
 
-      # 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()
-      }
+#' 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 = "")
+}
 
-      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)
+#' 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() |>
+      dplyr::filter(!!!conditions)
+  }
+}
 
-      # re-calculate our available.packages with required risk fields
-      ap_call$filters <- prior_filters
-      ap_call$fields <- eval(ap_call$fields, envir = parent.frame())
-      ap_call$fields <- unique(c(ap_call$fields, req_fields))
-      prior_pkgs <- eval(ap_call, envir = parent.frame(2))
+#' 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()
+    }
 
-      # TODO: Note that `prior_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.
+    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)
 
-      prior_pkgs |>
-        tibble::as_tibble() |>
-        dplyr::filter(!!!conditions)
-    }, id = id)
-  )
-}
+    # 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
+      }
+    }
 
-global_filters <- function() {
-  getOption(
-    "available_packages_filters",
-    # TODO: find alternative that doesn't use internal function, hardcode?
-    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

@@ -1,3 +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
+  )
+}