diff --git a/NEWS.md b/NEWS.md index c60c7f16f..92a8c6fce 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,6 @@ # testthat (development version) +* `expect_lt()`, `expect_gt()`, and friends have a refined display that is more likely to display the correct number of digits and shows you the actual values compared. * `describe()`, `it()`, and `test_that()` now have a shared stack of descriptions so that if you nest any inside of each other, any resulting failures will show you the full path. * `describe()` now correctly scopes `skip()` (#2007). * `ParallelProgressReporter` now respect `max_failures` (#1162). diff --git a/R/expect-comparison.R b/R/expect-comparison.R index b6b3b63eb..985c065aa 100644 --- a/R/expect-comparison.R +++ b/R/expect-comparison.R @@ -31,21 +31,31 @@ expect_compare_ <- function( msg <- c( "<" = "not strictly less than", "<=" = "not less than", - ">" = "not strictly more than", - ">=" = "not more than" + ">" = "not strictly greater than", + ">=" = "not greater than" )[[operator]] + negated_op <- switch(operator, "<" = ">=", "<=" = ">", ">" = "<=", ">=" = "<") + cmp <- op(act$val, exp$val) if (length(cmp) != 1 || !is.logical(cmp)) { abort("Result of comparison must be a single logical value") } if (!isTRUE(cmp)) { + digits <- max( + digits(act$val), + digits(exp$val), + min_digits(act$val, exp$val) + ) msg <- sprintf( - "%s is %s %s. Difference: %.3g", + "%s is %s %s.\n%s - %s = %s %s 0", act$lab, msg, exp$lab, - act$val - exp$val + num_exact(act$val, digits), + num_exact(exp$val, digits), + num_exact(act$val - exp$val, digits), + negated_op ) return(fail(msg, trace_env = trace_env)) } @@ -109,3 +119,39 @@ expect_more_than <- function(...) { warning("Deprecated: please use `expect_gt()` instead", call. = FALSE) expect_gt(...) } + + +# Helpers ----------------------------------------------------------------- + +num_exact <- function(x, digits = 6) { + sprintf(paste0("%0.", digits, "f"), x) +} + +min_digits <- function(x, y, tolerance = testthat_tolerance()) { + if (is.integer(x) && is.integer(y)) { + return(0L) + } + + attributes(x) <- NULL + attributes(y) <- NULL + + n <- digits(abs(x - y)) + if (!is.null(tolerance)) { + n <- min(n, digits(tolerance)) + } + + as.integer(n) + 1L +} + +digits <- function(x) { + x <- x[!is.na(x) & x != 0] + if (length(x) == 0) { + return(0) + } + scale <- -log10(min(x)) + if (scale <= 0) { + 0L + } else { + ceiling(round(scale, digits = 2)) + } +} diff --git a/tests/testthat/_snaps/expect-comparison.md b/tests/testthat/_snaps/expect-comparison.md new file mode 100644 index 000000000..ad689bbba --- /dev/null +++ b/tests/testthat/_snaps/expect-comparison.md @@ -0,0 +1,20 @@ +# useful output when numbers are very small + + 1.1 * x is not less than `x`. + 0.0000110 - 0.0000100 = 0.0000010 > 0 + +--- + + `x` is not strictly greater than 1.1 * x. + 0.0000100 - 0.0000110 = -0.0000010 <= 0 + +# useful output when difference is zero + + `x` is not strictly less than 100. + 100.0 - 100.0 = 0.0 >= 0 + +# useful output when differnce is large + + `x` is not strictly less than 0.001. + 100.000 - 0.001 = 99.999 >= 0 + diff --git a/tests/testthat/test-expect-comparison.R b/tests/testthat/test-expect-comparison.R index a3d485a40..89df396b7 100644 --- a/tests/testthat/test-expect-comparison.R +++ b/tests/testthat/test-expect-comparison.R @@ -8,6 +8,22 @@ test_that("basic comparisons work", { expect_success(expect_gte(10, 10)) }) +test_that("useful output when numbers are very small", { + x <- 1e-5 + expect_snapshot_failure(expect_lte(1.1 * x, x)) + expect_snapshot_failure(expect_gt(x, 1.1 * x)) +}) + +test_that("useful output when difference is zero", { + x <- 100 + expect_snapshot_failure(expect_lt(x, 100)) +}) + +test_that("useful output when differnce is large", { + x <- 100 + expect_snapshot_failure(expect_lt(x, 0.001)) +}) + test_that("comparison result object invisibly", { out <- expect_invisible(expect_lt(1, 10)) expect_equal(out, 1)