parse_test_report.R

# This script was created to parse the outputs from testthat and covr for
# DataSHIELD packages (e.g., dsBase). The input files are generate via a GHA
# workflow (see URL_TO_GHA_WORKFLOW).
#
# Roberto Villegas-Diaz <r.villegas-diaz@liverpool.ac.uk>
# July 2025

# SETUP ----
args <- commandArgs(trailingOnly = TRUE) # read CL arguments
# 1st argument: INPUT_DIR
if (length(args) >= 1) {
  INPUT_DIR <- args[1]
} else {
  INPUT_DIR <- getwd()
}
# 2nd argument: OUTPUT_DIR
if (length(args) >= 2) {
  OUTPUT_DIR <- args[2]
} else {
  OUTPUT_DIR <- INPUT_DIR
}
# 3rd argument: GH_REPO - GitHub repository URL
if (length(args) >= 3) {
  GH_REPO <- args[3]
} else {
  GH_REPO <- file.path(git2r::remote_url(), "blob/master")
}
# 4th argument: FN_NAME_PATTERN - Function name pattern
if (length(args) >= 4) {
  FN_NAME_PATTERN <- args[4]
} else {
  FN_NAME_PATTERN <- "[^-:.]+"
}
# 5th argument: FN_TEST_CLASS_PATTERN - Function test class pattern
if (length(args) >= 4) {
  FN_TEST_CLASS_PATTERN <- args[5]
} else {
  FN_TEST_CLASS_PATTERN <- "^[a-zA-Z]+-"
}

# HELPER FUNCTIONS ----
valid_url <- function(url, timeout = 5) {
  req <- httr2::request(url) |>
    httr2::req_method("HEAD") |>
    httr2::req_options(timeout = timeout)

  res <- tryCatch(
    httr2::req_perform(req),
    error = function(e) NULL
  )

  !is.null(res) && httr2::resp_status(res) < 400
}

xml2tibble_covr <- function(filepath) {
  covr_xml <- filepath |>
    xml2::read_xml()
  # get total coverage
  pkg_coverage <- covr_xml |>
    xml2::xml_find_all("packages") |>
    xml2::xml_find_all("package") |>
    xml2::xml_attrs() |>
    purrr::list_c() |>
    tibble::as_tibble_row()

  covr_xml |>
    xml2::xml_find_all("packages") |>
    xml2::xml_find_all("package") |>
    xml2::xml_find_all("classes") |>
    xml2::xml_find_all("class") |>
    purrr::map(
      function(x) {
        tmp <- tempfile()
        on.exit(unlink(tmp))
        x |>
          xml2::xml_attrs() |>
          tibble::as_tibble_row() |>
          readr::write_csv(tmp)
        readr::read_csv(tmp, show_col_types = FALSE)
      },
      .progress = FALSE
    ) |>
    purrr::list_c() |>
    dplyr::mutate(
      name = filename,
      file_coverage = round(as.numeric(`line-rate`) * 100, 2),
      total_coverage = round(as.numeric(pkg_coverage$`line-rate`) * 100, 2)
    ) |>
    dplyr::select(name, file_coverage, total_coverage)
}

xml2tibble_test <- function(filepath) {
  filepath |>
    xml2::read_xml() |>
    xml2::xml_find_all("testsuite") |>
    purrr::map(function(ts) {
      tmp <- tempfile()
      on.exit(unlink(tmp))
      ts |>
        xml2::xml_attrs() |>
        tibble::as_tibble_row() |>
        readr::write_csv(tmp)
      readr::read_csv(tmp, show_col_types = FALSE)
    }) |>
    purrr::list_c()
}

# LOAD RESULTS ----
message("Loading results...")
# Load coverage output
covr_files <- list.files(
  INPUT_DIR,
  pattern = "^coverage.*xml$",
  full.names = TRUE
)
if (length(covr_files) > 0) {
  covr_csv <- purrr::map(covr_files, xml2tibble_covr) |>
    purrr::list_c() |>
    dplyr::distinct()
} else if (file.exists(file.path(INPUT_DIR, "coverage.xml"))) {
  covr_csv <- file.path(INPUT_DIR, "coveragelist.csv") |>
    readr::read_csv(
      show_col_types = FALSE,
      skip = 1,
      col_names = c("name", "file_coverage", "total_coverage")
    ) |>
    dplyr::mutate(
      file_coverage = round(as.numeric(file_coverage), 2),
      total_coverage = round(as.numeric(total_coverage), 2)
    )
} else {
  covr_csv <- tibble::tibble(
    name = '<PLACEHOLDER>',
    file_coverage = NA_real_,
    total_coverage = NA_real_
  )
}

