freezing and timing in staging

DESCRIPTION

@@ -2,7 +2,7 @@ Package: multiverse.internals
 Title: Internal Infrastructure for R-multiverse
 Description: R-multiverse requires this internal internal infrastructure
   package to automate contribution reviews and populate universes.
-Version: 0.2.9
+Version: 0.2.10
 License: MIT + file LICENSE
 URL: https://github.com/r-multiverse/multiverse.internals
 BugReports: https://github.com/r-multiverse/multiverse.internals/issues

NAMESPACE

@@ -15,6 +15,7 @@ export(record_issues)
 export(record_versions)
 export(review_pull_request)
 export(review_pull_requests)
+export(staging_is_active)
 export(try_message)
 export(update_staging)
 importFrom(gh,gh)

NEWS.md

@@ -1,3 +1,8 @@
+# multiverse.internals 0.2.10
+
+* Implement freezing mechanism in `update_staging()`.
+* Implement `staging_is_active()` to detect when the staging universe should be active.
+
 # multiverse.internals 0.2.9
 
 * Implement community/staging idea from (@jeroen).

R/staging_is_active.R

@@ -7,13 +7,15 @@
 #'   staging universe becomes active.
 #' @param duration Positive integer, number of days that the staging
 #'   universe remains active after each threshold.
+#' @param today Character string with today's date in `"%Y-%m-%d"` format.
 #' @examples
 #' staging_is_active()
 staging_is_active <- function(
   thresholds = c("01-15", "04-15", "07-15", "10-15"),
-  duration = 30L
+  duration = 30L,
+  today = format(Sys.Date(), "%Y-%m-%d")
 ) {
-  year <- format(Sys.Date(), "%Y")
+  year <- format(as.Date(today), "%Y")
   thresholds <- paste0(year, "-", thresholds)
   spec <- "%Y-%m-%d"
   spans <- lapply(
@@ -25,5 +27,5 @@ staging_is_active <- function(
       )
     }
   )
-  format(Sys.Date(), spec) %in% unlist(spans)
+  today %in% unlist(spans)
 }

R/update_staging.R

