Skip to content

Commit 7b44c2b

Browse files
mpadgempadge
authored
Merge pull request #22 from ropensci-review-tools/issues
issues linked to change request metric for #11
2 parents 062c43e + 0bd82b2 commit 7b44c2b

11 files changed

+498
-4
lines changed

‎DESCRIPTION

+1-1
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
Package: repometrics
22
Title: Metrics for Your Code Repository
3-
Version: 0.1.1.009
3+
Version: 0.1.1.016
44
Authors@R:
55
person("Mark", "Padgham", , "mark.padgham@email.com", role = c("aut", "cre"),
66
comment = c(ORCID = "0000-0003-2172-5265"))

‎R/chaoss-external.R

+25
Original file line numberDiff line numberDiff line change
@@ -34,3 +34,28 @@ has_gh_ci_tests <- function (path) {
3434
h <- gert::git_log (repo = path, max = 1e6)
3535
any (ci_data$sha %in% h$commit)
3636
}
37+
38+
#' The "Ratio of Code Commits linked with Change Requests" CHAOSS metric. This
39+
#' is defined as, "Percentage of new code commits linked with change requests
40+
#' in the last 90 days."
41+
#' \url{https://chaoss.community/kb/metrics-model-collaboration-development-index/}.
42+
prop_commits_in_change_req <- function (path, end_date = Sys.Date ()) {
43+
44+
or <- org_repo_from_path (path)
45+
46+
gh_dat <- github_issues_prs_query (org = or [1], repo = or [2])
47+
48+
# Reduce to PR open-close events:
49+
gh_prs <- dplyr::filter (gh_dat, !is.na (number)) |>
50+
dplyr::group_by (number) |>
51+
dplyr::filter (action == "closed")
52+
53+
start_date <- as.Date (end_date - get_repometrics_period ())
54+
index <- which (as.Date (gh_prs$merged_at) >= start_date)
55+
56+
num_commits_from_prs <- sum (gh_prs$commits [index])
57+
58+
log <- git_log_in_period (path, end_date, get_repometrics_period ())
59+
60+
ifelse (nrow (log) == 0, 0, num_commits_from_prs / nrow (log))
61+
}

‎R/chaoss-hybrid.R

+4-1
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,10 @@
11
# Hybird metrics from both internal structure and external data
22