# Load test results
test_files <- list.files(
  INPUT_DIR,
  pattern = "^test_results.*xml$",
  full.names = TRUE
)
# Parse XML results into tibble
tests_tbl <- purrr::map(test_files, xml2tibble_test) |>
  purrr::list_c() |>
  dplyr::group_by(name) |>
  dplyr::reframe(
    tests = sum(tests, na.rm = TRUE),
    skipped = sum(skipped, na.rm = TRUE),
    failures = sum(failures, na.rm = TRUE),
    errors = sum(errors, na.rm = TRUE),
    time = sum(time, na.rm = TRUE)
  )

# AGGREGATE RESULTS ----
message("Aggregating results...")
tests_tbl_v2 <- tests_tbl |>
  # drop rows without actual tests
  dplyr::filter(tests > 0) |>
  # extract details from testsuite
  dplyr::mutate(
    # detect if current record has a test class
    has_test_class = stringr::str_detect(name, FN_TEST_CLASS_PATTERN),
    # detect naming style
    is_hyphen_style = stringr::str_detect(name, "^[^-:]+-[^-:]+"),
    # extract function name (handles both `class-fn` and `fn::class::...`)
    fn_name = name |>
      stringr::str_extract(FN_NAME_PATTERN) |>
      stringr::str_remove_all("[\\(\\)]"),
    # extract test class (e.g., arg, smk, etc.)
    test_class = name |>
      stringr::str_extract(FN_TEST_CLASS_PATTERN),
    test_class = dplyr::if_else(has_test_class, test_class, NA_character_),
    # fn_name_sub ONLY for hyphen-style: class-function-sub
    fn_name_sub = dplyr::if_else(
      is_hyphen_style,
      name |>
        # remove "class-function-" prefix (optional trailing dash)
        stringr::str_remove("^[^-:]+-[^-:]+-?") |>
        # keep only the first condition token if present
        stringr::str_extract("^[^:-]+") |>
        stringr::str_remove_all("[\\(\\)]") |>
        tidyr::replace_na(""),
      ""
    )
  ) |>
  dplyr::select(-is_hyphen_style) |>
  # fill in sub-tests with test class
  tidyr::fill(test_class, .direction = "down") |>
  dplyr::mutate(
    fn_name_sub2 = ifelse(fn_name_sub == "", "", paste0("-", fn_name_sub)),
    # create links to function script and test file
    github_script_link = file.path(
      GH_REPO,
      "R",
      paste0(fn_name, ".R")
    ),
    github_test_link = file.path(
      GH_REPO,
      "tests/testthat",
      paste0("test-", test_class, "-", fn_name, fn_name_sub2, ".R")
    )
  ) |>
  dplyr::select(-fn_name_sub2)

# aggregate results by function name and test class
tests_tbl_v3 <- tests_tbl_v2 |>
  dplyr::group_by(fn_name, fn_name_sub, test_class) |>
  dplyr::mutate(
    tests = sum(tests, na.rm = TRUE),
    skipped = sum(skipped, na.rm = TRUE),
    failures = sum(failures, na.rm = TRUE),
    errors = sum(errors, na.rm = TRUE),
    time = sum(time, na.rm = TRUE),
  ) |>
  dplyr::ungroup() |>
  dplyr::select(
    fn_name,
    fn_name_sub,
    test_class,
    tests:github_test_link,
    -has_test_class
  ) |>
  dplyr::distinct(fn_name, fn_name_sub, test_class, .keep_all = TRUE)

