Add more checks on repo status

.Rbuildignore

@@ -4,3 +4,4 @@
 ^assets$
 ^README\.Rmd$
 ^\.github$
+^\.lintr$

.lintr

@@ -0,0 +1,9 @@
+linters: all_linters()
+exclusions: list(
+    "tests/testthat.R",
+    "tests/testthat/test-generate_package_table.R",
+    "R/generate_package_table.R",
+    "R/repo_lists.R" = c(
+      nonportable_path_linter = Inf
+    )
+  )

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: pacta.sit.rep
 Title: What the Package Does (One Line, Title Case)
-Version: 0.0.0.9002
+Version: 0.0.0.9003
 Authors@R: 
     person("Jackson", "Hoffart", , "[email protected]", role = c("aut", "cre"),
            comment = c(ORCID = "0000-0002-8600-5042"))
@@ -10,12 +10,18 @@ Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.3.1
 Suggests: 
+    gt,
+    memoise,
     testthat (>= 3.0.0)
 Config/testthat/edition: 3
 Imports: 
+    base64enc,
     dplyr,
     gh,
     glue,
+    jsonlite,
+    pak,
     purrr,
     rlang,
-    tibble
+    tibble,
+    yaml

R/codeowners.R

@@ -0,0 +1,51 @@
+get_codeowner <- function(
+  repo_fullname,
+  path = ".github/CODEOWNERS", # nolint: non_portable_path
+  format = TRUE
+) {
+  content <- get_gh_text_file(repo_fullname, file_path = path)
+  if (is.null(content)) {
+    return(NULL)
+  }
+  default_owner <- grep(
+    pattern = "^\\s*\\*\\s+@\\S+",
+    x = content,
+    value = TRUE
+  )
+  default_owner_clean <- gsub(
+    pattern = "^\\s*\\*\\s+@|\\s*$",
+    replacement = "",
+    x = default_owner
+  )
+  if (format) {
+    default_owner_clean <- paste0("@", default_owner_clean)
+  }
+  return(default_owner_clean)
+}
+if (requireNamespace("memoise")) {
+  get_codeowner <- memoise::memoise(get_codeowner)
+}
+
+
+get_codeowner_errors <- function(repo_fullname) {
+  raw_content <- tryCatch(
+    expr = {
+      raw_content <- gh::gh(
+        "GET /repos/{repo}/codeowners/errors", # nolint: non_portable_path
+        repo = repo_fullname
+      )
+    },
+    error = function(e) {
+      NA_character_
+    }
+  )
+  if (identical(raw_content, NA_character_)) {
+    # Early return
+    return(NA_integer_)
+  }
+  errors <- raw_content[["errors"]]
+  return(length(errors))
+}
+if (requireNamespace("memoise")) {
+  get_codeowner_errors <- memoise::memoise(get_codeowner_errors)
+}

R/dependencies.R

@@ -0,0 +1,63 @@
+identify_gh_deps <- function(repo_fullname) {
+  deps <- tryCatch(
+    expr = {
+      pak::pkg_deps(repo_fullname)
+    },
+    error = function(e) {
+      NULL
+    }
+  )
+  if (is.null(deps)) {
+    return(NA_character_)
+  }
+  gh_deps <- deps[["type"]] == "github"
+  gh_dep_refs <- deps[gh_deps, "ref"]
+  return(gh_dep_refs)
+}
+if (requireNamespace("memoise")) {
+  identify_gh_deps <- memoise::memoise(identify_gh_deps)
+}
+
+identify_if_dep <- function(
+  repo_fullname,
+  repos_to_check = list(
+    prod = c(prod_workflows, r2dii.repos),
+    experimental = experimental_workflows
+  ),
+  return_max = TRUE
+) {
+
+  dep_lists <- lapply(repos_to_check, function(repos) {
+    deps <- lapply(
+      X = repos,
+      FUN = identify_gh_deps
+    )
+    clean_deps <- unique(unlist(deps))
+    return(clean_deps)
+  })
+
+  dep_levels <- NULL
+  for (i in seq_along(dep_lists)) {
+    if (
+      repo_fullname %in% dep_lists[[i]] ||
+        repo_fullname %in% repos_to_check[[i]]
+    ) {
+      dep_levels <- c(names(dep_lists)[i], dep_levels)
+    }
+  }
+  if (is.null(dep_levels)) {
+    dep_levels <- NA_character_
+  }
+
+  dep_levels_factor <- factor(
+    x = dep_levels,
+    levels = c("experimental", "prod"),
+    ordered = TRUE
+  )
+
+  if (return_max) {
+    return(max(dep_levels_factor))
+  } else {
+    return(dep_levels_factor)
+  }
+}

