Merge pull request #22 from ropensci-review-tools/issues

issues linked to change request metric for  #11

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: repometrics
 Title: Metrics for Your Code Repository
-Version: 0.1.1.009
+Version: 0.1.1.016
 Authors@R: 
     person("Mark", "Padgham", , "[email protected]", role = c("aut", "cre"),
            comment = c(ORCID = "0000-0003-2172-5265"))

R/chaoss-external.R

@@ -34,3 +34,28 @@ has_gh_ci_tests <- function (path) {
     h <- gert::git_log (repo = path, max = 1e6)
     any (ci_data$sha %in% h$commit)
 }
+
+#' The "Ratio of Code Commits linked with Change Requests" CHAOSS metric. This
+#' is defined as, "Percentage of new code commits linked with change requests
+#' in the last 90 days."
+#' \url{https://chaoss.community/kb/metrics-model-collaboration-development-index/}.
+prop_commits_in_change_req <- function (path, end_date = Sys.Date ()) {
+
+    or <- org_repo_from_path (path)
+
+    gh_dat <- github_issues_prs_query (org = or [1], repo = or [2])
+
+    # Reduce to PR open-close events:
+    gh_prs <- dplyr::filter (gh_dat, !is.na (number)) |>
+        dplyr::group_by (number) |>
+        dplyr::filter (action == "closed")
+
+    start_date <- as.Date (end_date - get_repometrics_period ())
+    index <- which (as.Date (gh_prs$merged_at) >= start_date)
+
+    num_commits_from_prs <- sum (gh_prs$commits [index])
+
+    log <- git_log_in_period (path, end_date, get_repometrics_period ())
+
+    ifelse (nrow (log) == 0, 0, num_commits_from_prs / nrow (log))
+}

R/chaoss-hybrid.R

