R/dev-cicd.R

In tjpalanca/tjutils: Utilities for TJ Palanca

#' @title
#' Continuous Integration (CI) / Continuous Deployment (CD) Tools
#'
#' @description
#' Tools for developing the testing and deployment workflows for subsequent
#' packages.
#'
#' @name dev_cicd
NULL

#' @describeIn dev_cicd
#' Determines whether the workflow is running in GitHub Actions
#' @export
dev_cicd_in_github_actions <- function() {
    Sys.getenv("GITHUB_ACTIONS") != ""
}

#' @describeIn dev_cicd
#' Determines whether the workflow is running in `covr`
#' @export
dev_cicd_in_covr <- function() {
    Sys.getenv("R_COVR") != ""
}

#' @describeIn dev_cicd
#' Name of the test schema according to github actions
#' @param short_pkg_name a shortened package name in case schema generated is
#'        sometimes too long
#' @importFrom snakecase to_snake_case
#' @export
dev_cicd_schema <- function(short_pkg_name =
                                tolower(dev_pkg_name(envir = parent.frame()))) {
    if (dev_cicd_in_github_actions()) {
        # In Github Actions
        to_snake_case(paste0(
            short_pkg_name,
            Sys.getenv("GITHUB_RUN_ID"), "_",
            Sys.getenv("GHA_JOB_ID")
        ))
    } else {
        # In development environment
        to_snake_case(paste0(
            tolower(short_pkg_name), "_",
            to_snake_case(Sys.getenv("JUPYTERHUB_USER"))
        ))
    }
}

#' @describeIn dev_cicd
#' Run the unit tests described in this package
#' @param stop_on_failure see [`devtools::test`]
#' @export
dev_cicd_test_package <- function(..., stop_on_failure = TRUE) {
    test_results <- devtools::test(..., stop_on_failure = stop_on_failure)
    return(invisible(test_results))
}

#' @describeIn dev_cicd
#' Measure and report the test coverage of this package
#' @param min_test_coverage minimum test coverage in percentage points
#' @param assert whether to error on failing to meet minimum
#' @param parent_env parent environment for package namespacing
#' @export
dev_cicd_test_coverage <- function(...,
                                   min_test_coverage = 80,
                                   assert = dev_cicd_in_github_actions(),
                                   envir = parent.frame()) {
    # # Compute and print test coverage
    coverage <- devtools::test_coverage(...)
    print(coverage)
    # Write coverage report to file and zip up
    covr::report(
        x    = coverage,
        file = glue("/tmp/{dev_pkg_name(envir = envir)}/test_coverage.html")
    )
    # Generate the zip file
    zip(
        zipfile = glue("/tmp/{dev_pkg_name(envir = envir)}/test_coverage.zip"),
        files   = list.files(glue("/tmp/{dev_pkg_name(envir = envir)}"),
                             recursive = TRUE,
                             include.dirs = TRUE,
                             full.names = TRUE),
        flags   = "-q"
    )
    # Ensure that we have sufficient test coverage
    current_coverage <- covr::percent_coverage(coverage)
    assert <- if (assert) assert_that else validate_that
    assert_result <-
        assert(
            current_coverage > min_test_coverage,
            msg = glue::glue(
                "Percent coverage of {min_test_coverage}% not reached. ",
                "Currently {current_coverage}."
            )
        )
    if (!isTRUE(assert_result)) print(assert_result)
    # Return the coverage object
    return(invisible(coverage))
}

#' @describeIn dev_cicd
#' Use linting tools to statically check the code for errors and style
#' irregularities.
#' @param max_lint_results max number of linting results without raising error
#' @export
dev_cicd_test_linting <- function(...,
                                  max_lint_results = 0L,
                                  assert = dev_cicd_in_github_actions()) {
    # Compute linting results
    lint_results <- lintr::lint_package(
        ...,
        linters = lintr::with_defaults(
            line_length_linter = lintr::line_length_linter(100L),
            object_name_linter = NULL,
            object_length_linter = NULL,
            commas_linter = NULL,
            pipe_continuation_linter = NULL,
            open_curly_linter = NULL,
            closed_curly_linter = NULL,
            cyclocomp_linter = lintr::cyclocomp_linter(complexity_limit = 35L),
            object_usage_linter = NULL,
            trailing_blank_lines_linter = NULL
        )
    )
    # Print the linting results if any
    cat(paste0(rep("=", 80L), collapse = ""), "\n")
    purrr::walk(
        lint_results,
        function(lint) {
            cat(paste0(rep("-", 80L), collapse = ""), "\n")
            print(lint)
        }
    )
    cat(paste0(rep("=", 80L), collapse = ""), "\n")
    # Check if in CI/CD
    assert <- if (assert) assert_that else validate_that
    assert_result <-
        assert(
            length(lint_results) <= max_lint_results,
            msg = glue::glue("{max_lint_results} max results exceeded.")
        )
    if (!isTRUE(assert_result)) print(assert_result)
    return(invisible(lint_results))
}

#' @describeIn dev_cicd
#' Spell checks the documentation.
#' @param max_spelling_errors maximum typos tolerated
#' @param assert whether to error on max typos
#' @export
dev_cicd_test_spelling <- function(...,
                                   max_spelling_errors = 0L,
                                   assert = dev_cicd_in_github_actions()) {
    results <- spelling::spell_check_package(...)
    print(results)
    # Assertion
    assert <- if (assert) assert_that else validate_that
    assert_result <-
        assert(length(results$word) <= max_spelling_errors,
               msg = glue::glue("{max_spelling_errors} max typos exceeded."))
    if (!isTRUE(assert_result)) print(assert_result)
    return(invisible(results))
}

#' @describeIn dev_cicd
#' Runs shiny functional tests
dev_cicd_shinytest <- function(app_name) {
    shinytest::testApp(glue("tests/testthat/{app_name}"),
                       compareImages = FALSE)
}