From 0731e09ebfa121833a5ff4b8bf50b266159dc002 Mon Sep 17 00:00:00 2001 From: Rodrigo Basa Date: Fri, 27 Jan 2023 13:58:35 +0800 Subject: [PATCH 01/16] adding test handler for single file, single dir, or recursive dir. --- DESCRIPTION | 2 +- R/recursive_unit_tests.R | 185 +++++++++++++++++++++++++++++++++++++++ R/tools.R | 18 +++- man/test_r.Rd | 19 +++- 4 files changed, 218 insertions(+), 6 deletions(-) create mode 100644 R/recursive_unit_tests.R diff --git a/DESCRIPTION b/DESCRIPTION index c442dc30..b0701120 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: rhino Title: A Framework for Enterprise Shiny Applications -Version: 1.3.0 +Version: 1.3.0.8001 Authors@R: c( person("Kamil", "Żyła", role = c("aut", "cre"), email = "opensource+kamil@appsilon.com"), diff --git a/R/recursive_unit_tests.R b/R/recursive_unit_tests.R new file mode 100644 index 00000000..c9e959cf --- /dev/null +++ b/R/recursive_unit_tests.R @@ -0,0 +1,185 @@ +RecursiveUnitTests <- R6::R6Class("RecursiveUnitTests", # nolint + public = list( + initialize = function(path, filter = "test-.+\\.R$", recursive = TRUE) { + private$path <- path + private$filter <- filter + private$recursive <- recursive + + private$get_valid_test_paths() + }, + run_tests = function(...) { + if (private$is_single_test_file()) { + testthat::test_file(path = private$valid_paths, ...) + } else if (private$is_single_test_dir()) { + testthat::test_dir(path = private$valid_paths, ...) + } else if (private$is_multiple_test_dirs()) { + private$test_recursive(...) + } else { + cli::cli_abort("Test run failed!") + } + } + ), + private = list( + filter = NULL, + path = NULL, + valid_paths = NULL, + recursive = TRUE, + get_valid_test_paths = function() { + if (fs::is_file(private$path)) { + private$valid_paths <- fs::path_filter(private$path, regexp = private$filter) + } + + if (fs::is_dir(private$path)) { + valid_paths <- unique( + fs::path_dir( + fs::dir_ls(path = private$path, + regexp = private$filter, + recurse = private$recursive, type = "file") + ) + ) + + private$valid_paths <- valid_paths[order(valid_paths)] + } + + if (length(private$valid_paths) == 0) { + abort_message <- paste( + "No valid test file/s found in", + private$path + ) + + cli::cli_abort(abort_message) + } + }, + is_single_test_file = function() { + length(private$valid_paths) == 1 && fs::is_file(private$valid_paths) + }, + is_single_test_dir = function() { + length(private$valid_paths) == 1 + }, + is_multiple_test_dirs = function() { + length(private$valid_paths) > 1 + }, + run_recursive_test_dir = function(...) { + t( + sapply(private$valid_paths, function(this_path) { + private$cat_cr() + cli::cat_line("Test Directory: ", this_path) + + single_test_result <- as.data.frame( + testthat::test_dir(path = this_path, stop_on_failure = FALSE, ...)) + + colSums(single_test_result[, c("failed", "warning", "skipped", "passed")]) + }) + ) + }, + show_final_line = function(test_results) { + final_line_results <- colSums(test_results) + + cli::cat_line( + private$summary_line(final_line_results[["failed"]], + final_line_results[["warning"]], + final_line_results[["skipped"]], + final_line_results[["passed"]]) + ) + + private$cat_cr() + }, + show_summary = function(test_results) { + private$cat_cr() + cli::cat_rule(cli::style_bold("Rhino App Summary"), line = 2) + private$cat_cr() + + cli::cat_line( + private$colourise(cli::symbol$tick, "success"), " | ", + private$colourise("F", "failure"), " ", + private$colourise("W", "warning"), " ", + private$colourise("S", "skip"), " ", + private$colourise(" OK", "success"), + " | ", "Test Directory" + ) + + summary_results <- as.data.frame(test_results) + + sapply(row.names(summary_results), function(summary_row_name) { + path_test_result <- summary_results[summary_row_name, ] + + if (path_test_result$failed > 0) { + status <- cli::col_red(cli::symbol$cross) + } else { + status <- cli::col_green(cli::symbol$tick) + } + + message <- paste0( + status, " | ", + private$col_format(path_test_result$failed, "fail"), " ", + private$col_format(path_test_result$warning, "warn"), " ", + private$col_format(path_test_result$skipped, "skip"), " ", + sprintf("%3d", path_test_result$passed), + " | ", summary_row_name + ) + + cli::cat_line(message) + }) + + private$cat_cr() + }, + test_recursive = function(...) { + test_results <- private$run_recursive_test_dir(...) + + private$show_summary(test_results) + + private$show_final_line(test_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 { + private$colourise(n, type) + } + }, + colourise = function(text, as = c("success", "skip", "warning", "failure", "error")) { + if (private$has_colour()) { + unclass(cli::make_ansi_style(private$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) private$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]] + } + ) +) diff --git a/R/tools.R b/R/tools.R index 53baf8b4..90120410 100644 --- a/R/tools.R +++ b/R/tools.R @@ -1,17 +1,29 @@ #' Run R unit tests #' #' Uses the `{testhat}` package to run all unit tests in `tests/testthat` directory. +#' Alternatively, a single unit test file can be provided. #' +#' @param path Path to file or directory containing tests. Defaults to `tests/testthat`. +#' @param recursive boolean, to run tests on all nested folders inside path. Defaults to TRUE +#' @param ... Additional arguments to pass to `testthat::test_file()` or `testthat::test_dir()`. #' @return None. This function is called for side effects. #' #' @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. +#' test_r(recursive = FALSE) +#' +#' # Run one unit test. +#' test_r("tests/testthat/main.R") +#' #' } #' @export -test_r <- function() { - testthat::test_dir(fs::path("tests", "testthat")) +test_r <- function(path = fs::path("tests", "testthat"), recursive = TRUE, ...) { + test <- RecursiveUnitTests$new(path = path, recursive = recursive) + test$run_tests(...) } lint_dir <- function(path) { diff --git a/man/test_r.Rd b/man/test_r.Rd index f9583f02..30cf99b3 100644 --- a/man/test_r.Rd +++ b/man/test_r.Rd @@ -4,17 +4,32 @@ \alias{test_r} \title{Run R unit tests} \usage{ -test_r() +test_r(path = fs::path("tests", "testthat"), recursive = TRUE, ...) +} +\arguments{ +\item{path}{Path to file or directory containing tests. Defaults to \code{tests/testthat}.} + +\item{recursive}{boolean, to run tests on all nested folders inside path. Defaults to TRUE} + +\item{...}{Additional arguments to pass to \code{testthat::test_file()} or \code{testthat::test_dir()}.} } \value{ None. This function is called for side effects. } \description{ Uses the \code{{testhat}} package to run all unit tests in \code{tests/testthat} directory. +Alternatively, a single unit test file 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. + test_r(recursive = FALSE) + + # Run one unit test. + test_r("tests/testthat/main.R") + } } From 91032d2a69c7d9aee6f93915df522d6846841887 Mon Sep 17 00:00:00 2001 From: Rodrigo Basa Date: Fri, 27 Jan 2023 14:05:23 +0800 Subject: [PATCH 02/16] prevent multiple paths --- R/recursive_unit_tests.R | 3 +++ 1 file changed, 3 insertions(+) diff --git a/R/recursive_unit_tests.R b/R/recursive_unit_tests.R index c9e959cf..12c8441b 100644 --- a/R/recursive_unit_tests.R +++ b/R/recursive_unit_tests.R @@ -1,6 +1,9 @@ RecursiveUnitTests <- R6::R6Class("RecursiveUnitTests", # nolint public = list( initialize = function(path, filter = "test-.+\\.R$", recursive = TRUE) { + if (length(path) > 1) { + cli::cli_abort("Please provide a single path.") + } private$path <- path private$filter <- filter private$recursive <- recursive From 514e457fb21d5eaba4eb2d5addfc4d41c3badc2d Mon Sep 17 00:00:00 2001 From: Rodrigo Basa Date: Fri, 27 Jan 2023 14:17:25 +0800 Subject: [PATCH 03/16] a dummy function to pass r cmd check --- R/recursive_unit_tests.R | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/R/recursive_unit_tests.R b/R/recursive_unit_tests.R index 12c8441b..492ce2b4 100644 --- a/R/recursive_unit_tests.R +++ b/R/recursive_unit_tests.R @@ -186,3 +186,7 @@ RecursiveUnitTests <- R6::R6Class("RecursiveUnitTests", # nolint } ) ) + +r_cmd_check_fix <- function() { + testthat::test_check() +} From 4d693d242f934726ee1e6a4fd756eea588170287 Mon Sep 17 00:00:00 2001 From: Rodrigo Basa Date: Tue, 31 Jan 2023 13:38:37 +0800 Subject: [PATCH 04/16] return error context as rhino::test_r() --- R/recursive_unit_tests.R | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/R/recursive_unit_tests.R b/R/recursive_unit_tests.R index 492ce2b4..1abcfef0 100644 --- a/R/recursive_unit_tests.R +++ b/R/recursive_unit_tests.R @@ -45,12 +45,8 @@ RecursiveUnitTests <- R6::R6Class("RecursiveUnitTests", # nolint } if (length(private$valid_paths) == 0) { - abort_message <- paste( - "No valid test file/s found in", - private$path - ) - - cli::cli_abort(abort_message) + cli::cli_abort("No valid test file/s found in {.var {private$path}}.", + call = rlang::caller_env(n = 3)) } }, is_single_test_file = function() { From 9eb3a0979f009497b353a06588ddfdfd0c08cc1c Mon Sep 17 00:00:00 2001 From: Rodrigo Basa Date: Tue, 31 Jan 2023 14:23:41 +0800 Subject: [PATCH 05/16] some code cleanup --- DESCRIPTION | 3 ++- R/recursive_unit_tests.R | 58 +++++++++------------------------------- 2 files changed, 15 insertions(+), 46 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index b0701120..847495aa 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: rhino Title: A Framework for Enterprise Shiny Applications -Version: 1.3.0.8001 +Version: 1.3.0.8002 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/R/recursive_unit_tests.R b/R/recursive_unit_tests.R index 1abcfef0..0fe93e1d 100644 --- a/R/recursive_unit_tests.R +++ b/R/recursive_unit_tests.R @@ -75,7 +75,7 @@ RecursiveUnitTests <- R6::R6Class("RecursiveUnitTests", # nolint final_line_results <- colSums(test_results) cli::cat_line( - private$summary_line(final_line_results[["failed"]], + summary_line(final_line_results[["failed"]], final_line_results[["warning"]], final_line_results[["skipped"]], final_line_results[["passed"]]) @@ -89,11 +89,11 @@ RecursiveUnitTests <- R6::R6Class("RecursiveUnitTests", # nolint private$cat_cr() cli::cat_line( - private$colourise(cli::symbol$tick, "success"), " | ", - private$colourise("F", "failure"), " ", - private$colourise("W", "warning"), " ", - private$colourise("S", "skip"), " ", - private$colourise(" OK", "success"), + colourise(cli::symbol$tick, "success"), " | ", + colourise("F", "failure"), " ", + colourise("W", "warning"), " ", + colourise("S", "skip"), " ", + colourise(" OK", "success"), " | ", "Test Directory" ) @@ -140,49 +140,17 @@ RecursiveUnitTests <- R6::R6Class("RecursiveUnitTests", # nolint if (n == 0) { " " } else { - private$colourise(n, type) + colourise(n, type) } - }, - colourise = function(text, as = c("success", "skip", "warning", "failure", "error")) { - if (private$has_colour()) { - unclass(cli::make_ansi_style(private$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) private$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]] } ) ) +colourise <- getFromNamespace("colourise", "testthat") +has_colour <- getFromNamespace("has_colour", "testthat") +summary_line <- getFromNamespace("summary_line", "testthat") +testthat_style <- getFromNamespace("testthat_style", "testthat") + r_cmd_check_fix <- function() { testthat::test_check() -} +} \ No newline at end of file From 10f600f19485b94c95b0ca2874cff7dba0ddbd35 Mon Sep 17 00:00:00 2001 From: Rodrigo Basa Date: Thu, 2 Feb 2023 15:47:18 +0800 Subject: [PATCH 06/16] run tests by file. duplicate testthat progress reporter look and feel --- R/recursive_unit_tests.R | 268 +++++++++++++++++++++++---------------- R/tools.R | 10 +- 2 files changed, 167 insertions(+), 111 deletions(-) diff --git a/R/recursive_unit_tests.R b/R/recursive_unit_tests.R index 0fe93e1d..d1bb24e4 100644 --- a/R/recursive_unit_tests.R +++ b/R/recursive_unit_tests.R @@ -1,133 +1,147 @@ RecursiveUnitTests <- R6::R6Class("RecursiveUnitTests", # nolint public = list( - initialize = function(path, filter = "test-.+\\.R$", recursive = TRUE) { - if (length(path) > 1) { - cli::cli_abort("Please provide a single path.") - } - private$path <- path - private$filter <- filter - private$recursive <- recursive - - private$get_valid_test_paths() - }, - run_tests = function(...) { - if (private$is_single_test_file()) { - testthat::test_file(path = private$valid_paths, ...) - } else if (private$is_single_test_dir()) { - testthat::test_dir(path = private$valid_paths, ...) - } else if (private$is_multiple_test_dirs()) { - private$test_recursive(...) + run_tests = function( + paths = fs::dir_ls("tests/testthat/", regexp = "\\.R$", recurse = TRUE, type = "file"), + inline_failures = FALSE, + raw_output = FALSE + ) { + files <- private$traverse_paths(paths) + + private$show_header() + test_results <- private$test_files(files, inline_failures) + flat_test_results <- private$flatten_test_results(test_results) + private$show_summary(flat_test_results, inline_failures) + + if (raw_output) { + output <- test_results } else { - cli::cli_abort("Test run failed!") + output <- flat_test_results } + + invisible(output) } ), private = list( - filter = NULL, - path = NULL, - valid_paths = NULL, - recursive = TRUE, - get_valid_test_paths = function() { - if (fs::is_file(private$path)) { - private$valid_paths <- fs::path_filter(private$path, regexp = private$filter) - } + traverse_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, regexp = "\\.R$", recurse = FALSE, type = "file") + ) + } + }) + + unlist(list_of_files, use.names = FALSE) + }, + test_files = function(files, inline_failures) { + test_results <- lapply(files, function(file) { + invisible(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 <- aggregate( + cbind(failed, warning, skipped, passed) ~ context, + data = raw_result, + FUN = sum + ) - if (fs::is_dir(private$path)) { - valid_paths <- unique( - fs::path_dir( - fs::dir_ls(path = private$path, - regexp = private$filter, - recurse = private$recursive, type = "file") + if (raw_result_summary$failed > 0) { + status <- cli::col_red(cli::symbol$cross) + } else { + status <- cli::col_green(cli::symbol$tick) + } + + message <- paste0( + status, " | ", + private$col_format(raw_result_summary$failed, "fail"), " ", + private$col_format(raw_result_summary$warning, "warn"), " ", + private$col_format(raw_result_summary$skipped, "skip"), " ", + sprintf("%3d", raw_result_summary$passed), + " | ", raw_result_summary$context ) - ) - private$valid_paths <- valid_paths[order(valid_paths)] - } + cli::cat_line(message) - if (length(private$valid_paths) == 0) { - cli::cli_abort("No valid test file/s found in {.var {private$path}}.", - call = rlang::caller_env(n = 3)) - } - }, - is_single_test_file = function() { - length(private$valid_paths) == 1 && fs::is_file(private$valid_paths) + if (inline_failures & raw_result_summary$failed > 0) { + private$show_failures(raw_result_df) + } + } + + return(raw_result) + }) }, - is_single_test_dir = function() { - length(private$valid_paths) == 1 + flatten_test_results = function(test_results) { + results_df <- lapply(test_results, `as.data.frame`) + results_df <- private$compact(results_df) + do.call("rbind", results_df) }, - is_multiple_test_dirs = function() { - length(private$valid_paths) > 1 + get_final_results = function(flat_test_results) { + colSums(flat_test_results[, c("failed", "warning", "skipped", "passed")]) }, - run_recursive_test_dir = function(...) { - t( - sapply(private$valid_paths, function(this_path) { - private$cat_cr() - cli::cat_line("Test Directory: ", this_path) - - single_test_result <- as.data.frame( - testthat::test_dir(path = this_path, stop_on_failure = FALSE, ...)) - - colSums(single_test_result[, c("failed", "warning", "skipped", "passed")]) - }) + show_header = function() { + cli::cat_line( + private$colourise(cli::symbol$tick, "success"), " | ", + private$colourise("F", "failure"), " ", + private$colourise("W", "warning"), " ", + private$colourise("S", "skip"), " ", + private$colourise(" OK", "success"), + " | ", "Context" ) }, - show_final_line = function(test_results) { - final_line_results <- colSums(test_results) - + show_final_line = function(final_results) { cli::cat_line( - summary_line(final_line_results[["failed"]], - final_line_results[["warning"]], - final_line_results[["skipped"]], - final_line_results[["passed"]]) + private$summary_line(final_results[["failed"]], + final_results[["warning"]], + final_results[["skipped"]], + final_results[["passed"]]) ) private$cat_cr() }, - show_summary = function(test_results) { - private$cat_cr() - cli::cat_rule(cli::style_bold("Rhino App Summary"), line = 2) - private$cat_cr() - - cli::cat_line( - colourise(cli::symbol$tick, "success"), " | ", - colourise("F", "failure"), " ", - colourise("W", "warning"), " ", - colourise("S", "skip"), " ", - colourise(" OK", "success"), - " | ", "Test Directory" - ) - - summary_results <- as.data.frame(test_results) - - sapply(row.names(summary_results), function(summary_row_name) { - path_test_result <- summary_results[summary_row_name, ] - - if (path_test_result$failed > 0) { - status <- cli::col_red(cli::symbol$cross) - } else { - status <- cli::col_green(cli::symbol$tick) - } - - message <- paste0( - status, " | ", - private$col_format(path_test_result$failed, "fail"), " ", - private$col_format(path_test_result$warning, "warn"), " ", - private$col_format(path_test_result$skipped, "skip"), " ", - sprintf("%3d", path_test_result$passed), - " | ", summary_row_name + show_failures = function(test_results) { + failed_tests <- test_results[test_results$failed > 0, "result"] + + lapply(failed_tests, function(failed_test) { + result_body <- failed_test[[1]] + srcref <- result_body[["srcref"]] + srcfile <- attr(srcref, "srcfile") + filename <- srcfile$filename + line <- srcref[1] + col <- srcref[2] + test <- result_body[["test"]] + message <- result_body[["message"]] + + failure_type <- private$colourise("Failure", "failure") + location <- cli::format_inline("{.file {filename}:{line}}:{{col}}") + issue_message <- cli::format_inline( + cli::style_bold( + "{failure_type} ({location}): {test}" + ) ) + private$cat_cr() + cli::cat_line(issue_message) cli::cat_line(message) }) - - private$cat_cr() }, - test_recursive = function(...) { - test_results <- private$run_recursive_test_dir(...) + show_summary = function(flat_test_results, inline_failures) { + final_results <- private$get_final_results(flat_test_results) + + if (!inline_failures & final_results[["failed"]] > 0) { + private$cat_cr() + cli::cat_rule(cli::style_bold("Failures"), line = 1) + private$show_failures(flat_test_results) + } - private$show_summary(test_results) + private$cat_cr() + cli::cat_rule(cli::style_bold("Results"), line = 2) + private$cat_cr() - private$show_final_line(test_results) + private$show_final_line(final_results) }, cat_cr = function() { if (cli::is_dynamic_tty()) { @@ -140,17 +154,55 @@ RecursiveUnitTests <- R6::R6Class("RecursiveUnitTests", # nolint if (n == 0) { " " } else { - colourise(n, type) + private$colourise(n, type) } + }, + colourise = function(text, as = c("success", "skip", "warning", "failure", "error")) { + if (private$has_colour()) { + unclass(cli::make_ansi_style(private$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) private$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[private$viapply(x, length) != 0] + }, + viapply = function(X, FUN, ...) { + vapply(X, FUN, ..., FUN.VALUE = integer(1)) } ) ) -colourise <- getFromNamespace("colourise", "testthat") -has_colour <- getFromNamespace("has_colour", "testthat") -summary_line <- getFromNamespace("summary_line", "testthat") -testthat_style <- getFromNamespace("testthat_style", "testthat") - r_cmd_check_fix <- function() { testthat::test_check() } \ No newline at end of file diff --git a/R/tools.R b/R/tools.R index 90120410..962f7c2f 100644 --- a/R/tools.R +++ b/R/tools.R @@ -21,9 +21,13 @@ #' #' } #' @export -test_r <- function(path = fs::path("tests", "testthat"), recursive = TRUE, ...) { - test <- RecursiveUnitTests$new(path = path, recursive = recursive) - test$run_tests(...) +test_r <- function( + paths = fs::dir_ls("tests/testthat/", regexp = "\\.R$", recurse = TRUE, type = "file"), + inline_failures = FALSE, + raw_output = FALSE +) { + test <- RecursiveUnitTests$new() + test$run_tests(paths, inline_failures, raw_output) } lint_dir <- function(path) { From 1c4c9117fcc811418bf338f5e1aab3a497362588 Mon Sep 17 00:00:00 2001 From: Rodrigo Basa Date: Thu, 2 Feb 2023 19:43:45 +0800 Subject: [PATCH 07/16] added skip test handling. modified docs. --- R/recursive_unit_tests.R | 404 +++++++++--------- R/tools.R | 46 +- man/test_r.Rd | 28 +- tests/testthat/test-test_r.R | 102 +++++ .../test_recursive/logic/test-logic_sample.R | 7 + tests/testthat/test_recursive/test-main.R | 3 + .../test_recursive/view/test-view_sample.R | 8 + 7 files changed, 382 insertions(+), 216 deletions(-) create mode 100644 tests/testthat/test-test_r.R create mode 100644 tests/testthat/test_recursive/logic/test-logic_sample.R create mode 100644 tests/testthat/test_recursive/test-main.R create mode 100644 tests/testthat/test_recursive/view/test-view_sample.R diff --git a/R/recursive_unit_tests.R b/R/recursive_unit_tests.R index d1bb24e4..1ba37cf8 100644 --- a/R/recursive_unit_tests.R +++ b/R/recursive_unit_tests.R @@ -1,208 +1,226 @@ -RecursiveUnitTests <- R6::R6Class("RecursiveUnitTests", # nolint - public = list( - run_tests = function( - paths = fs::dir_ls("tests/testthat/", regexp = "\\.R$", recurse = TRUE, type = "file"), - inline_failures = FALSE, - raw_output = FALSE - ) { - files <- private$traverse_paths(paths) - - private$show_header() - test_results <- private$test_files(files, inline_failures) - flat_test_results <- private$flatten_test_results(test_results) - private$show_summary(flat_test_results, inline_failures) - - if (raw_output) { - output <- test_results +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 { - output <- flat_test_results + status <- cli::col_green(cli::symbol$tick) } - invisible(output) - } - ), - private = list( - traverse_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, regexp = "\\.R$", recurse = FALSE, type = "file") - ) - } - }) - - unlist(list_of_files, use.names = FALSE) - }, - test_files = function(files, inline_failures) { - test_results <- lapply(files, function(file) { - invisible(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 <- aggregate( - cbind(failed, warning, skipped, passed) ~ 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, " | ", - private$col_format(raw_result_summary$failed, "fail"), " ", - private$col_format(raw_result_summary$warning, "warn"), " ", - private$col_format(raw_result_summary$skipped, "skip"), " ", - sprintf("%3d", raw_result_summary$passed), - " | ", raw_result_summary$context - ) - - cli::cat_line(message) - - if (inline_failures & raw_result_summary$failed > 0) { - private$show_failures(raw_result_df) - } - } - - return(raw_result) - }) - }, - flatten_test_results = function(test_results) { - results_df <- lapply(test_results, `as.data.frame`) - results_df <- private$compact(results_df) - do.call("rbind", results_df) - }, - get_final_results = function(flat_test_results) { - colSums(flat_test_results[, c("failed", "warning", "skipped", "passed")]) - }, - show_header = function() { - cli::cat_line( - private$colourise(cli::symbol$tick, "success"), " | ", - private$colourise("F", "failure"), " ", - private$colourise("W", "warning"), " ", - private$colourise("S", "skip"), " ", - private$colourise(" OK", "success"), - " | ", "Context" - ) - }, - show_final_line = function(final_results) { - cli::cat_line( - private$summary_line(final_results[["failed"]], - final_results[["warning"]], - final_results[["skipped"]], - final_results[["passed"]]) + 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 ) - private$cat_cr() - }, - show_failures = function(test_results) { - failed_tests <- test_results[test_results$failed > 0, "result"] - - lapply(failed_tests, function(failed_test) { - result_body <- failed_test[[1]] - srcref <- result_body[["srcref"]] - srcfile <- attr(srcref, "srcfile") - filename <- srcfile$filename - line <- srcref[1] - col <- srcref[2] - test <- result_body[["test"]] - message <- result_body[["message"]] - - failure_type <- private$colourise("Failure", "failure") - location <- cli::format_inline("{.file {filename}:{line}}:{{col}}") - issue_message <- cli::format_inline( - cli::style_bold( - "{failure_type} ({location}): {test}" - ) + if (raw_result_summary$real > min_time) { + message <- paste0( + message, + cli::col_grey(sprintf(" [%.1fs]", raw_result_summary$real)) ) - - private$cat_cr() - cli::cat_line(issue_message) - cli::cat_line(message) - }) - }, - show_summary = function(flat_test_results, inline_failures) { - final_results <- private$get_final_results(flat_test_results) - - if (!inline_failures & final_results[["failed"]] > 0) { - private$cat_cr() - cli::cat_rule(cli::style_bold("Failures"), line = 1) - private$show_failures(flat_test_results) } - private$cat_cr() - cli::cat_rule(cli::style_bold("Results"), line = 2) - private$cat_cr() + cli::cat_line(message) - private$show_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 { - private$colourise(n, type) + if (inline_issues & raw_result_summary$skipped > 0) { + show_test_issues("skip", raw_result_df) } - }, - colourise = function(text, as = c("success", "skip", "warning", "failure", "error")) { - if (private$has_colour()) { - unclass(cli::make_ansi_style(private$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) private$colourise(text, colour) else text + if (inline_issues & raw_result_summary$failed > 0) { + show_test_issues("failure", raw_result_df) } - - # 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[private$viapply(x, length) != 0] - }, - viapply = function(X, FUN, ...) { - vapply(X, FUN, ..., FUN.VALUE = integer(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" ) -) -r_cmd_check_fix <- function() { - testthat::test_check() + 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 + line <- srcref[1] + col <- srcref[2] + test <- result_body[["test"]] + message <- result_body[["message"]] + + issue_header <- colourise(first_upper(issue_type), issue_type) + location <- cli::format_inline("{.file {filename}:{line}:{col}}") + issue_message <- cli::format_inline( + cli::style_bold( + "{issue_header} ({location}): {test}" + ) + ) + + message <- gsub(":?\n(\n|.)+", "", message) # only show first line + + cat_cr() + cli::cat_line(issue_message) + cli::cat_line(message) + }) +} + +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) { + cat_cr() + cli::cat_rule(cli::style_bold("Skipped tests "), line = 1) + show_test_issues("skip", flat_test_results) + } + + if (!inline_issues & final_results[["failed"]] > 0) { + cat_cr() + cli::cat_rule(cli::style_bold("Failures"), line = 1) + show_test_issues("failure", flat_test_results) + } + + cat_cr() + 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 } \ No newline at end of file diff --git a/R/tools.R b/R/tools.R index 962f7c2f..5d3a7fe2 100644 --- a/R/tools.R +++ b/R/tools.R @@ -1,33 +1,51 @@ #' Run R unit tests #' -#' Uses the `{testhat}` package to run all unit tests in `tests/testthat` directory. -#' Alternatively, a single unit test file can be provided. -#' -#' @param path Path to file or directory containing tests. Defaults to `tests/testthat`. -#' @param recursive boolean, to run tests on all nested folders inside path. Defaults to TRUE -#' @param ... Additional arguments to pass to `testthat::test_file()` or `testthat::test_dir()`. -#' @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 and skip messages are shown while the tests are running. +#' If `FALSE`, test failure 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, recursively. #' test_r() #' -#' # Run all unit tests in the `tests/testthat` directory only. -#' test_r(recursive = FALSE) +#' # 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( - paths = fs::dir_ls("tests/testthat/", regexp = "\\.R$", recurse = TRUE, type = "file"), - inline_failures = FALSE, - raw_output = FALSE + paths = fs::dir_ls("tests/testthat/", glob = "*.R", recurse = TRUE, type = "file"), + inline_issues = FALSE, + raw_testthat_output = FALSE ) { - test <- RecursiveUnitTests$new() - test$run_tests(paths, inline_failures, raw_output) + files <- traverse_test_paths(paths) + + show_test_header() + test_results <- test_files(files, inline_issues) + 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 30cf99b3..294615ef 100644 --- a/man/test_r.Rd +++ b/man/test_r.Rd @@ -4,32 +4,42 @@ \alias{test_r} \title{Run R unit tests} \usage{ -test_r(path = fs::path("tests", "testthat"), recursive = TRUE, ...) +test_r( + paths = fs::dir_ls("tests/testthat/", glob = "*.R", recurse = TRUE, type = "file"), + inline_issues = FALSE, + raw_testthat_output = FALSE +) } \arguments{ -\item{path}{Path to file or directory containing tests. Defaults to \code{tests/testthat}.} +\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{recursive}{boolean, to run tests on all nested folders inside path. Defaults to TRUE} +\item{inline_issues}{If \code{TRUE}, test failure and skip messages are shown while the tests are running. +If \code{FALSE}, test failure and skip messages are shown after all tests are run.} -\item{...}{Additional arguments to pass to \code{testthat::test_file()} or \code{testthat::test_dir()}.} +\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. -Alternatively, a single unit test file can be provided. +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, recursively. test_r() - # Run all unit tests in the `tests/testthat` directory only. - test_r(recursive = FALSE) + # 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..48a4e24f --- /dev/null +++ b/tests/testthat/test-test_r.R @@ -0,0 +1,102 @@ +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), 5) +}) + +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 0 | SKIP 1 | PASS 3 ]", 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), 4) +}) + +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), 4) +}) + +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) +}) \ No newline at end of file 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..d81bea27 --- /dev/null +++ b/tests/testthat/test_recursive/view/test-view_sample.R @@ -0,0 +1,8 @@ +test_that("multiplication works", { + expect_equal(2 * 2, 4) +}) + +test_that("skip example", { + skip("Skip this") + expect_true(TRUE) +}) From 54a0703c1b3db07a3ebf4466a7d2c53dd78f4d48 Mon Sep 17 00:00:00 2001 From: Rodrigo Basa Date: Thu, 2 Feb 2023 19:46:45 +0800 Subject: [PATCH 08/16] renamed test helper file --- R/{recursive_unit_tests.R => test_helpers.R} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename R/{recursive_unit_tests.R => test_helpers.R} (100%) diff --git a/R/recursive_unit_tests.R b/R/test_helpers.R similarity index 100% rename from R/recursive_unit_tests.R rename to R/test_helpers.R From ae9ccde1421c4e7c6fe90793a3902fdf5d00a264 Mon Sep 17 00:00:00 2001 From: Rodrigo Basa Date: Thu, 2 Feb 2023 20:06:43 +0800 Subject: [PATCH 09/16] adjust whitespace --- R/test_helpers.R | 13 ++++++++----- R/tools.R | 1 + 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/R/test_helpers.R b/R/test_helpers.R index 1ba37cf8..fd06af5f 100644 --- a/R/test_helpers.R +++ b/R/test_helpers.R @@ -51,10 +51,14 @@ test_files <- function(files, inline_issues, min_time = 0.1) { 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$failed > 0) { + cli::cat_rule(line = 1) show_test_issues("failure", raw_result_df) + cli::cat_rule(line = 1) } } @@ -123,11 +127,13 @@ show_test_issues <- function(issue_type, test_results) { ) ) - message <- gsub(":?\n(\n|.)+", "", message) # only show first line + if (issue_type == "skip") { + message <- gsub(":?\n(\n|.)+", "", message) # only show first line + } - cat_cr() cli::cat_line(issue_message) cli::cat_line(message) + cat_cr() }) } @@ -135,18 +141,15 @@ 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) { - cat_cr() cli::cat_rule(cli::style_bold("Skipped tests "), line = 1) show_test_issues("skip", flat_test_results) } if (!inline_issues & final_results[["failed"]] > 0) { - cat_cr() cli::cat_rule(cli::style_bold("Failures"), line = 1) show_test_issues("failure", flat_test_results) } - cat_cr() 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") diff --git a/R/tools.R b/R/tools.R index 5d3a7fe2..13a846d5 100644 --- a/R/tools.R +++ b/R/tools.R @@ -36,6 +36,7 @@ test_r <- function( 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) From 6e571373e16ad806d451e6d69c3b0ee7313d74cf Mon Sep 17 00:00:00 2001 From: Rodrigo Basa Date: Thu, 2 Feb 2023 20:10:45 +0800 Subject: [PATCH 10/16] cleanup styling --- R/test_helpers.R | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/R/test_helpers.R b/R/test_helpers.R index fd06af5f..29262abf 100644 --- a/R/test_helpers.R +++ b/R/test_helpers.R @@ -91,12 +91,13 @@ show_test_header <- function() { show_test_final_line <- function(final_results) { cli::cat_line( - summary_line(final_results[["failed"]], - final_results[["warning"]], - final_results[["skipped"]], - final_results[["passed"]]) + summary_line( + final_results[["failed"]], + final_results[["warning"]], + final_results[["skipped"]], + final_results[["passed"]] + ) ) - cat_cr() } From 5cd4927b7d1d67d1a3a65c2ed28b8ab78499fbf8 Mon Sep 17 00:00:00 2001 From: Rodrigo Basa Date: Thu, 2 Feb 2023 20:12:29 +0800 Subject: [PATCH 11/16] documentation cleanup --- R/tools.R | 11 +++++++---- man/test_r.Rd | 11 +++++++---- 2 files changed, 14 insertions(+), 8 deletions(-) diff --git a/R/tools.R b/R/tools.R index 13a846d5..65a6702d 100644 --- a/R/tools.R +++ b/R/tools.R @@ -6,11 +6,14 @@ #' @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 and skip messages are shown while the tests are running. -#' If `FALSE`, test failure and skip messages are shown after all tests are run. +#' @param inline_issues If `TRUE`, test failure and skip messages are shown while the +#' tests are running. If `FALSE`, test failure 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()`. +#' @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()) { diff --git a/man/test_r.Rd b/man/test_r.Rd index 294615ef..719c1395 100644 --- a/man/test_r.Rd +++ b/man/test_r.Rd @@ -15,14 +15,17 @@ test_r( 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 and skip messages are shown while the tests are running. -If \code{FALSE}, test failure and skip messages are shown after all tests are run.} +\item{inline_issues}{If \code{TRUE}, test failure and skip messages are shown while the +tests are running. If \code{FALSE}, test failure and skip messages are shown after +all tests are run.} \item{raw_testthat_output}{boolean, See return value.} } \value{ -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()}. +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 the \code{tests/testthat} directory. From 7224d28c3ec6a3ad53b870cd103e3212318c2ce8 Mon Sep 17 00:00:00 2001 From: Rodrigo Basa Date: Thu, 2 Feb 2023 20:43:35 +0800 Subject: [PATCH 12/16] added warning messages --- R/test_helpers.R | 15 ++++++++++-- tests/testthat/test-test_r.R | 24 +++++++++++++++---- .../test_recursive/view/test-view_sample.R | 5 ++++ 3 files changed, 37 insertions(+), 7 deletions(-) diff --git a/R/test_helpers.R b/R/test_helpers.R index 29262abf..c1f2f5c0 100644 --- a/R/test_helpers.R +++ b/R/test_helpers.R @@ -55,6 +55,11 @@ test_files <- function(files, inline_issues, min_time = 0.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) @@ -105,7 +110,8 @@ show_test_issues <- function(issue_type, test_results) { df_column <- switch( issue_type, "failure" = "failed", - "skip" = "skipped" + "skip" = "skipped", + "warning" = "warning" ) issue_tests <- test_results[test_results[[df_column]] > 0, "result"] @@ -142,10 +148,15 @@ 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) + 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) diff --git a/tests/testthat/test-test_r.R b/tests/testthat/test-test_r.R index 48a4e24f..0de9858c 100644 --- a/tests/testthat/test-test_r.R +++ b/tests/testthat/test-test_r.R @@ -9,7 +9,7 @@ test_that("test_r returns an invisible data.frame with the correct number of row expect_invisible(test_results <- test_r(paths)) expect_s3_class(test_results, "data.frame") - expect_equal(nrow(test_results), 5) + expect_equal(nrow(test_results), 6) }) test_that("test_r returns a list when raw_testthat_output = TRUE", { @@ -24,7 +24,7 @@ test_that("test_r returns a list when raw_testthat_output = TRUE", { 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 0 | SKIP 1 | PASS 3 ]", fixed = TRUE) + expect_output(test_r(paths), "[ FAIL 1 | WARN 1 | SKIP 1 | PASS 4 ]", fixed = TRUE) }) test_that("test_r accepts a single test file", { @@ -57,7 +57,7 @@ test_that("test_r accepts more than one directory as paths for tests", { test_results <- test_r(paths) - expect_equal(nrow(test_results), 4) + expect_equal(nrow(test_results), 5) }) test_that("test_r accepts a mix of files and directories as paths", { @@ -68,7 +68,7 @@ test_that("test_r accepts a mix of files and directories as paths", { test_results <- test_r(paths) - expect_equal(nrow(test_results), 4) + expect_equal(nrow(test_results), 5) }) test_that("test_r shows a failed test", { @@ -99,4 +99,18 @@ test_that("test_r shows a skipped test inline when inline_issues = TRUE", { # "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) -}) \ No newline at end of file +}) + +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/view/test-view_sample.R b/tests/testthat/test_recursive/view/test-view_sample.R index d81bea27..8c4701ce 100644 --- a/tests/testthat/test_recursive/view/test-view_sample.R +++ b/tests/testthat/test_recursive/view/test-view_sample.R @@ -6,3 +6,8 @@ test_that("skip example", { skip("Skip this") expect_true(TRUE) }) + +test_that("warning example", { + warning("warn warn warn") + expect_true(TRUE) +}) \ No newline at end of file From bc31fc5e59f7d3fe466fe5912153b92c74cb4bc1 Mon Sep 17 00:00:00 2001 From: Rodrigo Basa Date: Thu, 2 Feb 2023 20:46:13 +0800 Subject: [PATCH 13/16] updated documentation for warnings --- R/tools.R | 4 ++-- man/test_r.Rd | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/R/tools.R b/R/tools.R index 65a6702d..2e13eaaa 100644 --- a/R/tools.R +++ b/R/tools.R @@ -6,8 +6,8 @@ #' @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 and skip messages are shown while the -#' tests are running. If `FALSE`, test failure and skip messages are shown after +#' @param inline_issues If `TRUE`, test failure, wanring, 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 diff --git a/man/test_r.Rd b/man/test_r.Rd index 719c1395..b99cfa11 100644 --- a/man/test_r.Rd +++ b/man/test_r.Rd @@ -15,8 +15,8 @@ test_r( 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 and skip messages are shown while the -tests are running. If \code{FALSE}, test failure and skip messages are shown after +\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.} From 45e7b26c5b5985f35fa368e02239d113c1044177 Mon Sep 17 00:00:00 2001 From: Rodrigo Basa Date: Fri, 3 Feb 2023 19:05:08 +0800 Subject: [PATCH 14/16] clean environment of box modules before running tests to avoid box::reload() calls in test files --- R/tools.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/tools.R b/R/tools.R index 53baf8b4..120f78fa 100644 --- a/R/tools.R +++ b/R/tools.R @@ -11,6 +11,7 @@ #' } #' @export test_r <- function() { + purge_box_cache() testthat::test_dir(fs::path("tests", "testthat")) } From 01b62bf0bfdb039c3e0d6391b0f437f3d3f891f3 Mon Sep 17 00:00:00 2001 From: Rodrigo Basa Date: Fri, 3 Feb 2023 19:28:23 +0800 Subject: [PATCH 15/16] rationalize version numbers and news entry --- DESCRIPTION | 2 +- NEWS.md | 4 ++++ 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 847495aa..bbac0fb0 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: rhino Title: A Framework for Enterprise Shiny Applications -Version: 1.3.0.8002 +Version: 1.3.0.9203 Authors@R: c( person("Kamil", "Żyła", role = c("aut", "cre"), email = "opensource+kamil@appsilon.com"), diff --git a/NEWS.md b/NEWS.md index 9f8e4063..c3b4be47 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,7 @@ +# rhino (development version) + +1. `test_r()` support for unit tests with a folder/directory structure. + # rhino 1.3.0 1. Rhino now works with `shinytest2` out of the box. From babfb817c1ba4de7217ba4e33b0476b26d147a69 Mon Sep 17 00:00:00 2001 From: Rodrigo Basa Date: Mon, 6 Feb 2023 18:57:47 +0800 Subject: [PATCH 16/16] fix some ci fails (lint and spelling) --- R/test_helpers.R | 30 +++++++++---------- R/tools.R | 2 +- tests/testthat/test-test_r.R | 6 ++-- .../test_recursive/view/test-view_sample.R | 2 +- 4 files changed, 20 insertions(+), 20 deletions(-) diff --git a/R/test_helpers.R b/R/test_helpers.R index c1f2f5c0..6bd19300 100644 --- a/R/test_helpers.R +++ b/R/test_helpers.R @@ -8,7 +8,7 @@ traverse_test_paths <- function(paths) { ) } }) - + unlist(list_of_files, use.names = FALSE) } @@ -70,7 +70,7 @@ test_files <- function(files, inline_issues, min_time = 0.1) { return(raw_result) }) - + compact(test_results) } @@ -120,14 +120,14 @@ show_test_issues <- function(issue_type, test_results) { result_body <- issue_test[[1]] srcref <- result_body[["srcref"]] srcfile <- attr(srcref, "srcfile") - filename <- srcfile$filename - line <- srcref[1] - col <- srcref[2] - test <- result_body[["test"]] + 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) - location <- cli::format_inline("{.file {filename}:{line}:{col}}") + + 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}" @@ -147,17 +147,17 @@ show_test_issues <- function(issue_type, test_results) { 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) { + 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) { + 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) { + if (!inline_issues && final_results[["failed"]] > 0) { cli::cat_rule(cli::style_bold("Failures"), line = 1) show_test_issues("failure", flat_test_results) } @@ -231,11 +231,11 @@ compact <- function(x) { x[viapply(x, length) != 0] } -viapply <- function(X, FUN, ...) { - vapply(X, FUN, ..., FUN.VALUE = integer(1)) +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 -} \ No newline at end of file +} diff --git a/R/tools.R b/R/tools.R index 05b8259b..8828ce94 100644 --- a/R/tools.R +++ b/R/tools.R @@ -6,7 +6,7 @@ #' @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, wanring, and skip messages are shown while the +#' @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. diff --git a/tests/testthat/test-test_r.R b/tests/testthat/test-test_r.R index 0de9858c..ec42d6d2 100644 --- a/tests/testthat/test-test_r.R +++ b/tests/testthat/test-test_r.R @@ -88,14 +88,14 @@ test_that("test_r shows a failed test inline when inline_issues = 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) @@ -103,7 +103,7 @@ test_that("test_r shows a skipped test inline when inline_issues = 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") }) diff --git a/tests/testthat/test_recursive/view/test-view_sample.R b/tests/testthat/test_recursive/view/test-view_sample.R index 8c4701ce..87e7608e 100644 --- a/tests/testthat/test_recursive/view/test-view_sample.R +++ b/tests/testthat/test_recursive/view/test-view_sample.R @@ -10,4 +10,4 @@ test_that("skip example", { test_that("warning example", { warning("warn warn warn") expect_true(TRUE) -}) \ No newline at end of file +})