@@ -1,7 +1,10 @@
 # Hybird metrics from both internal structure and external data
 
 chaoss_metric_has_ci <- function (path) {
-    has_ci <- has_gh_ci_tests (path)
+
+    is_test_env <- Sys.getenv ("REPOMETRICS_TESTS") == "true"
+    has_ci <- ifelse (is_test_env, FALSE, has_gh_ci_tests (path))
+
     if (!has_ci) {
         ci_files <- repo_has_ci_files (path)
         has_ci <- length (ci_files) > 0L

R/gh-queries.R

@@ -30,7 +30,7 @@ github_repo_workflow_query <- function (org = NULL, repo = NULL, n = 30L) {
     status <- vapply (workflows, function (i) i$status, character (1L))
     conclusion <- vapply (workflows, function (i) i$conclusion, character (1L))
     created <- vapply (workflows, function (i) i$created_at, character (1L))
-    created <- as.POSIXct (created, format = "%Y-%m-%dT%H:%M:%S", tz = "UTC")
+    created <- to_posix (created)
 
     data.frame (
         name = names,
@@ -42,3 +42,140 @@ github_repo_workflow_query <- function (org = NULL, repo = NULL, n = 30L) {
         created = created
     )
 }
+
+#' Use the GitHub Rest API activity list to extract event types.
+#' Activity requests are described at
+#' \url{https://docs.github.com/en/rest/repos/repos?apiVersion=2022-11-28#list-repository-activities}
+#' and the list of all event types is at
+#' \url{https://docs.github.com/en/rest/using-the-rest-api/github-event-types?apiVersion=2022-11-28}.
+#' @noRd
+github_issues_prs_query <- function (org = NULL, repo = NULL) {
+
+    u_base <- "https://api.github.com/repos/"
+    u_repo <- paste0 (u_base, org, "/", repo, "/")
+
+    is_test_env <- Sys.getenv ("REPOMETRICS_TESTS") == "true"
+    url0 <- paste0 (u_repo, "events?per_page=", ifelse (is_test_env, 2, 100))
+
+    body <- NULL
+    next_page <- 1
+    this_url <- url0
+    while (!is.null (next_page)) {
+
+        req <- httr2::request (this_url) |>
+            add_token_to_req ()
+
+        resp <- httr2::req_perform (req)
+        httr2::resp_check_status (resp)
+
+        this_body <- httr2::resp_body_json (resp)
+        body <- c (body, this_body)
+
+        next_page <- get_next_page (resp)
+        if (is_test_env) {
+            next_page <- NULL
+        }
+        this_url <- paste0 (url0, "&page=", next_page)
+    }
+
+    # Extraction function for single fields which may not be present
+    extract_one <- function (body, field = "action", naval = NA_character_) {
+        ret_type <- do.call (typeof (naval), list (1L))
+        vapply (body, function (i) {
+            ifelse (field %in% names (i$payload), i$payload [[field]], naval)
+        }, ret_type)
+    }
+
+    # Extraction function for doubly-nexted fields which may not be present
+    extract_two <- function (body,
+                             field1 = "pull_request",
+                             field2 = "comments",
+                             naval = NA_character_) {
+
+        ret_type <- do.call (typeof (naval), list (1L))
+        vapply (body, function (i) {
+            ret <- naval
+            if (field1 %in% names (i$payload)) {
+                if (field2 %in% names (i$payload [[field1]])) {
+                    ret <- i$payload [[field1]] [[field2]]
+                }
+            }
+            ifelse (is.null (ret), naval, ret)
+        }, ret_type)
+    }
+
+    # Items which are always present:
+    ids <- vapply (body, function (i) i$id, character (1L))
+    type <- vapply (body, function (i) i$type, character (1L))
+    login <- vapply (body, function (i) i$actor$login, character (1L))
+
+    # Single-nested items:
+    action <- extract_one (body, "action", NA_character_)
+    number <- extract_one (body, "number", NA_integer_)
+
+    # Doubly-nested items:
+    num_comments <- extract_two (body, "pull_request", "comments", NA_integer_)
+    num_review_comments <-
+        extract_two (body, "pull_request", "review_comments", NA_integer_)
+    commits <- extract_two (body, "pull_request", "commits", NA_integer_)
+    additions <- extract_two (body, "pull_request", "additions", NA_integer_)
+    deletions <- extract_two (body, "pull_request", "deletions", NA_integer_)
+    changed_files <-
+        extract_two (body, "pull_request", "changed_files", NA_integer_)
+    created_at <-
+        extract_two (body, "pull_request", "created_at", NA_character_)
+    created_at <- to_posix (created_at)
+    merged_at <-
+        extract_two (body, "pull_request", "created_at", NA_character_)
+    merged_at <- to_posix (merged_at)
+
+    data.frame (
+        id = ids,
+        type = type,
+        login = login,
+        action = action,
+        number = number,
+        commits = commits,
+        num_comments = num_comments,
+        num_review_comments = num_review_comments,
+        additions = additions,
+        deletions = deletions,
+        changed_files = changed_files,
+        created_at = created_at,
+        merged_at = merged_at
+    )
+}
+
+add_token_to_req <- function (req) {
+
+    if (!nzchar (Sys.getenv ("GITHUB_WORKFLOW"))) {
+        tok <- get_gh_token ()
+        headers <- list (Authorization = paste0 ("Bearer ", tok))
+        req <- httr2::req_headers (req, "Authorization" = headers)
+    }
+
+    return (req)
+}
+
+#' Pagination for Rest API. see
+#' https://docs.github.com/en/rest/using-the-rest-api/using-pagination-in-the-rest-api
+#' @noRd
+get_next_page <- function (resp) {
+
+    link <- httr2::resp_headers (resp)$link
+
+    next_page <- NULL
+
+    if (!is.null (link)) {
+        next_ptn <- "rel\\=\\\"next"
+        if (grepl (next_ptn, link)) {
+            # "next" is always first; where there are multiples, "prev" comes
+            # after "next"
+            ptn <- "<([^>]+)>"
+            next_page <- regmatches (link, regexpr (ptn, link))
+            next_page <- gsub ("^.*&page\\=|>", "", next_page)
+        }
+    }
+
+    return (next_page)
+}

R/utils.R

@@ -28,6 +28,10 @@ set_num_cores <- function (num_cores) {
     return (num_cores)
 }
 
+to_posix <- function (x) {
+    as.POSIXct (x, format = "%Y-%m-%dT%H:%M:%S", tz = "UTC")
+}
+
 # nocov start
 get_gh_token <- function () {
     e <- Sys.getenv ()

codemeta.json

@@ -8,7 +8,7 @@
   "codeRepository": "https://github.com/ropensci-review-tools/repometrics",
   "issueTracker": "https://github.com/ropensci-review-tools/repometrics/issues",
   "license": "https://spdx.org/licenses/GPL-3.0",
-  "version": "0.1.1.009",
+  "version": "0.1.1.016",
   "programmingLanguage": {
     "@type": "ComputerLanguage",
     "name": "R",

inst/httptest2/redact.R

@@ -14,6 +14,13 @@ function (resp) {
         fixed = TRUE
     )
 
+    resp <- httptest2::gsub_response (
+        resp,
+        "ropensci-review-tools/goodpractice",
+        "repo/",
+        fixed = TRUE
+    )
+
     test_repo <- "ropensci-review-tools/repometrics"
     resp <- httptest2::gsub_response (
         resp,

tests/testthat/_snaps/chaoss-metrics-hybrid.md

@@ -0,0 +1,7 @@
+# chaoss metric has_ci
+
+    Code
+      chk <- chaoss_metric_has_ci(path)
+    Message
+      i Unable to determine whether runs are recent for CI service [github].
+