R/generate_package_table.R

@@ -98,15 +98,15 @@ format_maintainer <- function(maintainer) {
 format_maintainer_v <- Vectorize(format_maintainer)
 
 table_lifecycle <- function(repo_path) {
-  readme <- fetch_readme(repo_path)
+  readme <- get_gh_text_file(repo_path, file_path = "README.md")
 
   if (is.null(readme)) {
     return(NA_character_)
   }
 
-  pattern <- "https://img.shields.io/badge/lifecycle-.*.svg"
+  pattern <- "https://img.shields.io/badge/lifecycle-\\S+.svg"
 
-  lifecycle_badge <- readme[grepl(pattern, readme)]
+  lifecycle_badge <- readme[grepl(pattern, readme)][1]
   lifecycle_badge <- gsub(".*(https[^)]*\\.svg).*", "\\1", lifecycle_badge)
 
   if (length(lifecycle_badge) == 0) {
@@ -136,7 +136,7 @@ table_latest_sha <- function(repo_path) {
 }
 
 table_maintainer <- function(repo_path) {
-  codeowners <- fetch_codeowners(repo_path)
+  codeowners <- get_gh_text_file(repo_path, file_path = ".github/CODEOWNERS")
   if (is.null(codeowners)) {
     return(NA_character_)
   }
@@ -153,22 +153,6 @@ table_maintainer <- function(repo_path) {
   return(maintainer)
 }
 
-fetch_codeowners <- function(repo_path) {
-  response <- tryCatch(
-    gh::gh(
-      "/repos/{repo}/contents/.github/CODEOWNERS",
-      repo = repo_path,
-      ref = "main"
-    ),
-    error = function(cond) return(NULL)
-  )
-
-  if (!is.null(response)) {
-    return(readLines(response$download_url))
-  }
-  return(NULL)
-}
-
 fetch_main_sha <- function(repo_path) {
   response <- tryCatch(
     gh::gh(
@@ -183,18 +167,3 @@ fetch_main_sha <- function(repo_path) {
   }
   return(NULL)
 }
-
-fetch_readme <- function(repo_path) {
-  response <- tryCatch(
-    gh::gh(
-      "/repos/{repo}/contents/README.md",
-      repo = repo_path
-    ),
-    error = function(cond) return(NULL)
-  )
-
-  if (!is.null(response)) {
-    return(readLines(response$download_url))
-  }
-  return(NULL)
-}

R/get_gh_file.R

@@ -0,0 +1,61 @@
+get_gh_text_file <- function(repo_fullname, file_path) {
+  response <- tryCatch(
+    expr = {
+      gh::gh(
+        "/repos/{repo_fullname}/contents/{file_path}", # nolint: non_portable_path
+        repo_fullname = repo_fullname,
+        file_path = file_path
+      )
+    },
+    error = function(cond) return(NULL)
+  )
+  if (is.null(response)) {
+    out <- NULL
+  } else if (response[["content"]] == "") {
+    # files larger than 1MB are not embedded in content
+    out <- readLines(
+      response[["download_url"]]
+    )
+  } else {
+    out <- strsplit(
+      x = rawToChar(
+        base64enc::base64decode(
+          response[["content"]]
+        )
+      ),
+      split = "\n",
+      fixed = TRUE
+    )[[1L]]
+  }
+  return(out)
+}
+if (requireNamespace("memoise")) {
+  get_gh_text_file <- memoise::memoise(get_gh_text_file)
+}
+
+get_gh_dir_listing <- function(repo_fullname, dir_path) {
+  response <- tryCatch(
+    expr = {
+      gh::gh(
+        "/repos/{repo_fullname}/contents/{dir_path}", # nolint: non_portable_path
+        repo_fullname = repo_fullname,
+        dir_path = dir_path
+      )
+    },
+    error = function(cond) return(NULL)
+  )
+  if (is.null(response)) {
+    out <- NULL
+  } else {
+    out <- lapply(
+      response,
+      function(x) {
+        list(
+          name = x[["name"]],
+          path = x[["path"]]
+        )
+      }
+    )
+  }
+  return(out)
+}

R/get_repos.R

@@ -0,0 +1,20 @@
+get_repos <- function(org) {
+  repo_fetch <- gh::gh(
+    "GET /orgs/{org}/repos", # nolint: non_portable_path
+    org = org, per_page  = 20L)
+  all_repos <- repo_fetch
+  while (
+    grepl(
+      pattern = "rel=\"next\"",
+      x = attr(repo_fetch, "response")[["link"]],
+      fixed = TRUE
+    )
+  ) {
+    repo_fetch <- gh::gh_next(repo_fetch)
+    all_repos <- c(all_repos, repo_fetch)
+  }
+  return(all_repos)
+}
+if (requireNamespace("memoise")) {
+  get_repos <- memoise::memoise(get_repos)
+}

R/prod_checks.R

@@ -0,0 +1,53 @@
+prod_checks <- function(repo_json) {
+  if (is.null(repo_json[["codeowner"]])) {
+    codeowner <- get_codeowner(repo_json[["full_name"]])
+    repo_json[["codeowner"]] <- codeowner
+  }
+  if (is.null(repo_json[["codeowner_errors"]])) {
+    codeowner_errors <- get_codeowner_errors(repo_json[["full_name"]])
+    repo_json[["codeowner_errors"]] <- codeowner_errors
+  }
+  if (is.null(repo_json[["gh_deps"]])) {
+    gh_deps <- identify_gh_deps(repo_json[["full_name"]])
+    repo_json[["gh_deps"]] <- gh_deps
+  }
+  if (is.null(repo_json[["dep_tree"]])) {
+    dep_tree <- identify_if_dep(repo_json[["full_name"]])
+    repo_json[["dep_tree"]] <- dep_tree
+  }
+  if (is.null(repo_json[["lifecycle_badge"]])) {
+    lifecycle_badge <- format_lifecycle(
+      table_lifecycle(repo_json[["full_name"]])
+    )
+    repo_json[["lifecycle_badge"]] <- lifecycle_badge
+  }
+  if (is.null(repo_json[["has_docker"]])) {
+    repo_json[["has_docker"]] <- !is.null(
+      get_gh_text_file(repo_json[["full_name"]], "Dockerfile")
+    )
+  }
+  if (is.null(repo_json[["has_R"]])) {
+    repo_json[["has_R"]] <- !is.null(
+      get_gh_dir_listing(repo_json[["full_name"]], "R")
+    )
+  }
+  expected_workflows <- NULL
+  if (repo_json[["has_R"]]) {
+    expected_workflows <- c(expected_workflows, "R.yml")
+  }
+  if (repo_json[["has_docker"]]) {
+    expected_workflows <- c(expected_workflows, "docker.yml")
+  }
+  if (is.null(repo_json[["workflows"]])) {
+    workflows <- workflow_summary(repo_json[["full_name"]])
+    repo_json[["workflows"]] <- workflows
+  }
+  if (is.null(repo_json[["enabled_rules"]])) {
+    enabled_rules <- check_actions_rulesets(repo_json[["full_name"]])
+    repo_json[["enabled_rules"]] <- enabled_rules
+  }
+  return(repo_json)
+}
+if (requireNamespace("memoise")) {
+  prod_checks <- memoise::memoise(prod_checks)
+}

R/repo_lists.R

@@ -0,0 +1,23 @@
+prod_workflows <- c(
+  "RMI-PACTA/pactaverse",
+  "RMI-PACTA/workflow.data.preparation",
+  "RMI-PACTA/workflow.portfolio.parsing",
+  "RMI-PACTA/workflow.prepare.pacta.indices",
+  "RMI-PACTA/workflow.scenario.preparation",
+  "RMI-PACTA/workflow.transition.monitor"
+)
+
+r2dii.repos <- c(
+  "RMI-PACTA/r2dii.data",
+  "RMI-PACTA/r2dii.match",
+  "RMI-PACTA/r2dii.analysis",
+  "RMI-PACTA/r2dii.plot"
+)
+
+experimental_workflows <- c(
+  "RMI-PACTA/workflow.mfm2023",
+  "RMI-PACTA/workflow.pacta",
+  "RMI-PACTA/workflow.pacta.data.qa",
+  "RMI-PACTA/workflow.pacta.report"
+)
+