diff --git a/DESCRIPTION b/DESCRIPTION index a572c5ba..bbac0fb0 100644 --- a/DESCRIPTION +++ b/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 = "opensource+kamil@appsilon.com"), @@ -40,6 +40,7 @@ Imports: yaml Suggests: covr, + crayon, knitr, mockery, rcmdcheck, diff --git a/NEWS.md b/NEWS.md index 16797fa6..c73eadcb 100644 --- a/NEWS.md +++ b/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. diff --git a/R/test_helpers.R b/R/test_helpers.R new file mode 100644 index 00000000..6bd19300 --- /dev/null +++ b/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 +} diff --git a/R/tools.R b/R/tools.R index 53baf8b4..8828ce94 100644 --- a/R/tools.R +++ b/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) { diff --git a/man/test_r.Rd b/man/test_r.Rd index f9583f02..b99cfa11 100644 --- a/man/test_r.Rd +++ b/man/test_r.Rd @@ -4,17 +4,45 @@ \alias{test_r} \title{Run R unit tests} \usage{ -test_r() +test_r( + paths = fs::dir_ls("tests/testthat/", glob = "*.R", recurse = TRUE, type = "file"), + inline_issues = FALSE, + raw_testthat_output = FALSE +) +} +\arguments{ +\item{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 \code{tests/testthat}.} + +\item{inline_issues}{If \code{TRUE}, test failure, wanring, and skip messages are shown while the +tests are running. If \code{FALSE}, test failure, warning, and skip messages are shown after +all tests are run.} + +\item{raw_testthat_output}{boolean, See return value.} } \value{ -None. This function is called for side effects. +If \code{raw_testthat_output = FALSE}, a data.frame (invisibly) containing data +about the \code{testthat} test results. +If \code{raw_testthat_output = TRUE}, a list (invisibly) of lists containing data +returned by \code{testthat::test_file()}. } \description{ -Uses the \code{{testhat}} package to run all unit tests in \code{tests/testthat} directory. +Uses the \code{{testhat}} package to run all unit tests in the \code{tests/testthat} directory. +Alternatively, a vector of paths (files and directories) can be provided. } \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")) } } diff --git a/tests/testthat/test-test_r.R b/tests/testthat/test-test_r.R new file mode 100644 index 00000000..ec42d6d2 --- /dev/null +++ b/tests/testthat/test-test_r.R @@ -0,0 +1,116 @@ +test_that("test_r works with default parameters", { + paths <- fs::dir_ls("test_recursive", glob = "*.R", recurse = TRUE, type = "file") + + expect_output(test_r(paths)) +}) + +test_that("test_r returns an invisible data.frame with the correct number of rows", { + paths <- fs::dir_ls("test_recursive", glob = "*.R", recurse = TRUE, type = "file") + + expect_invisible(test_results <- test_r(paths)) + expect_s3_class(test_results, "data.frame") + expect_equal(nrow(test_results), 6) +}) + +test_that("test_r returns a list when raw_testthat_output = TRUE", { + paths <- fs::dir_ls("test_recursive", glob = "*.R", recurse = TRUE, type = "file") + + test_results <- test_r(paths, raw_testthat_output = TRUE) + + expect_type(test_results, "list") + expect_length(test_results, 3) +}) + +test_that("test_r shows the correct test summary", { + paths <- fs::dir_ls("test_recursive", glob = "*.R", recurse = TRUE, type = "file") + + expect_output(test_r(paths), "[ FAIL 1 | WARN 1 | SKIP 1 | PASS 4 ]", fixed = TRUE) +}) + +test_that("test_r accepts a single test file", { + path <- "test_recursive/test-main.R" + + expect_output(test_results <- test_r(path)) + expect_equal(nrow(test_results), 1) +}) + +test_that("test_r accepts more than one test file", { + paths <- c("test_recursive/test-main.R", "test_recursive/logic/test-logic_sample.R") + + expect_output(test_results <- test_r(paths)) + expect_equal(nrow(test_results), 3) +}) + +test_that("test_r accepts a directory as path for tests", { + path <- "test_recursive/logic/test-logic_sample.R" + + test_results <- test_r(path) + + expect_equal(nrow(test_results), 2) +}) + +test_that("test_r accepts more than one directory as paths for tests", { + paths <- c( + "test_recursive/logic/test-logic_sample.R", + "test_recursive/view/test-view_sample.R" + ) + + test_results <- test_r(paths) + + expect_equal(nrow(test_results), 5) +}) + +test_that("test_r accepts a mix of files and directories as paths", { + paths <- c( + "test_recursive/logic/test-logic_sample.R", + "test_recursive/view/" + ) + + test_results <- test_r(paths) + + expect_equal(nrow(test_results), 5) +}) + +test_that("test_r shows a failed test", { + path <- "test_recursive/logic/test-logic_sample.R" + + expect_output(test_r(path), "Failures") + expect_output(test_r(path), "a failed test example", ignore.case = TRUE) +}) + +test_that("test_r shows a failed test inline when inline_issues = TRUE", { + path <- "test_recursive/logic/test-logic_sample.R" + + # "Failures" section should not show + expect_output(test_r(path, inline_issues = TRUE), "(?!Failures).*$", perl = TRUE) + expect_output(test_r(path, inline_issues = TRUE), "a failed test example", ignore.case = TRUE) +}) + +test_that("test_r shows a skipped test", { + path <- "test_recursive/view/test-view_sample.R" + + expect_output(test_r(path), "Skipped tests") + expect_output(test_r(path), "skip example", ignore.case = TRUE) +}) + +test_that("test_r shows a skipped test inline when inline_issues = TRUE", { + path <- "test_recursive/view/test-view_sample.R" + + # "Failures" section should not show + expect_output(test_r(path, inline_issues = TRUE), "(?!Skipped tests).*$", perl = TRUE) + expect_output(test_r(path, inline_issues = TRUE), "skip example", ignore.case = TRUE) +}) + +test_that("test_r shows warnings", { + path <- "test_recursive/view/test-view_sample.R" + + expect_output(test_r(path), "Warnings") + expect_output(test_r(path), "warn warn warn") +}) + +test_that("test_r shows warnings inline when inline_issues = TRUE", { + path <- "test_recursive/view/test-view_sample.R" + + expect_output(test_r(path, inline_issues = TRUE), "(?!Warnings).*$", perl = TRUE) + expect_output(test_r(path, inline_issues = TRUE), "warn warn warn") +}) diff --git a/tests/testthat/test_recursive/logic/test-logic_sample.R b/tests/testthat/test_recursive/logic/test-logic_sample.R new file mode 100644 index 00000000..a021af21 --- /dev/null +++ b/tests/testthat/test_recursive/logic/test-logic_sample.R @@ -0,0 +1,7 @@ +test_that("multiplication works", { + expect_equal(2 * 2, 4) +}) + +test_that("a failed test example", { + expect_true(FALSE) +}) diff --git a/tests/testthat/test_recursive/test-main.R b/tests/testthat/test_recursive/test-main.R new file mode 100644 index 00000000..8849056e --- /dev/null +++ b/tests/testthat/test_recursive/test-main.R @@ -0,0 +1,3 @@ +test_that("multiplication works", { + expect_equal(2 * 2, 4) +}) diff --git a/tests/testthat/test_recursive/view/test-view_sample.R b/tests/testthat/test_recursive/view/test-view_sample.R new file mode 100644 index 00000000..87e7608e --- /dev/null +++ b/tests/testthat/test_recursive/view/test-view_sample.R @@ -0,0 +1,13 @@ +test_that("multiplication works", { + expect_equal(2 * 2, 4) +}) + +test_that("skip example", { + skip("Skip this") + expect_true(TRUE) +}) + +test_that("warning example", { + warning("warn warn warn") + expect_true(TRUE) +})