@@ -37,20 +37,21 @@ update_staging <- function(
   file_community <- file.path(path_community, "packages.json")
   json_staging <- jsonlite::read_json(file_staging, simplifyVector = TRUE)
   json_community <- jsonlite::read_json(file_community, simplifyVector = TRUE)
+  meta_community <- mock$community %||% meta_packages(repo_community)
   issues <- list.files(
     file.path(path_staging, "issues"),
     all.files = TRUE,
     no.. = TRUE
   )
-  freeze <- setdiff(meta_staging$package, issues)
+  freeze <- setdiff(json_staging$package, issues)
   update <- setdiff(json_community$package, freeze)
-  json_freeze <- json_staging[json_staging$package %in% freeze, ]
+  should_freeze <- json_staging$package %in% freeze
+  json_freeze <- json_staging[should_freeze, ]
   json_update <- json_community[json_community$package %in% update, ]
   json_freeze$subdir <- json_freeze$subdir %||%
     rep(NA_character_, nrow(json_freeze))
   json_update$subdir <- json_update$subdir %||%
     rep(NA_character_, nrow(json_update))
-  meta_community <- mock$community %||% meta_packages(repo_community)
   branches <- meta_community[
     meta_community$package %in% update,
     c("package", "remotesha")

inst/mock/community/packages.json

@@ -1,32 +1,17 @@
 [
   {
-    "package": "promote",
-    "url": "https://github.com/owner/promote",
+    "package": "add",
+    "url": "https://github.com/owner/add",
     "branch": "*release"
   },
   {
-    "package": "change",
-    "url": "https://github.com/owner/change",
+    "package": "freeze",
+    "url": "https://github.com/owner/freeze",
     "branch": "*release"
   },
   {
-    "package": "keep",
-    "url": "https://github.com/owner/keep",
-    "branch": "*release"
-  },
-  {
-    "package": "checks",
-    "url": "https://github.com/owner/checks",
-    "branch": "*release"
-  },
-  {
-    "package": "descriptions",
-    "url": "https://github.com/owner/descriptions",
-    "branch": "*release"
-  },
-  {
-    "package": "versions",
-    "url": "https://github.com/owner/versions",
+    "package": "issue",
+    "url": "https://github.com/owner/issue",
     "branch": "*release"
   }
 ]

inst/mock/staging/issues/removed-has-issue

@@ -0,0 +1,13 @@
+{
+  "checks": {
+    "_linuxdevel": ["success"],
+    "_macbinary": ["success"],
+    "_wasmbinary": ["none"],
+    "_winbinary": ["success"],
+    "_status": ["success"],
+    "_buildurl": ["https://github.com/r-universe/r-multiverse/actions/runs/12345"]
+  },
+  "date": ["1980-01-01"],
+  "version": ["2.0.2"],
+  "remote_hash": ["abcdef1234567890abcdef"]
+}

inst/mock/staging/packages.json

@@ -1,12 +1,22 @@
 [
   {
-    "package": "change",
-    "url": "https://github.com/owner/change",
+    "package": "freeze",
+    "url": "https://github.com/owner/freeze",
     "branch": "original"
   },
   {
-    "package": "keep",
-    "url": "https://github.com/owner/keep",
-    "branch": "sha-keep"
+    "package": "issue",
+    "url": "https://github.com/owner/issue",
+    "branch": "original"
+  },
+  {
+    "package": "removed-has-issue",
+    "url": "https://github.com/owner/removed-has-issue",
+    "branch": "original"
+  },
+  {
+    "package": "removed-no-issue",
+    "url": "https://github.com/owner/removed-no-issue",
+    "branch": "original"
   }
 ]

tests/testthat/test-staging_is_active.R

@@ -0,0 +1,46 @@
+test_that("staging_is_active()", {
+  thresholds <- c("01-15", "04-15", "07-15", "10-15")
+  duration <- 30L
+  active <- c(
+    "2024-01-15",
+    "2024-01-16",
+    "2024-02-13",
+    "2024-04-15",
+    "2024-04-25",
+    "2024-05-14",
+    "2024-07-15",
+    "2024-08-12",
+    "2024-08-13",
+    "2024-10-15",
+    "2024-11-01",
+    "2024-11-13"
+  )
+  for (today in active) {
+    expect_true(
+      staging_is_active(
+        thresholds = thresholds,
+        duration = duration,
+        today = today
+      )
+    )
+  }
+  inactive <- c(
+    "2024-01-12",
+    "2024-02-14",
+    "2024-04-14",
+    "2024-05-15",
+    "2024-07-12",
+    "2024-08-14",
+    "2024-10-14",
+    "2024-11-14"
+  )
+  for (today in inactive) {
+    expect_false(
+      staging_is_active(
+        thresholds = thresholds,
+        duration = duration,
+        today = today
+      )
+    )
+  }
+})

tests/testthat/test-update_staging.R

@@ -22,32 +22,38 @@ test_that("update_staging()", {
     to = dir_community,
     recursive = TRUE
   )
-  json <- jsonlite::read_json(file.path(path_community, "packages.json"))
-  names <- vapply(
-    json,
+  file_staging <- file.path(path_staging, "packages.json")
+  file_community <- file.path(path_community, "packages.json")
+  json_staging <- jsonlite::read_json(file_staging)
+  json_community <- jsonlite::read_json(file_community)
+  names_community <- vapply(
+    json_community,
     function(x) x$package,
     FUN.VALUE = character(1L)
   )
   meta_community <- data.frame(
-    package = names,
-    remotesha = paste0("sha-", names)
+    package = names_community,
+    remotesha = paste0("sha-", names_community)
   )
   update_staging(
     path_staging = path_staging,
     path_community = path_community,
     mock = list(community = meta_community)
   )
-  packages <- jsonlite::read_json(
-    file.path(path_staging, "packages.json"),
-    simplifyVector = TRUE
-  )
+  packages <- jsonlite::read_json(file_staging, simplifyVector = TRUE)
   expect_true(is.data.frame(packages))
   expect_equal(dim(packages), c(4L, 3L))
-  names <- c("change", "checks", "keep", "promote")
+  names <- c("add", "freeze", "issue", "removed-no-issue")
   expect_equal(sort(packages$package), sort(names))
   expect_equal(
     packages$url,
     file.path("https://github.com/owner", packages$package)
   )
-  expect_equal(packages$branch, paste0("sha-", packages$package))
+  expect_equal(packages$branch[packages$package == "add"], "sha-add")
+  expect_equal(packages$branch[packages$package == "freeze"], "original")
+  expect_equal(packages$branch[packages$package == "issue"], "sha-issue")
+  expect_equal(
+    packages$branch[packages$package == "removed-no-issue"],
+    "original"
+  )
 })