R Under development (unstable) (2024-01-07 r85787 ucrt) -- "Unsuffered Consequences"
Copyright (C) 2024 The R Foundation for Statistical Computing
Platform: x86_64-w64-mingw32/x64

R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.

R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.

> options(useFancyQuotes = FALSE)  # Force to stabilise all.equal output
> 
> library(unittest)
> 
> # Compare character output of a (failing) cmp function, ignoring colors
> cmp_lines <- function (actual, ...) {
+     # Remove color escape codes
+     no_color <- gsub('\033\\[.*?m', '', actual, perl = TRUE)
+     if(identical(no_color, c(...)[!is.null(c(...))])) {
+         return(TRUE)
+     }
+     # utils::str(no_color, vec.len = 1000, digits.d = 5, nchar.max = 1000)
+     return(c(c(...)[!is.null(c(...))], '----', actual))
+ }
> 
> # Mock (fn) in namespace with (replacement) whilst (block) is being evaluated
> mock <- function (fn, replacement, block) {
+     # Get the name of the function from the unevaluated argument,
+     # assuming it's of the form package::name
+     fn_name <- as.character(as.list(sys.call()[[2]])[[3]])
+     ns <- environment(fn)
+ 
+     orig_fn <- get(fn_name, env = ns)
+     unlockBinding(fn_name, env = ns)
+     assign(fn_name, replacement, envir = ns)
+     on.exit(assign(fn_name, orig_fn, envir = ns), add = TRUE)
+ 
+     block
+ }
> 
> ok_group("ut_cmp_equal", (function () {
+     ok(isTRUE(ut_cmp_equal(4, 4)), "Identical objects return true")
+     ok(isTRUE(ut_cmp_equal(as.integer(4), 4)), "Equivalent objects return true (i.e. integer vs. number)")
+     ok(isTRUE(ut_cmp_equal(0.01, 0.02, tolerance = 0.1)), "Additional arguments passed through to all.equal")
+ 
+     if (!file.exists(unittest:::git_binary())) {
+         ok(TRUE, "# skip git not available")
+         return()
+     }
+ 
+     ok(cmp_lines(ut_cmp_equal(c(2,4,2,8), c(5,4,2,1)),
+         'Mean relative difference: 1',
+         '--- c(2, 4, 2, 8)',
+         '+++ c(5, 4, 2, 1)',
+         '[1] [-2-]{+5+} 4 2 [-8-]{+1+}',
+         NULL), "Vectors filtered by str, individual differences highlighted")
+ 
+     ok(!withVisible(ut_cmp_equal("apples", "oranges"))$visible,
+         "Output of comparision isn't visible (we should print it at a real console though)")
+ 
+     do_a_thing <- function (x) seq(x)
+     ok(cmp_lines(ut_cmp_equal(do_a_thing(4), do_a_thing(1 + 2)),
+         'Numeric: lengths (4, 3) differ',
+         '--- do_a_thing(4)',
+         '+++ do_a_thing(1 + 2)',
+         '[1] 1 2 3[-4-]',
+         NULL), "The ---/+++ lines show expressions handed to ut_cmp_equal()")
+ 
+     ok(cmp_lines(ut_cmp_equal(list(c(1, 2, 8), c(2, 3, 2), 10, 11, 12, 13), list(c(1, 2, 3), c(2, 3, 2), 10, 11, 12, 13)),
+         "Component 1: Mean relative difference: 0.625",
+         "--- list(c(1, 2, 8), c(2, 3, 2), 10, 11, 12, 13)",
+         "+++ list(c(1, 2, 3), c(2, 3, 2), 10, 11, 12, 13)",
+         "[[1]]",
+         "[1] 1 2 [-8-]{+3+}",
+         "",
+         "[[2]]",
+         "[1] 2 3 2",
+         "",
+         "[[3]]",
+         "[1] 10",
+         "",
+         "[[4]]",
+         "[1] 11",
+         "",
+         "[[5]]",
+         "[1] 12",
+         "",
+         "[[6]]",
+         "[1] 13",
+         NULL), "We return the whole file as context, not just the usual 3 lines")
+     
+     ok(cmp_lines(ut_cmp_equal(c("'Ouch!' he said,", "it was an iron bar."), c("Ooops!", "it was an accident.")),
+         '2 string mismatches',
+         '--- c("\'Ouch!\' he said,", "it was an iron bar.")',
+         '+++ c("Ooops!", "it was an accident.")',
+         "[-'Ouch!' he said,-]{+Ooops!+}",
+         'it was an [-iron bar.-]{+accident.+}',
+         NULL), "Character vectors get compared one per line")
+ 
+     ok(cmp_lines(ut_cmp_equal(as.environment(list(a=3, b=4)), as.environment(list(a=5, b=4, c=9))),
+         'Length mismatch: comparison on first 2 components',
+         'Component "a": Mean relative difference: 0.6666667',
+         '--- as.environment(list(a = 3, b = 4))',
+         '+++ as.environment(list(a = 5, b = 4, c = 9))',
+         '{+$c+}',
+         '{+[1] 9+}',
+         '',
+         '$b',
+         '[1] 4',
+         '',
+         '$a',
+         '[1] [-3-]{+5+}',
+         NULL), "Environments get converted to lists")
+ 
+     cmp_helper <- function (a, b) ut_cmp_equal(a, b, deparse_frame = -2)
+     ok(cmp_lines(cmp_helper(2, 8),
+         'Mean relative difference: 3',
+         '--- 2',
+         '+++ 8',
+         '[1] [-2-]{+8+}',
+         NULL), "A helper function can up deparse_frame to improve output")
+ })())
# ut_cmp_equal
ok - Identical objects return true
ok - Equivalent objects return true (i.e. integer vs. number)
ok - Additional arguments passed through to all.equal
ok - Vectors filtered by str, individual differences highlighted
ok - Output of comparision isn't visible (we should print it at a real console though)
ok - The ---/+++ lines show expressions handed to ut_cmp_equal()
ok - We return the whole file as context, not just the usual 3 lines
ok - Character vectors get compared one per line
ok - Environments get converted to lists
ok - A helper function can up deparse_frame to improve output
> 
> # Mock git_binary(), so we don't find git even if it is available
> ok_group("ut_cmp_equal:nogit", mock(unittest:::git_binary, function () "/not-here", {
+     ok(cmp_lines(ut_cmp_equal(c(2,4,2,8), c(5,4,2,1)),
+         'Mean relative difference: 1',
+         '--- c(2, 4, 2, 8)',
+         '[1] 2 4 2 8',
+         '+++ c(5, 4, 2, 1)',
+         '[1] 5 4 2 1',
+         NULL), "No git available, so show outputs side by side")
+ 
+     ok(cmp_lines(ut_cmp_equal(as.environment(list(a=3, b=4)), as.environment(list(a=5, b=4, c=9))),
+         'Length mismatch: comparison on first 2 components',
+         'Component "a": Mean relative difference: 0.6666667',
+         '--- as.environment(list(a = 3, b = 4))',
+         '$b',
+         '[1] 4',
+         '',
+         '$a',
+         '[1] 3',
+         '',
+         '+++ as.environment(list(a = 5, b = 4, c = 9))',
+         '$c',
+         '[1] 9',
+         '',
+         '$b',
+         '[1] 4',
+         '',
+         '$a',
+         '[1] 5',
+         '',
+         NULL), "Environments get converted to lists")
+ }))
# ut_cmp_equal:nogit
ok - No git available, so show outputs side by side
ok - Environments get converted to lists
> 
> ok_group("ut_cmp_identical", (function () {
+     if (!file.exists(unittest:::git_binary())) {
+         ok(TRUE, "# skip git not available")
+         return()
+     }
+ 
+     ok(isTRUE(ut_cmp_identical(4, 4)), "Identical objects return true")
+     ok(cmp_lines(ut_cmp_identical(as.integer(4), 4),
+         '--- as.integer(4)',
+         '+++ 4',
+         ' [-int-]{+num+} 4',
+         NULL), "Equivalent objects do not, unlike ut_cmp_equal(). We also fall back to using str(), as print() will produce identical output")
+ 
+     # NB: On r-oldrel-windows-ix86+x86_64 this produces 1.0000000001,
+     #     not 1.000000000100000008274, regardless expecting this much
+     #     numerical consistency is a bit enthusiastic.
+     ok(cmp_lines(gsub("1.0000000001[0-9]+", "1.0000000001", ut_cmp_identical(1, 1 + 1e-10)),
+         '--- 1',
+         '+++ 1 + 1e-10',
+         ' num [-1-]{+1.0000000001+}',
+         NULL), "Increase str() digits to 22 show a difference")
+ 
+     ok(cmp_lines(ut_cmp_identical(1 + 1e-10, 1 + 1e-7),
+         '--- 1 + 1e-10',
+         '+++ 1 + 1e-07',
+         ' num [-1-]{+1.0000001+}',
+         NULL), "Increase str() digits (7 is enough) show a difference")
+ 
+     cmp_helper <- function (a, b) ut_cmp_identical(a, b, deparse_frame = -2)
+     ok(cmp_lines(cmp_helper(2, 8),
+         '--- 2',
+         '+++ 8',
+         '[1] [-2-]{+8+}',
+         NULL), "A helper function can up deparse_frame to improve output")
+ })())
# ut_cmp_identical
ok - Identical objects return true
ok - Equivalent objects do not, unlike ut_cmp_equal(). We also fall back to using str(), as print() will produce identical output
ok - Increase str() digits to 22 show a difference
ok - Increase str() digits (7 is enough) show a difference
ok - A helper function can up deparse_frame to improve output
> 
> ok_group("output_diff", (function () {
+     if (!file.exists(unittest:::git_binary())) {
+         ok(TRUE, "# skip git not available")
+         return()
+     }
+ 
+     options("cli.num_colors" = 256)
+     ok(any(grepl('\033\\[.*?m', ut_cmp_identical(1L, 2L), perl = TRUE)), "cli.num_colors honoured (escape code in output)")
+ 
+     options("cli.num_colors" = 1)
+     ok(!all(grepl('\033\\[.*?m', ut_cmp_identical(1L, 2L), perl = TRUE)), "cli.num_colors honoured (no escape code in output)")
+ })())
# output_diff
ok - cli.num_colors honoured (escape code in output)
ok - cli.num_colors honoured (no escape code in output)
> 
> ok_group("ut_cmp_identical:nogit", mock(unittest:::git_binary, function () "/not-here", {
+     ok(isTRUE(ut_cmp_identical(4, 4)), "Identical objects return true")
+     ok(cmp_lines(ut_cmp_identical(as.integer(4), 4),
+         '--- as.integer(4)',
+         ' int 4',
+         '+++ 4',
+         ' num 4',
+         NULL), "Equivalent objects do not, unlike ut_cmp_equal(). We also fall back to using str(), as print() will produce identical output")
+ }))
# ut_cmp_identical:nogit
ok - Identical objects return true
ok - Equivalent objects do not, unlike ut_cmp_equal(). We also fall back to using str(), as print() will produce identical output
> 
> proc.time()
   user  system elapsed 
   0.26    0.14    4.34 
# Looks like you passed all 21 tests.