# check/validate URLs
message("Validating URLs...")
tests_tbl_v4 <- tests_tbl_v3 |>
  dplyr::mutate(
    valid_github_script_link = github_script_link |>
      purrr::map(valid_url, .progress = TRUE),
    valid_github_test_link = github_test_link |>
      purrr::map(valid_url, .progress = TRUE),
    github_script_link = ifelse(
      valid_github_script_link,
      github_script_link,
      NA
    ),
    github_test_link = ifelse(valid_github_test_link, github_test_link, NA)
  )

# ADD TEST COVERAGE ----
message("Adding test coverage...")
covr_csv_2 <- covr_csv |>
  dplyr::mutate(
    # extract function name
    fn_name = name |>
      basename() |>
      stringr::str_remove("\\.R") |>
      stringr::str_extract(FN_NAME_PATTERN),
    # review if `fn_name` is missing
    fn_name = ifelse(
      is.na(fn_name),
      name |>
        stringr::str_remove("\\.R") |>
        stringr::str_remove("R\\/*"),
      fn_name
    )
  )

# Combine results
covr_and_test_results <- tests_tbl_v4 |>
  dplyr::left_join(covr_csv_2, by = dplyr::join_by(fn_name))

# Tidy up results and combine into a wide table
covr_and_test_results_v2 <- covr_and_test_results |>
  dplyr::filter(!is.na(fn_name)) |>
  # subset columns
  dplyr::select(
    fn_name,
    fn_name_sub,
    github_script_link,
    file_coverage,
    test_class,
    github_test_link,
    tests:time
  ) |>
  dplyr::arrange(fn_name) |>
  tidyr::pivot_longer(
    cols = -c(
      fn_name,
      fn_name_sub,
      github_script_link,
      test_class,
      file_coverage
    ),
    values_transform = as.character
  ) |>
  dplyr::group_by(test_class) |>
  dplyr::group_split()

covr_and_test_results_v3 <- covr_and_test_results_v2 |>
  purrr::map(function(x) {
    x |>
      dplyr::distinct() |>
      tidyr::pivot_wider(
        id_cols = c(
          fn_name,
          fn_name_sub,
          github_script_link,
          test_class,
          file_coverage
        )
      ) |>
      dplyr::rename(
        script_url = github_script_link,
        test_url = github_test_link
      )
  })

covr_and_test_results_v3 |>
  readr::write_rds(file.path(
    OUTPUT_DIR,
    paste0(Sys.Date(), "_covr_and_test_results.Rds")
  ))

covr_and_test_results_v3 |>
  purrr::reduce(dplyr::bind_rows) |>
  readr::write_excel_csv(
    file.path(OUTPUT_DIR, paste0(Sys.Date(), "_covr_and_test_results.csv")),
    na = ""
  )

# capture session info
session_info_files <- list.files(
  INPUT_DIR,
  pattern = "^session_info.*txt$",
  full.names = TRUE
)

extract_session_info <- function(file) {
  txt <- readLines(file) |>
    paste(collapse = "\n")
  tibble::tibble(
    # file = basename(file),
    shard = stringr::str_match(basename(file), "shard-([^\n]+)\\.txt")[, 2] |>
      stringr::str_remove("\\-$"),
    r_version = stringr::str_match(txt, "R version ([^\n]+)")[, 2],
    platform = stringr::str_match(txt, "Platform: ([^\n]+)")[, 2],
    running_under = stringr::str_match(txt, "Running under: ([^\n]+)")[, 2],
    blas = stringr::str_match(txt, "BLAS:\\s+([^\n]+)")[, 2],
    lapack = stringr::str_match(txt, "LAPACK:\\s+([^\n]+)")[, 2],
    timezone = stringr::str_match(txt, "time zone: ([^\n]+)")[, 2],
    base_packages = stringr::str_match(
      txt,
      "attached base packages:\\n\\[1\\] ([^\n]+)"
    )[, 2] |>
      stringr::str_squish(),
    namespace_packages = stringr::str_match(
      txt,
      "loaded via a namespace \\(and not attached\\):\\n\\[1\\] ([^\n]+)"
    )[, 2] |>
      stringr::str_squish()
  )
}

session_info_files |>
  purrr::map(extract_session_info) |>
  purrr::list_c() |>
  readr::write_excel_csv(
    file.path(OUTPUT_DIR, paste0(Sys.Date(), "_session_info.csv")),
    na = ""
  )