33
chaoss_metric_has_ci <- function (path) {
4-
has_ci <- has_gh_ci_tests (path)
4+
5+
is_test_env <- Sys.getenv ("REPOMETRICS_TESTS") == "true"
6+
has_ci <- ifelse (is_test_env, FALSE, has_gh_ci_tests (path))
7+
58
if (!has_ci) {
69
ci_files <- repo_has_ci_files (path)
710
has_ci <- length (ci_files) > 0L

‎R/gh-queries.R

+138-1
Original file line numberDiff line numberDiff line change
@@ -30,7 +30,7 @@ github_repo_workflow_query <- function (org = NULL, repo = NULL, n = 30L) {
3030
status <- vapply (workflows, function (i) i$status, character (1L))
3131
conclusion <- vapply (workflows, function (i) i$conclusion, character (1L))
3232
created <- vapply (workflows, function (i) i$created_at, character (1L))
33-
created <- as.POSIXct (created, format = "%Y-%m-%dT%H:%M:%S", tz = "UTC")
33+
created <- to_posix (created)
3434

3535
data.frame (
3636
name = names,
@@ -42,3 +42,140 @@ github_repo_workflow_query <- function (org = NULL, repo = NULL, n = 30L) {
4242
created = created
4343
)
4444
}
45+
46+
#' Use the GitHub Rest API activity list to extract event types.
47+
#' Activity requests are described at
48+
#' \url{https://docs.github.com/en/rest/repos/repos?apiVersion=2022-11-28#list-repository-activities}
49+
#' and the list of all event types is at
50+
#' \url{https://docs.github.com/en/rest/using-the-rest-api/github-event-types?apiVersion=2022-11-28}.
51+
#' @noRd
52+
github_issues_prs_query <- function (org = NULL, repo = NULL) {
53+
54+
u_base <- "https://api.github.com/repos/"
55+
u_repo <- paste0 (u_base, org, "/", repo, "/")
56+
57+
is_test_env <- Sys.getenv ("REPOMETRICS_TESTS") == "true"
58+
url0 <- paste0 (u_repo, "events?per_page=", ifelse (is_test_env, 2, 100))
59+
60+
body <- NULL
61+
next_page <- 1
62+
this_url <- url0
63+
while (!is.null (next_page)) {
64+
65+
req <- httr2::request (this_url) |>
66+
add_token_to_req ()
67+
68+
resp <- httr2::req_perform (req)
69+
httr2::resp_check_status (resp)
70+
71+
this_body <- httr2::resp_body_json (resp)
72+
body <- c (body, this_body)
73+
74+
next_page <- get_next_page (resp)
75+
if (is_test_env) {
76+
next_page <- NULL
77+
}
78+
this_url <- paste0 (url0, "&page=", next_page)
79+
}
80+
81+
# Extraction function for single fields which may not be present
82+
extract_one <- function (body, field = "action", naval = NA_character_) {
83+
ret_type <- do.call (typeof (naval), list (1L))
84+
vapply (body, function (i) {
85+
ifelse (field %in% names (i$payload), i$payload [[field]], naval)
86+
}, ret_type)
87+
}
88+
89+
# Extraction function for doubly-nexted fields which may not be present
90+
extract_two <- function (body,
91+
field1 = "pull_request",
92+
field2 = "comments",
93+
naval = NA_character_) {
94+
95+
ret_type <- do.call (typeof (naval), list (1L))
96+
vapply (body, function (i) {
97+
ret <- naval
98+
if (field1 %in% names (i$payload)) {
99+
if (field2 %in% names (i$payload [[field1]])) {
100+
ret <- i$payload [[field1]] [[field2]]
101+
}
102+
}
103+
ifelse (is.null (ret), naval, ret)
104+
}, ret_type)
105+
}
106+
107+
# Items which are always present:
108+
ids <- vapply (body, function (i) i$id, character (1L))
109+
type <- vapply (body, function (i) i$type, character (1L))
110+
login <- vapply (body, function (i) i$actor$login, character (1L))
111+
112+
# Single-nested items:
113+
action <- extract_one (body, "action", NA_character_)
114+
number <- extract_one (body, "number", NA_integer_)
115+
116+
# Doubly-nested items:
117+
num_comments <- extract_two (body, "pull_request", "comments", NA_integer_)
118+
num_review_comments <-
119+
extract_two (body, "pull_request", "review_comments", NA_integer_)
120+
commits <- extract_two (body, "pull_request", "commits", NA_integer_)
121+
additions <- extract_two (body, "pull_request", "additions", NA_integer_)
122+
deletions <- extract_two (body, "pull_request", "deletions", NA_integer_)
123+
changed_files <-
124+
extract_two (body, "pull_request", "changed_files", NA_integer_)
125+
created_at <-
126+
extract_two (body, "pull_request", "created_at", NA_character_)
127+
created_at <- to_posix (created_at)
128+
merged_at <-
129+
extract_two (body, "pull_request", "created_at", NA_character_)
130+
merged_at <- to_posix (merged_at)
131+
132+
data.frame (
133+
id = ids,
134+
type = type,
135+
login = login,
136+
action = action,
137+
number = number,
138+
commits = commits,
139+
num_comments = num_comments,
140+
num_review_comments = num_review_comments,
141+
additions = additions,
142+
deletions = deletions,
143+
changed_files = changed_files,
144+
created_at = created_at,
145+
merged_at = merged_at
146+
)
147+
}
148+
149+
add_token_to_req <- function (req) {
150+
151+
if (!nzchar (Sys.getenv ("GITHUB_WORKFLOW"))) {
152+
tok <- get_gh_token ()
153+
headers <- list (Authorization = paste0 ("Bearer ", tok))
154+
req <- httr2::req_headers (req, "Authorization" = headers)
155+
}
156+
157+
return (req)
158+
}
159+
160+
#' Pagination for Rest API. see
161+
#' https://docs.github.com/en/rest/using-the-rest-api/using-pagination-in-the-rest-api
162+
#' @noRd
163+
get_next_page <- function (resp) {
164+
165+
link <- httr2::resp_headers (resp)$link
166+
167+
next_page <- NULL
168+
169+
if (!is.null (link)) {
170+
next_ptn <- "rel\\=\\\"next"
171+
if (grepl (next_ptn, link)) {
172+
# "next" is always first; where there are multiples, "prev" comes
173+
# after "next"
174+
ptn <- "<([^>]+)>"
175+
next_page <- regmatches (link, regexpr (ptn, link))
176+
next_page <- gsub ("^.*&page\\=|>", "", next_page)
177+
}
178+
}
179+
180+
return (next_page)
181+
}

‎R/utils.R

+4
Original file line numberDiff line numberDiff line change
@@ -28,6 +28,10 @@ set_num_cores <- function (num_cores) {
2828
return (num_cores)
2929
}
3030

31+
to_posix <- function (x) {
32+
as.POSIXct (x, format = "%Y-%m-%dT%H:%M:%S", tz = "UTC")
33+
}
34+
3135
# nocov start
3236
get_gh_token <- function () {
3337
e <- Sys.getenv ()

‎codemeta.json

+1-1
Original file line numberDiff line numberDiff line change
@@ -8,7 +8,7 @@
88
"codeRepository": "https://github.com/ropensci-review-tools/repometrics",
99
"issueTracker": "https://github.com/ropensci-review-tools/repometrics/issues",
1010
"license": "https://spdx.org/licenses/GPL-3.0",
11-
"version": "0.1.1.009",
11+
"version": "0.1.1.016",
1212
"programmingLanguage": {
1313
"@type": "ComputerLanguage",
1414
"name": "R",

‎inst/httptest2/redact.R

+7
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,13 @@ function (resp) {
1414
fixed = TRUE
1515
)
1616

17+
resp <- httptest2::gsub_response (
18+
resp,
19+
"ropensci-review-tools/goodpractice",
20+
"repo/",
21+
fixed = TRUE
22+
)
23+
1724
test_repo <- "ropensci-review-tools/repometrics"
1825
resp <- httptest2::gsub_response (
1926
resp,

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

+7
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,7 @@
1+
# chaoss metric has_ci
2+
3+
Code
4+
chk <- chaoss_metric_has_ci(path)
5+
Message
6+
i Unable to determine whether runs are recent for CI service [github].
7+

0 commit comments

Comments
 (0)