Recursive test_r()

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: rhino
 Title: A Framework for Enterprise Shiny Applications
-Version: 1.3.0.9000
+Version: 1.3.0.9203
 Authors@R:
   c(
     person("Kamil", "Żyła", role = c("aut", "cre"), email = "[email protected]"),
@@ -40,6 +40,7 @@ Imports:
   yaml
 Suggests:
   covr,
+  crayon,
   knitr,
   mockery,
   rcmdcheck,

NEWS.md

@@ -1,5 +1,7 @@
 # rhino (development version)
 
+1. `test_r()` support for unit tests with a folder/directory structure.
+
 # [rhino 1.3.0](https://github.com/Appsilon/rhino/releases/tag/v1.3.0)
 
 1. Rhino now works with `shinytest2` out of the box.

R/test_helpers.R

@@ -0,0 +1,241 @@
+traverse_test_paths <- function(paths) {
+  list_of_files <- lapply(paths, function(path) {
+    if (fs::is_file(path)) {
+      return(path)
+    } else if (fs::is_dir(path)) {
+      return(
+        fs::dir_ls(path, glob = "*.R", recurse = FALSE, type = "file")
+      )
+    }
+  })
+
+  unlist(list_of_files, use.names = FALSE)
+}
+
+test_files <- function(files, inline_issues, min_time = 0.1) {
+  test_results <- lapply(files, function(file) {
+    invisible(utils::capture.output(
+      raw_result <- testthat::test_file(file, stop_on_failure = FALSE)
+    ))
+
+    if (length(raw_result) > 0) {
+      raw_result_df <- as.data.frame(raw_result)
+      raw_result_summary <- stats::aggregate(
+        cbind(failed, warning, skipped, passed, real) ~ context,
+        data = raw_result,
+        FUN = sum
+      )
+
+      if (raw_result_summary$failed > 0) {
+        status <- cli::col_red(cli::symbol$cross)
+      } else {
+        status <- cli::col_green(cli::symbol$tick)
+      }
+
+      message <- paste0(
+        status, " | ",
+        col_format(raw_result_summary$failed, "fail"), " ",
+        col_format(raw_result_summary$warning, "warn"), " ",
+        col_format(raw_result_summary$skipped, "skip"), " ",
+        sprintf("%3d", raw_result_summary$passed),
+        " | ", raw_result_summary$context
+      )
+
+      if (raw_result_summary$real > min_time) {
+        message <- paste0(
+          message,
+          cli::col_grey(sprintf(" [%.1fs]", raw_result_summary$real))
+        )
+      }
+
+      cli::cat_line(message)
+
+      if (inline_issues & raw_result_summary$skipped > 0) {
+        cli::cat_rule(line = 1)
+        show_test_issues("skip", raw_result_df)
+        cli::cat_rule(line = 1)
+      }
+      if (inline_issues & raw_result_summary$warning > 0) {
+        cli::cat_rule(line = 1)
+        show_test_issues("warning", raw_result_df)
+        cli::cat_rule(line = 1)
+      }
+      if (inline_issues & raw_result_summary$failed > 0) {
+        cli::cat_rule(line = 1)
+        show_test_issues("failure", raw_result_df)
+        cli::cat_rule(line = 1)
+      }
+
+    }
+
+    return(raw_result)
+  })
+
+  compact(test_results)
+}
+
+flatten_test_results <- function(test_results) {
+  results_df <- lapply(test_results, `as.data.frame`)
+  do.call("rbind", results_df)
+}
+
+get_final_test_results <- function(flat_test_results) {
+  colSums(flat_test_results[, c("failed", "warning", "skipped", "passed", "real")])
+}
+
+show_test_header <- function() {
+  cli::cat_line(
+    colourise(cli::symbol$tick, "success"), " | ",
+    colourise("F", "failure"), " ",
+    colourise("W", "warning"), " ",
+    colourise("S", "skip"), " ",
+    colourise(" OK", "success"),
+    " | ", "Context"
+  )
+}
+
+show_test_final_line <- function(final_results) {
+  cli::cat_line(
+    summary_line(
+      final_results[["failed"]],
+      final_results[["warning"]],
+      final_results[["skipped"]],
+      final_results[["passed"]]
+    )
+  )
+  cat_cr()
+}
+
+show_test_issues <- function(issue_type, test_results) {
+  df_column <- switch(
+    issue_type,
+    "failure" = "failed",
+    "skip" = "skipped",
+    "warning" = "warning"
+  )
+
+  issue_tests <- test_results[test_results[[df_column]] > 0, "result"]
+
+  lapply(issue_tests, function(issue_test) {
+    result_body <- issue_test[[1]]
+    srcref <- result_body[["srcref"]]
+    srcfile <- attr(srcref, "srcfile")
+    filename <- srcfile$filename      # nolint
+    line <- srcref[1]                 # nolint
+    col <- srcref[2]                  # nolint
+    test <- result_body[["test"]]     # nolint
+    message <- result_body[["message"]]
+
+    issue_header <- colourise(first_upper(issue_type), issue_type)    # nolint
+    location <- cli::format_inline("{.file {filename}:{line}:{col}}") # nolint
+    issue_message <- cli::format_inline(
+      cli::style_bold(
+        "{issue_header} ({location}): {test}"
+      )
+    )
+
+    if (issue_type == "skip") {
+      message <- gsub(":?\n(\n|.)+", "", message) # only show first line
+    }
+
+    cli::cat_line(issue_message)
+    cli::cat_line(message)
+    cat_cr()
+  })
+}
+
+show_test_summary <- function(flat_test_results, inline_issues, min_time = 0.1) {
+  final_results <- get_final_test_results(flat_test_results)
+
+  if (!inline_issues && final_results[["skipped"]] > 0) {
+    cli::cat_rule(cli::style_bold("Skipped tests"), line = 1)
+    show_test_issues("skip", flat_test_results)
+  }
+
+  if (!inline_issues && final_results[["warning"]] > 0) {
+    cli::cat_rule(cli::style_bold("Warnings"), line = 1)
+    show_test_issues("warning", flat_test_results)
+  }
+
+  if (!inline_issues && final_results[["failed"]] > 0) {
+    cli::cat_rule(cli::style_bold("Failures"), line = 1)
+    show_test_issues("failure", flat_test_results)
+  }
+
+  cli::cat_rule(cli::style_bold("Results"), line = 2)
+  if (final_results[["real"]] > min_time) {
+    cli::cat_line("Duration: ", sprintf("%.1f s", final_results[["real"]]), col = "cyan")
+  }
+  cat_cr()
+  show_test_final_line(final_results)
+}
+
+cat_cr <- function() {
+  if (cli::is_dynamic_tty()) {
+    cli::cat_line("\r")
+  } else {
+    cli::cat_line("\n")
+  }
+}
+
+col_format <- function(n, type) {
+  if (n == 0) {
+    " "
+  } else {
+    colourise(n, type)
+  }
+}
+
+colourise <- function(text, as = c("success", "skip", "warning", "failure", "error")) {
+  if (has_colour()) {
+    unclass(cli::make_ansi_style(testthat_style(as))(text))
+  } else {
+    text
+  }
+}
+
+has_colour <- function() {
+  isTRUE(getOption("testthat.use_colours", TRUE)) &&
+    cli::num_ansi_colors() > 1
+}
+
+summary_line <- function(n_fail, n_warn, n_skip, n_pass) {
+  colourise_if <- function(text, colour, cond) {
+    if (cond) colourise(text, colour) else text
+  }
+
+  # Ordered from most important to least important
+  paste0(
+    "[ ",
+    colourise_if("FAIL", "failure", n_fail > 0), " ", n_fail, " | ",
+    colourise_if("WARN", "warn", n_warn > 0),    " ", n_warn, " | ",
+    colourise_if("SKIP", "skip", n_skip > 0),    " ", n_skip, " | ",
+    colourise_if("PASS", "success", n_fail == 0), " ", n_pass,
+    " ]"
+  )
+}
+
+testthat_style <- function(type = c("success", "skip", "warning", "failure", "error")) {
+  type <- match.arg(type)
+
+  c(
+    success = "green",
+    skip = "blue",
+    warning = "magenta",
+    failure = "orange",
+    error = "orange"
+  )[[type]]
+}
+
+compact <- function(x) {
+  x[viapply(x, length) != 0]
+}
+
+viapply <- function(x, FUN, ...) {
+  vapply(x, FUN, ..., FUN.VALUE = integer(1))
+}
+
+first_upper <- function(x) {
+  substr(x, 1, 1) <- toupper(substr(x, 1, 1))
+  x
+}

R/tools.R

@@ -1,17 +1,56 @@
 #' Run R unit tests
 #'
-#' Uses the `{testhat}` package to run all unit tests in `tests/testthat` directory.
-#'
-#' @return None. This function is called for side effects.
+#' Uses the `{testhat}` package to run all unit tests in the `tests/testthat` directory.
+#' Alternatively, a vector of paths (files and directories) can be provided.
+#'
+#' @param paths A character vector of paths to R files or directories containing tests.
+#'   Given a directory, R files in the directory will be included as test files.
+#'   Defaults to all files in all directories recursively in `tests/testthat`.
+#' @param inline_issues If `TRUE`, test failure, warning, and skip messages are shown while the
+#'    tests are running. If `FALSE`, test failure, warning, and skip messages are shown after
+#'    all tests are run.
+#' @param raw_testthat_output boolean, See return value.
+#' @return If `raw_testthat_output = FALSE`, a data.frame (invisibly) containing data
+#' about the `testthat` test results.
+#'    If `raw_testthat_output = TRUE`, a list (invisibly) of lists containing data
+#'    returned by `testthat::test_file()`.
 #'
 #' @examples
 #' if (interactive()) {
-#'   # Run all unit tests in the `tests/testthat` directory.
+#'   # Run all unit tests in the `tests/testthat` directory, recursively.
 #'   test_r()
+#'
+#'   # Run all unit tests in the `tests/testthat` directory only. Non-recursive.
+#'   test_r("tests/testthat")
+#'
+#'   # Run one unit test.
+#'   test_r("tests/testthat/main.R")
+#'
+#'   # Run unit tests on a collection of files and directories.
+#'   test_r(c("tests/testthat/test-main.R", "tests/testthat/logic"))
 #' }
 #' @export
-test_r <- function() {
-  testthat::test_dir(fs::path("tests", "testthat"))
+test_r <- function(
+    paths = fs::dir_ls("tests/testthat/", glob = "*.R", recurse = TRUE, type = "file"),
+    inline_issues = FALSE,
+    raw_testthat_output = FALSE
+) {
+  purge_box_cache()
+  files <- traverse_test_paths(paths)
+
+  show_test_header()
+  test_results <- test_files(files, inline_issues)
+  cat_cr()
+  flat_test_results <- flatten_test_results(test_results)
+  show_test_summary(flat_test_results, inline_issues)
+
+  if (raw_testthat_output) {
+    output <- test_results
+  } else {
+    output <- flat_test_results
+  }
+
+  invisible(output)
 }
 
 lint_dir <- function(path) {