waldo/0000755000176200001440000000000014713223771011367 5ustar liggesuserswaldo/tests/0000755000176200001440000000000014713156617012535 5ustar liggesuserswaldo/tests/testthat/0000755000176200001440000000000014713223771014371 5ustar liggesuserswaldo/tests/testthat/test-compare.R0000644000176200001440000003016014706167014017116 0ustar liggesuserstest_that("same object has no differences", { x <- 1:10 expect_equal(compare_structure(x, x), character()) }) test_that("attributes compare by name", { x <- structure(list(), a = "a", b = "b") y <- structure(list(), b = "b", a = "a") expect_equal(compare_structure(x, y), character()) }) test_that("unnnamed lists compare all positions", { x <- list(1, 2) y <- list(3, 4) expect_length(compare(x, y), 2) }) test_that("can control number of differences", { x <- as.list(letters) y <- as.list(LETTERS) expect_snapshot(compare(x, y, max_diffs = 1)) expect_snapshot(compare(x, y, max_diffs = Inf)) expect_snapshot(compare(letters, LETTERS, max_diffs = 1)) expect_snapshot(compare(letters, LETTERS, max_diffs = 10)) expect_snapshot(compare(letters, LETTERS, max_diffs = 20)) expect_snapshot(compare(letters, LETTERS, max_diffs = Inf)) }) test_that("can optionally ignore attributes", { opts <- compare_opts(ignore_attr = TRUE) x <- y <- 1:5 attr(y, "a") <- "b" expect_equal(compare_structure(x, y, opts = opts), character()) # Ignores class class(y) <- "foofy" expect_equal(compare_structure(x, y, opts = opts), character()) # Ignores names x <- list(x = 1) y <- list(y = 1) expect_equal(compare_structure(x, y, opts = opts), character()) }) test_that("can optionally ignore selected attributes", { x <- y <- 1:5 attr(y, "a") <- "b" attr(y, "b") <- "b" opts <- compare_opts(ignore_attr = c("a", "b")) expect_equal(compare_structure(x, y, opts = opts), character()) expect_snapshot({ compare(x, y, ignore_attr = "a") }) # Ignores names x <- list(x = 1) y <- list(y = 1) opts <- compare_opts(ignore_attr = "names") expect_equal(compare_structure(x, y, opts = opts), character()) }) test_that("can ignore class attribute", { one_a <- structure(1, class = "a") one_b <- structure(1, class = "b") expect_length(compare(one_a, one_b, ignore_attr = "class"), 0) expect_length(compare(one_a, 1, ignore_attr = "class"), 0) expect_snapshot(compare(one_a, 1L, ignore_attr = "class")) expect_length(compare(one_a, 1L, ignore_attr = "class", tolerance = 1e-6), 0) }) test_that("can optionally ignore function/formula envs", { f1a <- y ~ x f1b <- local(y ~ x) expect_equal(length(compare(f1a, f1b, ignore_formula_env = TRUE)), 0) f2a <- function(x) x + 1 f2b <- local(function(x) x + 1) expect_equal(length(compare(f2a, f2b, ignore_function_env = TRUE)), 0) }) test_that("don't strictly compare row names", { df1 <- df2 <- data.frame(x = 1:2) rownames(df2) <- 1:2 expect_equal(compare_structure(df1, df2), character()) }) test_that("can ignore minor numeric differences", { x <- 1:3 expect_equal(compare_structure(x, as.numeric(x), opts = compare_opts(tolerance = 0)), character()) expect_equal(compare_structure(x, x + 1e-9, opts = compare_opts(tolerance = 1e-6)), character()) }) test_that("can compare int64s", { int64_0 <- bit64::as.integer64(0) int64_1 <- bit64::as.integer64(1) expect_snapshot({ compare(int64_1, int64_1) compare(int64_0, int64_1) }) }) test_that("can ignore numeric differences between int64 and other numbers", { int64_1 <- bit64::as.integer64(1) expect_snapshot({ compare(1, int64_1) compare(1, int64_1, tolerance = 0) compare(1L, int64_1, tolerance = 0) }) }) test_that("ignores S3 [[ methods", { expect_snapshot({ x <- as.POSIXlt("2020-01-01") y <- as.POSIXlt("2020-01-02") compare(x, y) x <- package_version("1.0.0") y <- package_version("1.1.0") compare(x, y) }) }) test_that("can optionally compare encoding", { x <- c("fa\xE7ile", "fa\ue7ile") Encoding(x) <- c("latin1", "UTF-8") y <- rev(x) expect_snapshot({ compare(x, y) compare(x, y, ignore_encoding = FALSE) }) }) test_that("lists compare by name, where possible", { expect_snapshot({ "extra y" compare(list("a", "b"), list("a", "b", "c")) compare(list(a = "a", b = "b"), list(a = "a", b = "b", c = "c")) "extra x" compare(list("a", "b", "c"), list("a", "b")) compare(list(a = "a", b = "b", c = "c"), list(a = "a", b= "b")) "different order" compare(list(a = "a", b = "b"), list(b = "b", a = "a")) "invalid names uses position" compare(list(a = "a", "b"), list(a = "a", "c")) compare(list(a = "a", a = "b"), list(a = "a", a = "c")) }) }) test_that("can request lists treated as maps", { compare_map <- function(x, y) compare(x, y, list_as_map = TRUE) expect_equal( compare_map(list(x = 1, 2, y = 3), list(y = 3, 2, x = 1)), new_compare() ) expect_equal( compare_map(list(x = 1, y = NULL, NULL), list(x = 1)), new_compare() ) # But duplicated names are still reported expect_snapshot( compare_map(list(x = 1, y = 1, y = 2), list(x = 1, y = 1)) ) }) test_that("can compare with `missing_arg()`", { expect_snapshot({ compare(missing_arg(), missing_arg()) compare(missing_arg(), sym("a")) compare(sym("a"), missing_arg()) }) expect_snapshot({ "when in a list symbol #79" compare(list(sym("a")), list()) compare(list(), list(sym("a"))) }) }) test_that("comparing functions gives useful diffs", { expect_snapshot({ "equal" f1 <- function(x = 1, y = 2) {} f2 <- function(x = 1, y = 2) {} compare(f1, f2) f2 <- source(test_path("f2.R"), local = TRUE, keep.source = TRUE)$value compare(f1, f2) "pritimives" compare(`[`, sum) compare(sum, prod) "diff formals" f3 <- function(x = 1, y = 1, z = 1) {} compare(f1, f3) "diff body" f4 <- function(x = 1, y = 2) { x + y } compare(f1, f4) "diff environment" environment(f1) <- base_env() environment(f2) <- global_env() compare(f1, f2) }) }) test_that("can choose to compare srcrefs", { f1 <- f2 <- function() { 1 + 2 } attr(f2, "srcref") <- NULL f3 <- function() { 1 + 3 } expect_snapshot({ compare(f2, f1) compare(f2, f1, ignore_srcref = FALSE) "Different body" compare(f3, f1, ignore_srcref = FALSE) }) }) test_that("can compare atomic vectors", { expect_snapshot({ compare(1:3, 10L + 1:3) compare(c(TRUE, FALSE, NA, TRUE), c(FALSE, FALSE, FALSE)) }) }) test_that("can compare S3 objects", { expect_snapshot({ compare(factor("a"), 1L) compare(factor("a"), globalenv()) compare(factor("a"), as.Date("1970-01-02")) compare( structure(function() {}, class = "foo"), factor("a") ) }) }) test_that("can compare S4 objects", { setClass("A", slots = c(x = "character")) setClass("B", contains = "A") expect_snapshot({ "Non S4" compare(new("A", x = "1"), 1) compare(new("A", x = "1"), globalenv()) compare(new("A", x = "1"), factor("x")) "S4" compare(new("A", x = "1"), new("A", x = "1")) compare(new("A", x = "1"), new("A", x = "2")) compare(new("A", x = "1"), new("B", x = "1")) "S4 with extra attributes" new <- old <- new("A", x = "1") attr(new, "bar") <- 2 compare(new, old) }) }) test_that("can distinguish S4 bit", { expect_snapshot({ compare(1, asS4(1)) }) }) test_that("can compare R6 objects", { expect_snapshot({ goofy <- R6::R6Class("goofy", public = list( initialize = function(x) self$x <- x, x = 10 )) froofy <- R6::R6Class("froofy", inherit = goofy, public = list( y = 10 )) "Non R6" compare(goofy$new(1), 1) compare(goofy$new(1), globalenv()) compare(goofy$new(1), factor("x")) "R6" compare(goofy$new(1), goofy$new(1)) compare(goofy$new(1), goofy$new("a")) compare(goofy$new(1), froofy$new(1)) # https://github.com/r-lib/waldo/issues/84 compare(froofy$new(1), froofy$new(1)$clone()) }) }) test_that("can compare S7 objects", { A <- S7::new_class("A", properties = list(a = S7::class_numeric), package = "waldo") B <- S7::new_class("B", parent = A, package = "waldo") expect_snapshot({ "Non S7" compare(A(1), 1) compare(A(1), globalenv()) compare(A(1), factor("x")) "S4" compare(A(1), A(1)) compare(A(1), A(2)) compare(A(1), B(1)) "S7 with extra attributes" new <- old <- A(1) attr(new, "bar") <- 2 compare(new, old) }) }) test_that("Named environments compare by reference", { expect_snapshot({ compare(baseenv(), globalenv()) compare(baseenv(), new.env()) compare(new.env(), baseenv()) }, transform = scrub_environment) }) test_that("unnamed arguments compare by value", { expect_snapshot({ e1 <- new.env(parent = emptyenv()) e2 <- new.env(parent = emptyenv()) compare(e1, e2) e1$x <- 10 e2$x <- 11 compare(e1, e2) e2$x <- 10 compare(e1, e2) }, transform = scrub_environment) }) test_that("compares parent envs", { expect_snapshot({ e1 <- new.env(parent = emptyenv()) e1$x <- 1 e2 <- new.env(parent = emptyenv()) e2$x <- 2 e3 <- new.env(parent = e1) e4 <- new.env(parent = e2) compare(e3, e4) }, transform = scrub_environment) }) test_that("don't get caught in endless loops", { expect_snapshot({ e1 <- new.env(parent = emptyenv()) e2 <- new.env(parent = emptyenv()) e1$x <- 10 e1$y <- e1 e2$x <- 10 e2$y <- e1 compare(e1, e2) e2$y <- e2 compare(e1, e2) }, transform = scrub_environment) }) test_that("only shows paired env different once", { expect_snapshot({ e1 <- new.env(parent = emptyenv()) e2 <- new.env(parent = emptyenv()) e3 <- new.env(parent = emptyenv()) e1$x <- 1 e2$x <- 2 e3$x <- 3 compare(list(e1, e1, e1), list(e2, e2, e3)) }, transform = scrub_environment) }) test_that("can compare classed environments", { e1 <- new.env(parent = emptyenv()) class(e1) <- "foo" e2 <- new.env(parent = emptyenv()) class(e2) <- "foo" expect_equal(compare(e1, e2), new_compare()) }) test_that("can compare CHARSXP", { skip_if(interactive()) char1 <- readRDS(test_path("charsxp-1.rds")) char2 <- readRDS(test_path("charsxp-2.rds")) expect_snapshot({ compare(char1, char2) compare(char1, "foo") }) }) test_that("differences in DOTSXP are ignored", { f <- function(...) { environment() } e <- f(1, 2, 3) expect_snapshot({ compare(f(1), f(1, 2)) }) }) test_that("comparing language objects gives useful diffs", { expect_snapshot({ compare(quote(a), quote(b)) compare(quote(a + b), quote(b + c)) x <- y <- quote(foo(1:3)) y[[2]] <- 1:3 compare(x, y) compare(expression(1, a, a + b), expression(1, a, a + b)) compare(expression(1, a, a + b), expression(1, a, a + c)) }) }) test_that("compare_proxy() can change type", { local_bindings( compare_proxy.foo = function(x, path) { list(object = 10, path = paste0("proxy(", path, ")")) }, .env = global_env() ) expect_equal( compare(structure(1, class = "foo"), structure("x", class = "foo")), new_compare() ) }) test_that("compare_proxy() modifies path", { local_bindings( compare_proxy.foo = function(x, path) { list(object = list(x = x$x), path = paste0("proxy(", path, ")")) }, .env = global_env() ) foo1 <- structure(list(x = 1), class = "foo") foo2 <- structure(list(x = 2), class = "foo") expect_snapshot(compare(foo1, foo2)) }) test_that("options have correct precedence", { x <- list(1) x_tolerant <- structure(x, waldo_opts = list(tolerance = 0)) x_intolerant <- structure(x, waldo_opts = list(tolerance = NULL)) y <- list(1L) y_tolerant <- structure(y, waldo_opts = list(tolerance = 0)) y_intolerant <- structure(y, waldo_opts = list(tolerance = NULL)) # Starts from global defaults expect_length(compare(x, y), 1) # Options beats nothing expect_length(compare(x, y_tolerant), 0) expect_length(compare(x_tolerant, y), 0) # y beats x expect_length(compare(x_intolerant, y_tolerant), 0) expect_length(compare(x_tolerant, y_intolerant), 1) # User supplied beats y expect_length(compare(x_intolerant, y_tolerant, tolerance = NULL), 1) }) test_that("options inherited by children", { x <- structure(list(list(1)), waldo_opts = list(tolerance = 0)) y <- list(list(1L)) expect_length(compare(x, y), 0) }) test_that("can opt out of string quoting", { expect_snapshot( compare(c("a", "b", "c"), c("a", "b", "d"), quote_strings = FALSE) ) }) waldo/tests/testthat/test-utils.R0000644000176200001440000000141214705523306016625 0ustar liggesuserstest_that("as_map() keeps attributes", { expect_equal( as_map(structure(list(b = 1, a = 2), attr1 = "a")), structure(list(a = 2, b = 1), attr1 = "a") ) }) test_that("as_map() leaves unnnamed components alone", { expect_equal(as_map(c(c = 5, 2, b = 3, 4, a = 1)), c(a = 1, 2, b = 3, 4, c = 5)) expect_equal(as_map(c(c = 3, b = 2, a = 1)), c(a = 1, b = 2, c = 3)) expect_equal(as_map(3:1), c(3:1)) }) test_that("as_map() strips NULLs", { expect_equal(as_map(list(a = 1, b = NULL)), list(a = 1)) }) test_that("friendly_type_of() uses single S4 class", { on.exit({removeClass("Foo1"); removeClass("Foo2")}) Foo1 <- setClass("Foo1") Foo2 <- setClass("Foo2", contains = "Foo1") expect_equal(friendly_type_of(Foo2()), "an S4 object of class ") }) waldo/tests/testthat/test-ses.R0000644000176200001440000000255414662171661016274 0ustar liggesuserstest_that("can parse three main formats", { del <- ses(c("a", "b", "c"), c("a", "b")) expect_equal(del, ses_df(3, 3, "d", 2, 2)) add <- ses(c("a", "b"), c("a", "b", "c")) expect_equal(add, ses_df(2, 2, "a", 3, 3)) mod <- ses(c("a", "B", "c"), c("a", "b", "c")) expect_equal(mod, ses_df(2, 2, "c", 2, 2)) }) test_that("can parse multi-element changes", { del <- ses(c("a", "b", "c", "d"), c("a", "b")) expect_equal(del, ses_df(3, 4, "d", 2, 2)) add <- ses(c("a", "b"), c("a", "b", "c", "d")) expect_equal(add, ses_df(2, 2, "a", 3, 4)) }) test_that("can parse large numbers", { del <- ses(c(letters,"x"), letters) expect_equal(del, ses_df(27, 27, "d", 26, 26)) }) test_that("ses_elementwise() matches seq() for exact matches", { expect_equal( ses_elementwise(letters[1:4], letters[1:4]), ses(letters[1:4], letters[1:4]) ) expect_equal( ses_elementwise(letters[1:4], letters[1:2]), ses(letters[1:4], letters[1:2]) ) expect_equal( ses_elementwise(letters[1:2], letters[1:4]), ses(letters[1:2], letters[1:4]) ) }) test_that("ses_elementwise() matches seq() for missing values", { expect_equal( ses_elementwise(NA, TRUE), ses(NA, TRUE) ) expect_equal( ses_elementwise(TRUE, NA), ses(TRUE, NA) ) expect_equal( ses_elementwise(c(NA, TRUE), c(NA, FALSE)), ses(c(NA, TRUE), c(NA, FALSE)) ) }) waldo/tests/testthat/test-compare-opts.R0000644000176200001440000000114414075101361020071 0ustar liggesuserstest_that("all.equal arguments warned an preserved", { expect_warning( opts <- compare_opts(checkNames = FALSE), "checkNames" ) expect_equal(opts$ignore_attr, TRUE) expect_warning( opts <- compare_opts(check.attributes = FALSE), "check.attributes" ) expect_equal(opts$ignore_attr, TRUE) expect_warning( opts <- compare_opts(tol = 1), "tol" ) expect_equal(opts$tolerance, 1) }) test_that("other arguments are ignored with a warning", { expect_snapshot(compare(1, 1, 1)) expect_snapshot(compare(1, 1, abc = 1)) expect_snapshot(compare(1, 1, abc = 1, xyz = 2)) }) waldo/tests/testthat/test-proxy.R0000644000176200001440000000204514662171661016656 0ustar liggesuserstest_that("xml2 proxy generates useful comparisons", { expect_snapshot({ x1a <- xml2::read_xml("1") x1b <- xml2::read_xml("1") compare(x1a, x1b) x2 <- xml2::read_xml("2") compare(x1a, x2) }) }) test_that("POSIXlt comparison ignores balanced attribute", { # Simulate example from https://github.com/r-lib/waldo/issues/160 x1 <- x2 <- as.POSIXlt("2009-08-03 12:01:59", tz = "UTC") attr(x1, "balanced") <- TRUE attr(x2, "balanced") <- NULL expect_length(compare(x1, x2), 0) }) # don't Suggest RProtoBuf, so just mock the classes test_that("RProtoBuf proxy works", { x1 <- x2 <- list(toString = function(x) 1) # strengthen confidence by ensuring toString() is compared x1$a <- 2 x2$a <- 3 proto_methods <- c( "Message", "Descriptor", "EnumDescriptor", "FieldDescriptor", "ServiceDescriptor", "FileDescriptor", "EnumValueDescriptor", "MethodDescriptor" ) for (method in proto_methods) { class(x1) <- class(x2) <- method expect_identical(x1, x2) } }) waldo/tests/testthat/test-compare-value.R0000644000176200001440000001405414705465170020237 0ustar liggesuserstest_that("character comparison", { expect_snapshot({ "no difference" compare_character(c("a", "b"), c("a", "b")) "single change" compare_character(c("a", "b", "c"), c("a", "b")) compare_character(c("a", "b"), c("a", "b", "c")) compare_character(c("a", "B", "c"), c("a", "b", "c")) "multiple contexts" compare_character( c("a", "b", letters, "a", "b", "c", letters, "X"), c("a", "b", "c", letters, "a", "b", letters, "Y") ) "truncation" compare_character(c("X", letters), letters) compare_character(c(letters, "X"), letters) "large diff" compare(letters, c(letters[1:20], "a")) }) }) test_that("NA and 'NA' compare differently", { expect_snapshot(compare(NA_character_, "NA")) }) test_that("multiline comparison", { expect_snapshot({ compare_character("A\nthe apple is red\nC\n", "A\nthe apple was red\nC\n") compare_character("A\nthe apple is red and green\nC\n", "A\nthe apple is red\nC\n") compare_character("A\nthe apple is red and green\nC\n", "A\nI like bananas\nC\n") "trailing newlines are correctly compared" compare("x\n", "x") }) }) test_that("multi-element multi-line comparisons get indices", { expect_snapshot({ compare(c("a", "b", "c\nd"), c("a", "b", "c\ne")) }) }) test_that("show elementwise differences of random permutations", { expect_snapshot({ compare(letters[1:15], letters[c(14, 4, 12, 11, 13, 3, 10, 5, 1, 7, 9, 15, 6, 8, 2)], max_diffs = Inf) compare(letters[1:15], letters[c(3, 13, 6, 10, 11, 9, 4, 5, 15, 2, 12, 14, 8, 7, 1)], max_diffs = Inf) compare(letters[1:15], letters[c(12, 13, 1, 2, 5, 6, 11, 15, 10, 14, 9, 7, 3, 4, 8)], max_diffs = Inf) }) }) test_that("favour smart diff over elementwise when total length is the same", { expect_snapshot({ compare(c(1, 2, 3, 4, 5), c(1, 2, 10, 3, 4, 5)) compare(c(1, 2, 4, 5), c(1, 2, 3, 4, 5)) }) }) test_that("numeric comparison", { expect_snapshot({ "no difference" compare_numeric(1:3, 1:3) compare_numeric(c(1, NA), c(1, NA)) compare_numeric(c(NA, 1), c(1, NA)) "simple change" compare_numeric(c(1, 2, 3), c(1, 2)) compare_numeric(c(1, 2), c(1, 2, 3)) compare_numeric(c(1, 10, 3), c(1, 2, 3)) "equal length" x <- c(1, 2, 3) compare_numeric(x, x + c(-1, 0, 1) * 1e-3) compare_numeric(x, x + c(-1, 0, 1) * 1e-4) compare_numeric(x, x + c(-1, 0, 1) * 1e-5) compare_numeric(x, x + c(-1, 0, 1) * 1e-6) compare_numeric(x, x + c(-1, 0, 1) * 1e-7) compare_numeric(x, x + c(-1, 0, 1) * 1e-8) compare_numeric(x, x + c(-1, 0, 1) * 1e-8, tolerance = NULL) compare_numeric(x, x + c(-1, 0, 1) * 1e-9, tolerance = NULL) compare_numeric(x, x + c(-1, 0, 1) * 1e-10, tolerance = NULL) "unequal length" compare_numeric(c(1, 2, NA), c(1, 2 + 1e-7, NA, 3)) }) }) test_that("tolerance is used in display of differences", { x <- c(1, 2, 3) y <- x + c(1e-9, 1e-9, 1) expect_snapshot({ compare_numeric(x, y) compare_numeric(x, y, tolerance = NULL) }) }) test_that("NAs are shown regardless of position", { expect_snapshot({ compare(c(NA, 1, 2), c(1, 2)) compare(c(1, NA, 2), c(1, 2)) compare(c(1, 2, NA), c(1, 2)) }) }) test_that("informative difference between NA and NaN when tolerance set", { expect_snapshot({ compare_numeric(NA_real_, NaN) compare_numeric(NA_real_, NaN, tolerance = NULL) }) }) test_that("numeric comparison works on factors", { expect_snapshot({ f1 <- factor(c("a", "b", "c")) f2 <- factor(c("a", "c", "b"), c("a", "c", "b")) compare(f1, f2) f3 <- factor(c("a", "B", "c")) compare(f1, f3) }) }) test_that("shows row-by-row diff for numeric matrices", { expect_snapshot({ x <- y <- matrix(1:4, nrow = 2) y[2, 2] <- 5L compare(x, y) }) }) test_that("but not for arrays", { expect_snapshot({ x <- y <- array(1:4, c(1, 2, 2)) y[1, 2, 2] <- 5L compare(x, y) }) }) test_that("falls back to regular display if printed representation the same", { expect_snapshot({ x <- y <- matrix(1:4, nrow = 2) y[2, 2] <- y[2, 2] + 1e-10 compare(x, y) }) }) test_that("uses format method if available", { expect_snapshot({ compare(structure(1, class = "Date"), structure(1.5, class = "Date")) compare(structure(1, class = "Date"), structure(100, class = "Date")) compare(.POSIXct(1, "UTC"), .POSIXct(2, "UTC")) compare(factor("a"), factor("b")) compare(ordered("a"), ordered("b")) compare(factor(c("a", "b")), factor(c("a", "b"), levels = c("b", "a"))) }) }) test_that("ignore_attr never uses format method", { expect_snapshot({ compare(.POSIXct(1, "UTC"), .POSIXct(2, "UTC"), ignore_attr = TRUE) }) }) test_that("don't use format if numeric & within tolerance", { dt <- as.POSIXct("2016-07-18 16:06:00", tz = "UTC") expect_snapshot({ compare(dt, dt + 5) compare(dt, dt + 5, tolerance = 1e-8) }) }) test_that("can compare complex numbers", { expect_snapshot({ compare(1:2 + 1i, 2 + 1i) compare(1:2 + 1i, 1:2 + 2i) }) }) test_that("logical comparisons minimise extraneous diffs", { x1 <- x2 <- rep(TRUE, 50) x2[c(1, 25, 50)] <- FALSE expect_snapshot(compare_logical(x1, x2)) x3 <- rep(c(TRUE, FALSE), 25) x4 <- rep(c(FALSE, TRUE), 26) expect_snapshot(compare_logical(x3, x4)) }) test_that("min_digits correctly computed digits needed for comparison", { expect_equal(min_digits(-0.5, 0.5), 1) expect_equal(min_digits(-0.9090909, 0.9090909), 1) expect_equal(min_digits(0.21, 0.23), 3) expect_equal(min_digits(1.93, 1.92), 3) expect_equal(min_digits(1, 1.1), 2) expect_equal(min_digits(1, 1.01), 3) expect_equal(min_digits(1, 1.001), 4) expect_equal(min_digits(1, 1.0001), 5) expect_equal(min_digits(1, 1.00001), 6) expect_equal(min_digits(1, 1.000001), 7) expect_equal(min_digits(1, 1.0000001), 8) expect_equal(min_digits(1, 1.00000001), 9) expect_equal(min_digits(1, 1.000000001), 9) expect_equal(min_digits(1, 1.0000000001), 9) expect_equal(min_digits(1, 1.000000001, tolerance = NULL), 10) expect_equal(min_digits(1, 1.0000000001, tolerance = NULL), 11) }) waldo/tests/testthat/test-num_equal.R0000644000176200001440000000332014706474213017456 0ustar liggesuserstest_that("num_equal returns early", { expect_equal(num_equal(1, 1:2), FALSE) expect_equal(num_equal(1, 2, NULL), FALSE) expect_equal(num_equal(1, 1), TRUE) expect_equal(num_equal(1, NA), FALSE) expect_equal(num_equal(c(1, NA), c(1, NA)), TRUE) }) test_that("tolerance is relative", { expect_equal(num_equal(1000, 1001, tolerance = 1e-3), TRUE) expect_equal(num_equal(1000, 1002, tolerance = 1e-3), FALSE) }) test_that("tolerance is absolute for small values", { expect_equal(num_equal(0, 0.0009, tolerance = 0.0010), TRUE) expect_equal(num_equal(0, 0.0010, tolerance = 0.0010), FALSE) }) test_that("tolerance works the same way for negative values", { expect_equal(num_equal(4, 4 + 2 * default_tol()), TRUE) expect_equal(num_equal(-4, -4 - 2 * default_tol()), TRUE) }) test_that("infinite values are handled properly", { expect_equal(num_equal(1, Inf), FALSE) expect_equal(num_equal(1, Inf, tolerance = 1.e-8), FALSE) expect_equal(num_equal(Inf, Inf), TRUE) expect_equal(num_equal(Inf, Inf, tolerance = 1.e-8), TRUE) expect_equal(num_equal(-Inf, Inf), FALSE) expect_equal(num_equal(-Inf, Inf, tolerance = 1.e-8), FALSE) }) test_that("NaN is equal to NA_real_ unless tolerance is NULL", { expect_true(num_equal(NaN, NA_real_)) expect_false(num_equal(NaN, NA_real_, tolerance = NULL)) expect_true(num_equal(NaN, NaN)) expect_true(num_equal(NA_real_, NA_real_)) }) test_that("can't can't compare large integers", { expect_snapshot( num_equal(9007199254740995, bit64::as.integer64(1)), error = TRUE ) expect_false(num_equal(9007199254740991, bit64::as.integer64(1))) expect_no_error(num_equal(NA, bit64::as.integer64(1))) expect_no_error(num_equal(bit64::as.integer64(1), NA)) }) waldo/tests/testthat/charsxp-1.rds0000644000176200001440000000005314212417513016700 0ustar liggesusers‹‹àb```b`adb`bf``aàò™Óòó[ž/Çwaldo/tests/testthat/_snaps/0000755000176200001440000000000014706474213015655 5ustar liggesuserswaldo/tests/testthat/_snaps/compare.md0000644000176200001440000004277614706272073017645 0ustar liggesusers# can control number of differences Code compare(x, y, max_diffs = 1) Output `old[[1]]`: "a" `new[[1]]`: "A" And 25 more differences ... --- Code compare(x, y, max_diffs = Inf) Output `old[[1]]`: "a" `new[[1]]`: "A" `old[[2]]`: "b" `new[[2]]`: "B" `old[[3]]`: "c" `new[[3]]`: "C" `old[[4]]`: "d" `new[[4]]`: "D" `old[[5]]`: "e" `new[[5]]`: "E" `old[[6]]`: "f" `new[[6]]`: "F" `old[[7]]`: "g" `new[[7]]`: "G" `old[[8]]`: "h" `new[[8]]`: "H" `old[[9]]`: "i" `new[[9]]`: "I" `old[[10]]`: "j" `new[[10]]`: "J" `old[[11]]`: "k" `new[[11]]`: "K" `old[[12]]`: "l" `new[[12]]`: "L" `old[[13]]`: "m" `new[[13]]`: "M" `old[[14]]`: "n" `new[[14]]`: "N" `old[[15]]`: "o" `new[[15]]`: "O" `old[[16]]`: "p" `new[[16]]`: "P" `old[[17]]`: "q" `new[[17]]`: "Q" `old[[18]]`: "r" `new[[18]]`: "R" `old[[19]]`: "s" `new[[19]]`: "S" `old[[20]]`: "t" `new[[20]]`: "T" `old[[21]]`: "u" `new[[21]]`: "U" `old[[22]]`: "v" `new[[22]]`: "V" `old[[23]]`: "w" `new[[23]]`: "W" `old[[24]]`: "x" `new[[24]]`: "X" `old[[25]]`: "y" `new[[25]]`: "Y" `old[[26]]`: "z" `new[[26]]`: "Z" --- Code compare(letters, LETTERS, max_diffs = 1) Output `old`: "a" and 25 more... `new`: "A" ... --- Code compare(letters, LETTERS, max_diffs = 10) Output `old`: "a" "b" "c" "d" "e" "f" "g" "h" "i" "j" and 16 more... `new`: "A" "B" "C" "D" "E" "F" "G" "H" "I" "J" ... --- Code compare(letters, LETTERS, max_diffs = 20) Output old | new [1] "a" - "A" [1] [2] "b" - "B" [2] [3] "c" - "C" [3] [4] "d" - "D" [4] [5] "e" - "E" [5] [6] "f" - "F" [6] [7] "g" - "G" [7] [8] "h" - "H" [8] [9] "i" - "I" [9] [10] "j" - "J" [10] [11] "k" - "K" [11] [12] "l" - "L" [12] [13] "m" - "M" [13] [14] "n" - "N" [14] [15] "o" - "O" [15] [16] "p" - "P" [16] [17] "q" - "Q" [17] [18] "r" - "R" [18] [19] "s" - "S" [19] [20] "t" - "T" [20] ... ... ... and 6 more ... --- Code compare(letters, LETTERS, max_diffs = Inf) Output old | new [1] "a" - "A" [1] [2] "b" - "B" [2] [3] "c" - "C" [3] [4] "d" - "D" [4] [5] "e" - "E" [5] [6] "f" - "F" [6] [7] "g" - "G" [7] [8] "h" - "H" [8] [9] "i" - "I" [9] [10] "j" - "J" [10] [11] "k" - "K" [11] [12] "l" - "L" [12] [13] "m" - "M" [13] [14] "n" - "N" [14] [15] "o" - "O" [15] [16] "p" - "P" [16] [17] "q" - "Q" [17] [18] "r" - "R" [18] [19] "s" - "S" [19] [20] "t" - "T" [20] [21] "u" - "U" [21] [22] "v" - "V" [22] [23] "w" - "W" [23] [24] "x" - "X" [24] [25] "y" - "Y" [25] [26] "z" - "Z" [26] # can optionally ignore selected attributes Code compare(x, y, ignore_attr = "a") Output `attr(old, 'b')` is absent `attr(new, 'b')` is a character vector ('b') # can ignore class attribute Code compare(one_a, 1L, ignore_attr = "class") Output `old` is an S3 object of class , a double vector `new` is an integer vector (1) # can compare int64s Code compare(int64_1, int64_1) Output v No differences Code compare(int64_0, int64_1) Output `old`: "0" `new`: "1" # can ignore numeric differences between int64 and other numbers Code compare(1, int64_1) Output `old` is a double vector (1) `new` is an S3 object of class , a double vector Code compare(1, int64_1, tolerance = 0) Output v No differences Code compare(1L, int64_1, tolerance = 0) Output v No differences # ignores S3 [[ methods Code x <- as.POSIXlt("2020-01-01") y <- as.POSIXlt("2020-01-02") compare(x, y) Output `old$mday`: 1 `new$mday`: 2 `old$wday`: 3 `new$wday`: 4 `old$yday`: 0 `new$yday`: 1 Code x <- package_version("1.0.0") y <- package_version("1.1.0") compare(x, y) Output `old[[1]]`: 1 0 0 `new[[1]]`: 1 1 0 # can optionally compare encoding Code compare(x, y) Output v No differences Code compare(x, y, ignore_encoding = FALSE) Output `Encoding(old)`: "latin1" "UTF-8" `Encoding(new)`: "UTF-8" "latin1" # lists compare by name, where possible Code # extra y compare(list("a", "b"), list("a", "b", "c")) Output `old` is length 2 `new` is length 3 `old[[3]]` is absent `new[[3]]` is a character vector ('c') Code compare(list(a = "a", b = "b"), list(a = "a", b = "b", c = "c")) Output `old` is length 2 `new` is length 3 `names(old)`: "a" "b" `names(new)`: "a" "b" "c" `old$c` is absent `new$c` is a character vector ('c') Code # extra x compare(list("a", "b", "c"), list("a", "b")) Output `old` is length 3 `new` is length 2 `old[[3]]` is a character vector ('c') `new[[3]]` is absent Code compare(list(a = "a", b = "b", c = "c"), list(a = "a", b = "b")) Output `old` is length 3 `new` is length 2 `names(old)`: "a" "b" "c" `names(new)`: "a" "b" `old$c` is a character vector ('c') `new$c` is absent Code # different order compare(list(a = "a", b = "b"), list(b = "b", a = "a")) Output `names(old)`: "a" "b" `names(new)`: "b" "a" Code # invalid names uses position compare(list(a = "a", "b"), list(a = "a", "c")) Output `old[[2]]`: "b" `new[[2]]`: "c" Code compare(list(a = "a", a = "b"), list(a = "a", a = "c")) Output `old[[2]]`: "b" `new[[2]]`: "c" # can request lists treated as maps Code compare_map(list(x = 1, y = 1, y = 2), list(x = 1, y = 1)) Output `old` is length 3 `new` is length 2 `names(old)`: "x" "y" "y" `names(new)`: "x" "y" `old[[3]]` is a double vector (2) `new[[3]]` is absent # can compare with `missing_arg()` Code compare(missing_arg(), missing_arg()) Output v No differences Code compare(missing_arg(), sym("a")) Output `old` is absent `new` is a symbol Code compare(sym("a"), missing_arg()) Output `old` is a symbol `new` is absent --- Code # when in a list symbol #79 compare(list(sym("a")), list()) Output `old` is length 1 `new` is length 0 `old[[1]]` is a symbol `new[[1]]` is absent Code compare(list(), list(sym("a"))) Output `old` is length 0 `new` is length 1 `old[[1]]` is absent `new[[1]]` is a symbol # comparing functions gives useful diffs Code # equal f1 <- (function(x = 1, y = 2) { }) f2 <- (function(x = 1, y = 2) { }) compare(f1, f2) Output v No differences Code f2 <- source(test_path("f2.R"), local = TRUE, keep.source = TRUE)$value compare(f1, f2) Output v No differences Code # pritimives compare(`[`, sum) Output `old` is `.Primitive("[")` `new` is `.Primitive("sum")` Code compare(sum, prod) Output `old` is `.Primitive("sum")` `new` is `.Primitive("prod")` Code # diff formals f3 <- (function(x = 1, y = 1, z = 1) { }) compare(f1, f3) Output `formals(old)` is length 2 `formals(new)` is length 3 `names(formals(old))`: "x" "y" `names(formals(new))`: "x" "y" "z" `formals(old)$y`: 2.0 `formals(new)$y`: 1.0 `formals(old)$z` is absent `formals(new)$z` is a double vector (1) Code # diff body f4 <- (function(x = 1, y = 2) { x + y }) compare(f1, f4) Output `body(old)`: `{` `}` `body(new)`: `{` ` x + y` `}` Code # diff environment environment(f1) <- base_env() environment(f2) <- global_env() compare(f1, f2) Output `environment(old)` is `environment(new)` is # can choose to compare srcrefs Code compare(f2, f1) Output v No differences Code compare(f2, f1, ignore_srcref = FALSE) Output `attr(old, 'srcref')` is absent `attr(new, 'srcref')` is an S3 object of class , an integer vector Code # Different body compare(f3, f1, ignore_srcref = FALSE) Output `attr(old, 'srcref')`: 225 9 227 3 9 3 225 227 `attr(new, 'srcref')`: 221 15 223 3 15 3 221 223 `attr(body(old), 'srcref')[[1]]`: 225 20 225 20 20 20 225 225 `attr(body(new), 'srcref')[[1]]`: 221 26 221 26 26 26 221 221 `attr(body(old), 'srcref')[[2]]`: 226 5 226 9 5 9 226 226 `attr(body(new), 'srcref')[[2]]`: 222 5 222 9 5 9 222 222 `attr(body(old), 'wholeSrcref')`: 1 0 227 3 0 3 1 227 `attr(body(new), 'wholeSrcref')`: 1 0 223 3 0 3 1 223 `body(old)`: `{` ` 1 + 3` `}` `body(new)`: `{` ` 1 + 2` `}` # can compare atomic vectors Code compare(1:3, 10L + 1:3) Output `old`: 1 2 3 `new`: 11 12 13 Code compare(c(TRUE, FALSE, NA, TRUE), c(FALSE, FALSE, FALSE)) Output `old`: TRUE FALSE TRUE `new`: FALSE FALSE FALSE # can compare S3 objects Code compare(factor("a"), 1L) Output `old` is an S3 object of class , an integer vector `new` is an integer vector (1) Code compare(factor("a"), globalenv()) Output `old` is an S3 object of class , an integer vector `new` is an environment Code compare(factor("a"), as.Date("1970-01-02")) Output `old` is an S3 object of class , an integer vector `new` is an S3 object of class , a double vector Code compare(structure(function() { }, class = "foo"), factor("a")) Output `old` is an S3 object of class , a function `new` is an S3 object of class , an integer vector # can compare S4 objects Code # Non S4 compare(new("A", x = "1"), 1) Output `old` is an S4 object of class `new` is a double vector (1) Code compare(new("A", x = "1"), globalenv()) Output `old` is an S4 object of class `new` is an environment Code compare(new("A", x = "1"), factor("x")) Output `old` is an S4 object of class `new` is an S3 object of class , an integer vector Code # S4 compare(new("A", x = "1"), new("A", x = "1")) Output v No differences Code compare(new("A", x = "1"), new("A", x = "2")) Output `old@x`: "1" `new@x`: "2" Code compare(new("A", x = "1"), new("B", x = "1")) Output `is(old)`: "A" `is(new)`: "B" "A" Code # S4 with extra attributes new <- old <- new("A", x = "1") attr(new, "bar") <- 2 compare(new, old) Output `attr(old, 'bar')` is a double vector (2) `attr(new, 'bar')` is absent # can distinguish S4 bit Code compare(1, asS4(1)) Output `old` is a double vector (1) `new` is an S4 object of class (1) # can compare R6 objects Code goofy <- R6::R6Class("goofy", public = list(initialize = function(x) self$x <- x, x = 10)) froofy <- R6::R6Class("froofy", inherit = goofy, public = list(y = 10)) # Non R6 compare(goofy$new(1), 1) Output `old` is an R6 object of class `new` is a double vector (1) Code compare(goofy$new(1), globalenv()) Output `old` is an R6 object of class `new` is an environment Code compare(goofy$new(1), factor("x")) Output `old` is an R6 object of class `new` is an S3 object of class , an integer vector Code # R6 compare(goofy$new(1), goofy$new(1)) Output v No differences Code compare(goofy$new(1), goofy$new("a")) Output `old$x` is a double vector (1) `new$x` is a character vector ('a') Code compare(goofy$new(1), froofy$new(1)) Output `class(old)`: "goofy" "R6" `class(new)`: "froofy" "goofy" "R6" `old` is length 3 `new` is length 4 `names(old)`: "clone" "initialize" "x" `names(new)`: "clone" "initialize" "x" "y" `old$y` is absent `new$y` is a double vector (10) Code compare(froofy$new(1), froofy$new(1)$clone()) Output v No differences # can compare S7 objects Code # Non S7 compare(A(1), 1) Output `old` is an S7 object of class `new` is a double vector (1) Code compare(A(1), globalenv()) Output `old` is an S7 object of class `new` is an environment Code compare(A(1), factor("x")) Output `old` is an S7 object of class `new` is an S3 object of class , an integer vector Code # S4 compare(A(1), A(1)) Output v No differences Code compare(A(1), A(2)) Output `old@a`: 1.0 `new@a`: 2.0 Code compare(A(1), B(1)) Output `class(old)`: "waldo::A" "S7_object" `class(new)`: "waldo::B" "waldo::A" "S7_object" Code # S7 with extra attributes new <- old <- A(1) attr(new, "bar") <- 2 compare(new, old) Output `attr(old, 'bar')` is a double vector (2) `attr(new, 'bar')` is absent # Named environments compare by reference Code compare(baseenv(), globalenv()) Output `old` is `new` is Code compare(baseenv(), new.env()) Output `old` is `new` is Code compare(new.env(), baseenv()) Output `old` is `new` is # unnamed arguments compare by value Code e1 <- new.env(parent = emptyenv()) e2 <- new.env(parent = emptyenv()) compare(e1, e2) Output v No differences Code e1$x <- 10 e2$x <- 11 compare(e1, e2) Output `old$x`: 10.0 `new$x`: 11.0 Code e2$x <- 10 compare(e1, e2) Output v No differences # compares parent envs Code e1 <- new.env(parent = emptyenv()) e1$x <- 1 e2 <- new.env(parent = emptyenv()) e2$x <- 2 e3 <- new.env(parent = e1) e4 <- new.env(parent = e2) compare(e3, e4) Output `parent.env(old)$x`: 1.0 `parent.env(new)$x`: 2.0 # don't get caught in endless loops Code e1 <- new.env(parent = emptyenv()) e2 <- new.env(parent = emptyenv()) e1$x <- 10 e1$y <- e1 e2$x <- 10 e2$y <- e1 compare(e1, e2) Output v No differences Code e2$y <- e2 compare(e1, e2) Output v No differences # only shows paired env different once Code e1 <- new.env(parent = emptyenv()) e2 <- new.env(parent = emptyenv()) e3 <- new.env(parent = emptyenv()) e1$x <- 1 e2$x <- 2 e3$x <- 3 compare(list(e1, e1, e1), list(e2, e2, e3)) Output `old[[1]]$x`: 1.0 `new[[1]]$x`: 2.0 `old[[3]]$x`: 1.0 `new[[3]]$x`: 3.0 # can compare CHARSXP Code compare(char1, char2) Output `old` is CHARSXP: foo `new` is CHARSXP: bar Code compare(char1, "foo") Output `old` is an internal string `new` is a character vector ('foo') # differences in DOTSXP are ignored Code compare(f(1), f(1, 2)) Output v No differences # comparing language objects gives useful diffs Code compare(quote(a), quote(b)) Output `old` is `a` `new` is `b` Code compare(quote(a + b), quote(b + c)) Output `old`: `a + b` `new`: `b + c` Code x <- y <- quote(foo(1:3)) y[[2]] <- 1:3 compare(x, y) Output `old[[2]]` is a call `new[[2]]` is an integer vector (1, 2, 3) Code compare(expression(1, a, a + b), expression(1, a, a + b)) Output v No differences Code compare(expression(1, a, a + b), expression(1, a, a + c)) Output `old[[3]]`: `a + b` `new[[3]]`: `a + c` # compare_proxy() modifies path Code compare(foo1, foo2) Output `proxy(old)$x`: 1.0 `proxy(new)$x`: 2.0 # can opt out of string quoting Code compare(c("a", "b", "c"), c("a", "b", "d"), quote_strings = FALSE) Output old | new [1] a | a [1] [2] b | b [2] [3] c - d [3] waldo/tests/testthat/_snaps/proxy.md0000644000176200001440000000066214706272074017365 0ustar liggesusers# xml2 proxy generates useful comparisons Code x1a <- xml2::read_xml("1") x1b <- xml2::read_xml("1") compare(x1a, x1b) Output v No differences Code x2 <- xml2::read_xml("2") compare(x1a, x2) Output lines(as.character(old)) vs lines(as.character(new)) "" - "1" + "2" "" waldo/tests/testthat/_snaps/compare-opts.md0000644000176200001440000000072314706272071020610 0ustar liggesusers# other arguments are ignored with a warning Code compare(1, 1, 1) Condition Warning: Unused arguments (1) Output v No differences --- Code compare(1, 1, abc = 1) Condition Warning: Unused arguments (abc = 1) Output v No differences --- Code compare(1, 1, abc = 1, xyz = 2) Condition Warning: Unused arguments (abc = 1, xyz = 2) Output v No differences waldo/tests/testthat/_snaps/compare-class.md0000644000176200001440000000065014706272071020727 0ustar liggesusers# print method covers main cases Code new_compare() Output v No differences Code new_compare(letters[1:3]) Output a b c Code new_compare(letters[1:11]) Output a b c d e f g h i j And 1 more differences ... waldo/tests/testthat/_snaps/diff.md0000644000176200001440000000765414706272074017124 0ustar liggesusers# paired diffs Code # no difference diff_element(c("a", "b"), c("a", "b")) Output v No differences Code # single change diff_element(c("a", "b", "c"), c("a", "b")) Output `x`: "a" "b" "c" `y`: "a" "b" Code diff_element(c("a", "b"), c("a", "b", "c")) Output `x`: "a" "b" `y`: "a" "b" "c" Code diff_element(c("a", "B", "c"), c("a", "b", "c")) Output `x`: "a" "B" "c" `y`: "a" "b" "c" Code # multiple contexts diff_element(c("a", "b", letters, "a", "b", "c", letters, "X"), c("a", "b", "c", letters, "a", "b", letters, "Y")) Output `x[1:5]`: "a" "b" "a" "b" "c" `y[1:6]`: "a" "b" "c" "a" "b" "c" `x[28:34]`: "z" "a" "b" "c" "a" "b" "c" `y[29:34]`: "z" "a" "b" "a" "b" "c" `x[55:58]`: "x" "y" "z" "X" `y[55:58]`: "x" "y" "z" "Y" Code # truncation diff_element(c("X", letters), letters) Output `x[1:4]`: "X" "a" "b" "c" `y[1:3]`: "a" "b" "c" Code diff_element(c(letters, "X"), letters) Output `x[24:27]`: "x" "y" "z" "X" `y[24:26]`: "x" "y" "z" Code # zero length diff_element(letters[1:10], character()) Output `x`: "a" "b" "c" "d" "e" "f" "g" "h" "i" "j" `y`: Code diff_element(character(), letters[1:10]) Output `x`: `y`: "a" "b" "c" "d" "e" "f" "g" "h" "i" "j" # side-by-side diffs Code x <- c("a", "a") diff_element(c(x, "a", "b", "c"), c(x, "a", "b"), width = 20) Output x | y [2] "a" | "a" [2] [3] "a" | "a" [3] [4] "b" | "b" [4] [5] "c" - Code diff_element(c(x, "a", "b"), c(x, "a", "b", "c"), width = 20) Output x | y [2] "a" | "a" [2] [3] "a" | "a" [3] [4] "b" | "b" [4] - "c" [5] Code diff_element(c(x, "a", "B", "c"), c(x, "a", "b", "c"), width = 20) Output x | y [1] "a" | "a" [1] [2] "a" | "a" [2] [3] "a" | "a" [3] [4] "B" - "b" [4] [5] "c" | "c" [5] Code # context diff_element(c(letters, "a", "b"), c(letters, "a", "b", "c"), width = 20) Output x | y [26] "z" | "z" [26] [27] "a" | "a" [27] [28] "b" | "b" [28] - "c" [29] # element-wise diffs Code diff_element(c("a", "b", "c", "d"), c("a", "b"), width = 10) Output x vs y "a" "b" - "c" - "d" Code diff_element(c("a", "b"), c("a", "b", "c", "d"), width = 10) Output x vs y "a" "b" + "c" + "d" Code diff_element(c("a", "B", "C", "d"), c("a", "b", "c", "d"), width = 10) Output x vs y "a" - "B" + "b" - "C" + "c" "d" Code # context diff_element(c(letters, "a", "b"), c(letters, "a", "b", "c"), width = 10) Output x[26:28] vs y[26:29] "y" "z" "a" "b" + "c" # only interleave if change has equal number of lines Code x <- letters diff_element(c(x, 1:2, x), c(x, -(1:2), x), width = 10) Output x[24:31] vs y[24:31] "x" "y" "z" - "1" + "-1" - "2" + "-2" "a" "b" "c" Code diff_element(c(x, 1:3, x), c(x, -(1:2), x), width = 10) Output x[24:32] vs y[24:31] "x" "y" "z" - "1" - "2" - "3" + "-1" + "-2" "a" "b" "c" Code diff_element(c(x, 1:2, x), c(x, -(1:3), x), width = 10) Output x[24:31] vs y[24:32] "x" "y" "z" - "1" - "2" + "-1" + "-2" + "-3" "a" "b" "c" waldo/tests/testthat/_snaps/num_equal.md0000644000176200001440000000037214712725410020162 0ustar liggesusers# can't can't compare large integers Code num_equal(9007199254740996, bit64::as.integer64(1)) Condition Error in `num_equal()`: ! No way to coerce to compatible numeric type. i Try again without setting `tolerance`. waldo/tests/testthat/_snaps/compare-data-frame.md0000644000176200001440000000630514706272071021626 0ustar liggesusers# informative diff for additions and deletions Code df <- data.frame(x = 1:5, y = 5:1) compare(df, unrowname(df[1:3, ])) Output `attr(old, 'row.names')`: 1 2 3 4 5 `attr(new, 'row.names')`: 1 2 3 old vs new x y old[1, ] 1 5 old[2, ] 2 4 old[3, ] 3 3 - old[4, ] 4 2 - old[5, ] 5 1 `old$x`: 1 2 3 4 5 `new$x`: 1 2 3 `old$y`: 5 4 3 2 1 `new$y`: 5 4 3 Code compare(df, unrowname(df[c(1, 5, 2, 3, 4, 5), ])) Output `attr(old, 'row.names')[3:5]`: 3 4 5 `attr(new, 'row.names')[3:6]`: 3 4 5 6 old vs new x y old[1, ] 1 5 + new[2, ] 5 1 old[2, ] 2 4 old[3, ] 3 3 old[4, ] 4 2 `old$x[1:4]`: 1 2 3 4 `new$x[1:5]`: 1 5 2 3 4 `old$y[1:4]`: 5 4 3 2 `new$y[1:5]`: 5 1 4 3 2 # informative diff for changes Code df1 <- data.frame(x = 1:3, y = 1, z = c("a", "b", "c")) df2 <- data.frame(x = c(1, 100, 3), y = 1, z = c("a", "B", "c")) compare(df1, df2) Output old vs new x z old[1, ] 1 a - old[2, ] 2 b + new[2, ] 100 B old[3, ] 3 c `old$x` is an integer vector (1, 2, 3) `new$x` is a double vector (1, 100, 3) `old$z`: "a" "b" "c" `new$z`: "a" "B" "c" # informative diff for rownames Code df1 <- data.frame(x = c(a = 1, b = 2)) df2 <- data.frame(x = c(a = 1, c = 2)) compare(df1, df2) Output `attr(old, 'row.names')`: "a" "b" `attr(new, 'row.names')`: "a" "c" # converts factors to strings Code compare(df1, df2) Output `levels(old$x)`: "a" "b" "c" `levels(new$x)`: "a" "b" "d" # works when nrow(df) > option(max.print) Code withr::local_options(max.print = 1) df1 <- data.frame(a = 1:2, b = 1:2) df2 <- data.frame(a = c(1, 3), b = 1:2) compare(df1, df2) Output old vs new a old[1, ] 1 - old[2, ] 2 + new[2, ] 3 `old$a` is an integer vector (1, 2) `new$a` is a double vector (1, 3) # obeys max_diffs Code df1 <- data.frame(a = 1:5) df2 <- data.frame(a = 5:1) compare(df1, df2, max_diffs = 3) Output old vs new a - old[1, ] 1 + new[1, ] 5 - old[2, ] 2 + new[2, ] 4 old[3, ] 3 and 2 more ... `old$a`: 1 2 3 and 2 more... `new$a`: 5 4 3 ... Code compare(df1, df2, max_diffs = 4) Output old vs new a - old[1, ] 1 + new[1, ] 5 - old[2, ] 2 + new[2, ] 4 old[3, ] 3 - old[4, ] 4 + new[4, ] 2 and 1 more ... `old$a`: 1 2 3 4 and 1 more... `new$a`: 5 4 3 2 ... Code compare(df1, df2, max_diffs = 5) Output old vs new a - old[1, ] 1 + new[1, ] 5 - old[2, ] 2 + new[2, ] 4 old[3, ] 3 - old[4, ] 4 + new[4, ] 2 - old[5, ] 5 + new[5, ] 1 `old$a`: 1 2 3 4 5 `new$a`: 5 4 3 2 1 waldo/tests/testthat/_snaps/compare-value.md0000644000176200001440000002414314706272072020742 0ustar liggesusers# character comparison Code # no difference compare_character(c("a", "b"), c("a", "b")) Output v No differences Code # single change compare_character(c("a", "b", "c"), c("a", "b")) Output `x`: "a" "b" "c" `y`: "a" "b" Code compare_character(c("a", "b"), c("a", "b", "c")) Output `x`: "a" "b" `y`: "a" "b" "c" Code compare_character(c("a", "B", "c"), c("a", "b", "c")) Output `x`: "a" "B" "c" `y`: "a" "b" "c" Code # multiple contexts compare_character(c("a", "b", letters, "a", "b", "c", letters, "X"), c("a", "b", "c", letters, "a", "b", letters, "Y")) Output `x[1:5]`: "a" "b" "a" "b" "c" `y[1:6]`: "a" "b" "c" "a" "b" "c" `x[28:34]`: "z" "a" "b" "c" "a" "b" "c" `y[29:34]`: "z" "a" "b" "a" "b" "c" `x[55:58]`: "x" "y" "z" "X" `y[55:58]`: "x" "y" "z" "Y" Code # truncation compare_character(c("X", letters), letters) Output `x[1:4]`: "X" "a" "b" "c" `y[1:3]`: "a" "b" "c" Code compare_character(c(letters, "X"), letters) Output `x[24:27]`: "x" "y" "z" "X" `y[24:26]`: "x" "y" "z" Code # large diff compare(letters, c(letters[1:20], "a")) Output `old[18:26]`: "r" "s" "t" "u" "v" "w" "x" "y" "z" `new[18:21]`: "r" "s" "t" "a" # NA and 'NA' compare differently Code compare(NA_character_, "NA") Output `old`: NA `new`: "NA" # multiline comparison Code compare_character("A\nthe apple is red\nC\n", "A\nthe apple was red\nC\n") Output `lines(x)`: "A" "the apple is red" "C" "" `lines(y)`: "A" "the apple was red" "C" "" Code compare_character("A\nthe apple is red and green\nC\n", "A\nthe apple is red\nC\n") Output `lines(x)`: "A" "the apple is red and green" "C" "" `lines(y)`: "A" "the apple is red" "C" "" Code compare_character("A\nthe apple is red and green\nC\n", "A\nI like bananas\nC\n") Output `lines(x)`: "A" "the apple is red and green" "C" "" `lines(y)`: "A" "I like bananas" "C" "" Code # trailing newlines are correctly compared compare("x\n", "x") Output `lines(old)`: "x" "" `lines(new)`: "x" # multi-element multi-line comparisons get indices Code compare(c("a", "b", "c\nd"), c("a", "b", "c\ne")) Output `lines(old[[3]])`: "c" "d" `lines(new[[3]])`: "c" "e" # show elementwise differences of random permutations Code compare(letters[1:15], letters[c(14, 4, 12, 11, 13, 3, 10, 5, 1, 7, 9, 15, 6, 8, 2)], max_diffs = Inf) Output `old`: "a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" "m" "n" "o" `new`: "n" "d" "l" "k" "m" "c" "j" "e" "a" "g" "i" "o" "f" "h" "b" Code compare(letters[1:15], letters[c(3, 13, 6, 10, 11, 9, 4, 5, 15, 2, 12, 14, 8, 7, 1)], max_diffs = Inf) Output `old`: "a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" "m" "n" "o" `new`: "c" "m" "f" "j" "k" "i" "d" "e" "o" "b" "l" "n" "h" "g" "a" Code compare(letters[1:15], letters[c(12, 13, 1, 2, 5, 6, 11, 15, 10, 14, 9, 7, 3, 4, 8)], max_diffs = Inf) Output `old`: "a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" "m" "n" "o" `new`: "l" "m" "a" "b" "e" "f" "k" "o" "j" "n" "i" "g" "c" "d" "h" # favour smart diff over elementwise when total length is the same Code compare(c(1, 2, 3, 4, 5), c(1, 2, 10, 3, 4, 5)) Output `old`: 1 2 3 4 5 `new`: 1 2 10 3 4 5 Code compare(c(1, 2, 4, 5), c(1, 2, 3, 4, 5)) Output `old`: 1 2 4 5 `new`: 1 2 3 4 5 # numeric comparison Code # no difference compare_numeric(1:3, 1:3) Output v No differences Code compare_numeric(c(1, NA), c(1, NA)) Output v No differences Code compare_numeric(c(NA, 1), c(1, NA)) Output `x`: NA 1.0 `y`: 1.0 NA Code # simple change compare_numeric(c(1, 2, 3), c(1, 2)) Output `x`: 1 2 3 `y`: 1 2 Code compare_numeric(c(1, 2), c(1, 2, 3)) Output `x`: 1 2 `y`: 1 2 3 Code compare_numeric(c(1, 10, 3), c(1, 2, 3)) Output `x`: 1.0 10.0 3.0 `y`: 1.0 2.0 3.0 Code # equal length x <- c(1, 2, 3) compare_numeric(x, x + c(-1, 0, 1) * 0.001) Output `x`: 1.0000 2.0000 3.0000 `y`: 0.9990 2.0000 3.0010 Code compare_numeric(x, x + c(-1, 0, 1) * 1e-04) Output `x`: 1.00000 2.00000 3.00000 `y`: 0.99990 2.00000 3.00010 Code compare_numeric(x, x + c(-1, 0, 1) * 1e-05) Output `x`: 1.000000 2.000000 3.000000 `y`: 0.999990 2.000000 3.000010 Code compare_numeric(x, x + c(-1, 0, 1) * 1e-06) Output `x`: 1.0000000 2.0000000 3.0000000 `y`: 0.9999990 2.0000000 3.0000010 Code compare_numeric(x, x + c(-1, 0, 1) * 1e-07) Output `x`: 1.00000000 2.00000000 3.00000000 `y`: 0.99999990 2.00000000 3.00000010 Code compare_numeric(x, x + c(-1, 0, 1) * 1e-08) Output v No differences Code compare_numeric(x, x + c(-1, 0, 1) * 1e-08, tolerance = NULL) Output `x`: 1.000000000 2.000000000 3.000000000 `y`: 0.999999990 2.000000000 3.000000010 Code compare_numeric(x, x + c(-1, 0, 1) * 1e-09, tolerance = NULL) Output `x`: 1.0000000000 2.0000000000 3.0000000000 `y`: 0.9999999990 2.0000000000 3.0000000010 Code compare_numeric(x, x + c(-1, 0, 1) * 1e-10, tolerance = NULL) Output `x`: 1.00000000000 2.00000000000 3.00000000000 `y`: 0.99999999990 2.00000000000 3.00000000010 Code # unequal length compare_numeric(c(1, 2, NA), c(1, 2 + 1e-07, NA, 3)) Output `x[2:3]`: 2 NA `y`: 1 2.0000001 NA 3 # tolerance is used in display of differences Code compare_numeric(x, y) Output `x`: 1.000000000 2.000000000 3.000000000 `y`: 1.000000001 2.000000001 4.000000000 Code compare_numeric(x, y, tolerance = NULL) Output `x`: 1.0000000000 2.0000000000 3.0000000000 `y`: 1.0000000010 2.0000000010 4.0000000000 # NAs are shown regardless of position Code compare(c(NA, 1, 2), c(1, 2)) Output `old`: NA 1 2 `new`: 1 2 Code compare(c(1, NA, 2), c(1, 2)) Output `old`: 1 NA 2 `new`: 1 2 Code compare(c(1, 2, NA), c(1, 2)) Output `old`: 1 2 NA `new`: 1 2 # informative difference between NA and NaN when tolerance set Code compare_numeric(NA_real_, NaN) Output v No differences Code compare_numeric(NA_real_, NaN, tolerance = NULL) Output `x`: NA `y`: NaN # numeric comparison works on factors Code f1 <- factor(c("a", "b", "c")) f2 <- factor(c("a", "c", "b"), c("a", "c", "b")) compare(f1, f2) Output `levels(old)`: "a" "b" "c" `levels(new)`: "a" "c" "b" Code f3 <- factor(c("a", "B", "c")) compare(f1, f3) Output `levels(old)`: "a" "b" "c" `levels(new)`: "B" "a" "c" `old`: "a" "b" "c" `new`: "a" "B" "c" # shows row-by-row diff for numeric matrices Code x <- y <- matrix(1:4, nrow = 2) y[2, 2] <- 5L compare(x, y) Output old vs new [,1] [,2] old[1, ] 1 3 - old[2, ] 2 4 + new[2, ] 2 5 # but not for arrays Code x <- y <- array(1:4, c(1, 2, 2)) y[1, 2, 2] <- 5L compare(x, y) Output `old`: 1 2 3 4 `new`: 1 2 3 5 # falls back to regular display if printed representation the same Code x <- y <- matrix(1:4, nrow = 2) y[2, 2] <- y[2, 2] + 1e-10 compare(x, y) Output `old` is an integer vector (1, 2, 3, 4) `new` is a double vector (1, 2, 3, 4.0000000001) # uses format method if available Code compare(structure(1, class = "Date"), structure(1.5, class = "Date")) Output `unclass(old)`: 1.00 `unclass(new)`: 1.50 Code compare(structure(1, class = "Date"), structure(100, class = "Date")) Output `old`: "1970-01-02" `new`: "1970-04-11" Code compare(.POSIXct(1, "UTC"), .POSIXct(2, "UTC")) Output `old`: "1970-01-01 00:00:01" `new`: "1970-01-01 00:00:02" Code compare(factor("a"), factor("b")) Output `levels(old)`: "a" `levels(new)`: "b" Code compare(ordered("a"), ordered("b")) Output `levels(old)`: "a" `levels(new)`: "b" Code compare(factor(c("a", "b")), factor(c("a", "b"), levels = c("b", "a"))) Output `levels(old)`: "a" "b" `levels(new)`: "b" "a" `unclass(old)`: 1.0 2.0 `unclass(new)`: 2.0 1.0 # ignore_attr never uses format method Code compare(.POSIXct(1, "UTC"), .POSIXct(2, "UTC"), ignore_attr = TRUE) Output `old`: 1.0 `new`: 2.0 # don't use format if numeric & within tolerance Code compare(dt, dt + 5) Output `old`: "2016-07-18 16:06:00" `new`: "2016-07-18 16:06:05" Code compare(dt, dt + 5, tolerance = 1e-08) Output v No differences # can compare complex numbers Code compare(1:2 + 0+1i, 2 + 0+1i) Output `old`: 1+1i 2+1i `new`: 2+1i Code compare(1:2 + 0+1i, 1:2 + 0+2i) Output `Im(old)`: 1.0 1.0 `Im(new)`: 2.0 2.0 # logical comparisons minimise extraneous diffs Code compare_logical(x1, x2) Output `x[1:4]`: TRUE TRUE TRUE TRUE `y[1:4]`: FALSE TRUE TRUE TRUE `x[22:28]`: TRUE TRUE TRUE TRUE TRUE TRUE TRUE `y[22:28]`: TRUE TRUE TRUE FALSE TRUE TRUE TRUE `x[47:50]`: TRUE TRUE TRUE TRUE `y[47:50]`: TRUE TRUE TRUE FALSE --- Code compare_logical(x3, x4) Output `x[1:3]`: TRUE FALSE TRUE `y[1:4]`: FALSE TRUE FALSE TRUE `x[48:50]`: FALSE TRUE FALSE `y[49:52]`: FALSE TRUE FALSE TRUE waldo/tests/testthat/test-compare-class.R0000644000176200001440000000054114073210415020210 0ustar liggesuserstest_that("can construct compare object", { x <- new_compare("Hi!") expect_s3_class(x, "waldo_compare") }) test_that("print method covers main cases", { old <- Sys.getenv("CI") Sys.setenv(CI = "false") on.exit(Sys.setenv(CI = old)) expect_snapshot({ new_compare() new_compare(letters[1:3]) new_compare(letters[1:11]) }) }) waldo/tests/testthat/charsxp-2.rds0000644000176200001440000000005314212417513016701 0ustar liggesusers‹‹àb```b`adb`bf``aàò™“‹Ðw£=waldo/tests/testthat/f2.R0000644000176200001440000000003413641461304015013 0ustar liggesusersfunction(x = 1, y = 2) { } waldo/tests/testthat/test-compare-data-frame.R0000644000176200001440000000371214705471007021117 0ustar liggesuserstest_that("informative diff for additions and deletions", { expect_snapshot({ df <- data.frame(x = 1:5, y = 5:1) compare(df, unrowname(df[1:3, ])) compare(df, unrowname(df[c(1, 5, 2, 3, 4, 5), ])) }) }) test_that("informative diff for changes", { expect_snapshot({ df1 <- data.frame(x = 1:3, y = 1, z = c("a", "b", "c")) df2 <- data.frame(x = c(1, 100, 3), y = 1, z = c("a", "B", "c")) compare(df1, df2) }) }) test_that("informative diff for rownames", { expect_snapshot({ df1 <- data.frame(x = c(a = 1, b = 2)) df2 <- data.frame(x = c(a = 1, c = 2)) compare(df1, df2) }) }) test_that("can set tolerance", { df1 <- data.frame(x = 1) df2 <- data.frame(x = 1.001) expect_length(compare(df1, df2, tolerance = 0.1), 0) }) test_that("converts factors to strings", { df1 <- data.frame(x = factor(c("a", "b", "c"))) df2 <- data.frame(x = factor(c("a", "b", "d"))) expect_snapshot({ compare(df1, df2) }) }) test_that("works when nrow(df) > option(max.print)", { expect_snapshot({ withr::local_options("max.print" = 1) df1 <- data.frame(a = 1:2, b = 1:2) df2 <- data.frame(a = c(1, 3), b = 1:2) compare(df1, df2) }) }) test_that("only used for appropriate data frames", { df <- data.frame(x = 1) expect_equal(compare_data_frame(df, df), NULL) expect_equal(compare_data_frame(df, data.frame()), NULL) expect_equal(compare_data_frame(df, data.frame(y = 1)), NULL) expect_equal(compare_data_frame(df, data.frame(x = FALSE)), NULL) expect_equal(compare_data_frame(df, data.frame(x = structure(1, a = 1))), NULL) expect_equal(compare_data_frame(data.frame(), data.frame()), NULL) df$y <- list(1:10) expect_equal(compare_data_frame(df, data.frame()), NULL) }) test_that("obeys max_diffs", { expect_snapshot({ df1 <- data.frame(a = 1:5) df2 <- data.frame(a = 5:1) compare(df1, df2, max_diffs = 3) compare(df1, df2, max_diffs = 4) compare(df1, df2, max_diffs = 5) }) }) waldo/tests/testthat/test-diff.R0000644000176200001440000000326414415256260016404 0ustar liggesuserstest_that("paired diffs", { expect_snapshot({ "no difference" diff_element(c("a", "b"), c("a", "b")) "single change" diff_element(c("a", "b", "c"), c("a", "b")) diff_element(c("a", "b"), c("a", "b", "c")) diff_element(c("a", "B", "c"), c("a", "b", "c")) "multiple contexts" diff_element( c("a", "b", letters, "a", "b", "c", letters, "X"), c("a", "b", "c", letters, "a", "b", letters, "Y") ) "truncation" diff_element(c("X", letters), letters) diff_element(c(letters, "X"), letters) "zero length" diff_element(letters[1:10], character()) diff_element(character(), letters[1:10]) }) }) test_that("side-by-side diffs", { expect_snapshot({ x <- c("a", "a") diff_element(c(x, "a", "b", "c"), c(x, "a", "b"), width = 20) diff_element(c(x, "a", "b"), c(x, "a", "b", "c"), width = 20) diff_element(c(x, "a", "B", "c"), c(x, "a", "b", "c"), width = 20) "context" diff_element(c(letters, "a", "b"), c(letters, "a", "b", "c"), width = 20) }) }) test_that("element-wise diffs", { expect_snapshot({ diff_element(c("a", "b", "c", "d"), c("a", "b"), width = 10) diff_element(c("a", "b"), c("a", "b", "c", "d"), width = 10) diff_element(c("a", "B", "C", "d"), c("a", "b", "c", "d"), width = 10) "context" diff_element(c(letters, "a", "b"), c(letters, "a", "b", "c"), width = 10) }) }) test_that("only interleave if change has equal number of lines", { expect_snapshot({ x <- letters # to anchor diffs diff_element(c(x, 1:2, x), c(x, -(1:2), x), width = 10) diff_element(c(x, 1:3, x), c(x, -(1:2), x), width = 10) diff_element(c(x, 1:2, x), c(x, -(1:3), x), width = 10) }) }) waldo/tests/testthat.R0000644000176200001440000000006613637650533014522 0ustar liggesuserslibrary(testthat) library(waldo) test_check("waldo") waldo/MD50000644000176200001440000000642014713223771011701 0ustar liggesusers24b1c2b9cd0657bd6908dc398b01f589 *DESCRIPTION 7be88896a6c4a4461e69c8cb0d82e1f0 *LICENSE 6939592a153222dbe5b30bd018a93415 *NAMESPACE f9861acf9edca413b735d0aee0f9f9ec *NEWS.md 4816ee96e748835ec740d96abfed0874 *R/compare-class.R e3fa946b455d123f24ea38ddd7eb7b3a *R/compare-data-frame.R ab974bd790ddd93f35f1ec53ba4b9bae *R/compare-opts.R be4b3d4360857431a1a614071fa35cad *R/compare-value.R 1752933ee606e2ba3e076a4cf3696b5c *R/compare.R f5fc493ce35961109b3736876ef4fd92 *R/diff.R 799bdb3344a8c0c98ff29fa5f7055f01 *R/import-standalone-obj-type.R 62545d8f97ad53b42ec2efcbde7de6bc *R/import-standalone-types-check.R ec07ddb229d238f23a4f236173ff94ae *R/num_equal.R c9daace37b97c65f323da7071875be61 *R/proxy.R 0f881ed97216916b1aae86c663488b5d *R/rematch.R e7a94eb4706b5197f75077f52884ab2e *R/ses.R c8ffbbdc4d07584878ee60b52d2b2e1b *R/utils.R 163e1e88b8c4b1f535f3942e86534bff *R/waldo-package.R 67ba06d288bfb007535182b9f97984d3 *README.md 3555ebc013d31f113a80d5c146cc6b84 *man/compare.Rd 834ce4f7c6fc9a7ce65a585507382fe6 *man/compare_proxy.Rd 811c55fc4fe8cdff141ed6d617456287 *man/figures/README/unnamed-chunk-10.svg c79bab6ac5348a3d828612d9657877dd *man/figures/README/unnamed-chunk-11.svg 26efb57642c0ae075cb4ab596fc2067a *man/figures/README/unnamed-chunk-12.svg a7d6e285199cbe9915d4d7f38d112cfc *man/figures/README/unnamed-chunk-2.svg ba3e8b2bd929123f829057f9c9b5dcd9 *man/figures/README/unnamed-chunk-3.svg cedca24ad45b9189095889b10c29e337 *man/figures/README/unnamed-chunk-4.svg 84fe1b26dc97b9586fba078dbf4970d2 *man/figures/README/unnamed-chunk-5.svg 68b21ae6506b388532676a703aaf78e4 *man/figures/README/unnamed-chunk-6.svg 72897ca8f3f371ab32c7093e3156978c *man/figures/README/unnamed-chunk-7.svg dcee3b2fcc218c2c6bb638222ca87902 *man/figures/README/unnamed-chunk-8.svg b3ee06745833673792f52423ecbc3cc2 *man/figures/README/unnamed-chunk-9.svg eb52d3b078fde6445debca4cf2ce7796 *man/waldo-package.Rd 8586af7172136e962563a5a7e6c53155 *tests/testthat.R b931b43036bf2c66a19f9d8578e0e430 *tests/testthat/_snaps/compare-class.md 7aa69e98bb38835689db248a61b11f89 *tests/testthat/_snaps/compare-data-frame.md 4a213b3316196456e07f0aa5c20b7258 *tests/testthat/_snaps/compare-opts.md b52f9af0eec59096aa96fc654b0730a9 *tests/testthat/_snaps/compare-value.md e5f9e07ed69ef19ca2a732375513af9b *tests/testthat/_snaps/compare.md 2df20b96552271e99d4fb5a923ba7ae7 *tests/testthat/_snaps/diff.md 31da0df1a899f519c52add9adc3c1085 *tests/testthat/_snaps/num_equal.md 08ca0f8059a19a48cd62f59cb05748aa *tests/testthat/_snaps/proxy.md a1312516827ac5857443acf06c192afa *tests/testthat/charsxp-1.rds 9b2c483da2e8cf53ddda390bc97a9931 *tests/testthat/charsxp-2.rds 7dfc8dcb328b76cae6f9c7f5ca9c0441 *tests/testthat/f2.R 0141511eeeaec51b3959145b37a5efc8 *tests/testthat/test-compare-class.R 534cf856da6f6d2fd2d72807e094cd14 *tests/testthat/test-compare-data-frame.R f11ea680ea30726171d2f730343fb8db *tests/testthat/test-compare-opts.R 3329ccc1b0a84f5340b2f2553f88d8b7 *tests/testthat/test-compare-value.R fbf6ae5d7d56102d817f327dfad4ac93 *tests/testthat/test-compare.R 5c5c5fc75460eb70a27758f9637af005 *tests/testthat/test-diff.R 9684a59db7140bed52e62f2cb01df07c *tests/testthat/test-num_equal.R 5a0d0e27462fceaf4a39970da39cdade *tests/testthat/test-proxy.R 9de0e996a6bffee4ec41a45310e5c5fc *tests/testthat/test-ses.R 6526697fd1d2e8627a97a78e0ced969f *tests/testthat/test-utils.R waldo/R/0000755000176200001440000000000014713143542011565 5ustar liggesuserswaldo/R/rematch.R0000644000176200001440000000162414705465170013343 0ustar liggesusers# Source copied from rematch2::re_match, but doesn't return tibble. re_match <- function(text, pattern, perl = TRUE, ...) { stopifnot(is.character(pattern), length(pattern) == 1, !is.na(pattern)) text <- as.character(text) match <- regexpr(pattern, text, perl = perl, ...) start <- as.vector(match) length <- attr(match, "match.length") end <- start + length - 1L matchstr <- substring(text, start, end) matchstr[start == -1] <- NA_character_ res <- data.frame(.text = text, .match = matchstr) if (!is.null(attr(match, "capture.start"))) { gstart <- attr(match, "capture.start") glength <- attr(match, "capture.length") gend <- gstart + glength - 1L groupstr <- substring(text, gstart, gend) groupstr[gstart == -1] <- NA_character_ dim(groupstr) <- dim(gstart) res <- cbind(groupstr, res) } names(res) <- c(attr(match, "capture.names"), ".text", ".match") res } waldo/R/import-standalone-types-check.R0000644000176200001440000003047414706167014017577 0ustar liggesusers# Standalone file: do not edit by hand # Source: https://github.com/r-lib/rlang/blob/HEAD/R/standalone-types-check.R # Generated by: usethis::use_standalone("r-lib/rlang", "types-check") # ---------------------------------------------------------------------- # # --- # repo: r-lib/rlang # file: standalone-types-check.R # last-updated: 2023-03-13 # license: https://unlicense.org # dependencies: standalone-obj-type.R # imports: rlang (>= 1.1.0) # --- # # ## Changelog # # 2024-08-15: # - `check_character()` gains an `allow_na` argument (@martaalcalde, #1724) # # 2023-03-13: # - Improved error messages of number checkers (@teunbrand) # - Added `allow_infinite` argument to `check_number_whole()` (@mgirlich). # - Added `check_data_frame()` (@mgirlich). # # 2023-03-07: # - Added dependency on rlang (>= 1.1.0). # # 2023-02-15: # - Added `check_logical()`. # # - `check_bool()`, `check_number_whole()`, and # `check_number_decimal()` are now implemented in C. # # - For efficiency, `check_number_whole()` and # `check_number_decimal()` now take a `NULL` default for `min` and # `max`. This makes it possible to bypass unnecessary type-checking # and comparisons in the default case of no bounds checks. # # 2022-10-07: # - `check_number_whole()` and `_decimal()` no longer treat # non-numeric types such as factors or dates as numbers. Numeric # types are detected with `is.numeric()`. # # 2022-10-04: # - Added `check_name()` that forbids the empty string. # `check_string()` allows the empty string by default. # # 2022-09-28: # - Removed `what` arguments. # - Added `allow_na` and `allow_null` arguments. # - Added `allow_decimal` and `allow_infinite` arguments. # - Improved errors with absent arguments. # # # 2022-09-16: # - Unprefixed usage of rlang functions with `rlang::` to # avoid onLoad issues when called from rlang (#1482). # # 2022-08-11: # - Added changelog. # # nocov start # Scalars ----------------------------------------------------------------- .standalone_types_check_dot_call <- .Call check_bool <- function(x, ..., allow_na = FALSE, allow_null = FALSE, arg = caller_arg(x), call = caller_env()) { if (!missing(x) && .standalone_types_check_dot_call(ffi_standalone_is_bool_1.0.7, x, allow_na, allow_null)) { return(invisible(NULL)) } stop_input_type( x, c("`TRUE`", "`FALSE`"), ..., allow_na = allow_na, allow_null = allow_null, arg = arg, call = call ) } check_string <- function(x, ..., allow_empty = TRUE, allow_na = FALSE, allow_null = FALSE, arg = caller_arg(x), call = caller_env()) { if (!missing(x)) { is_string <- .rlang_check_is_string( x, allow_empty = allow_empty, allow_na = allow_na, allow_null = allow_null ) if (is_string) { return(invisible(NULL)) } } stop_input_type( x, "a single string", ..., allow_na = allow_na, allow_null = allow_null, arg = arg, call = call ) } .rlang_check_is_string <- function(x, allow_empty, allow_na, allow_null) { if (is_string(x)) { if (allow_empty || !is_string(x, "")) { return(TRUE) } } if (allow_null && is_null(x)) { return(TRUE) } if (allow_na && (identical(x, NA) || identical(x, na_chr))) { return(TRUE) } FALSE } check_name <- function(x, ..., allow_null = FALSE, arg = caller_arg(x), call = caller_env()) { if (!missing(x)) { is_string <- .rlang_check_is_string( x, allow_empty = FALSE, allow_na = FALSE, allow_null = allow_null ) if (is_string) { return(invisible(NULL)) } } stop_input_type( x, "a valid name", ..., allow_na = FALSE, allow_null = allow_null, arg = arg, call = call ) } IS_NUMBER_true <- 0 IS_NUMBER_false <- 1 IS_NUMBER_oob <- 2 check_number_decimal <- function(x, ..., min = NULL, max = NULL, allow_infinite = TRUE, allow_na = FALSE, allow_null = FALSE, arg = caller_arg(x), call = caller_env()) { if (missing(x)) { exit_code <- IS_NUMBER_false } else if (0 == (exit_code <- .standalone_types_check_dot_call( ffi_standalone_check_number_1.0.7, x, allow_decimal = TRUE, min, max, allow_infinite, allow_na, allow_null ))) { return(invisible(NULL)) } .stop_not_number( x, ..., exit_code = exit_code, allow_decimal = TRUE, min = min, max = max, allow_na = allow_na, allow_null = allow_null, arg = arg, call = call ) } check_number_whole <- function(x, ..., min = NULL, max = NULL, allow_infinite = FALSE, allow_na = FALSE, allow_null = FALSE, arg = caller_arg(x), call = caller_env()) { if (missing(x)) { exit_code <- IS_NUMBER_false } else if (0 == (exit_code <- .standalone_types_check_dot_call( ffi_standalone_check_number_1.0.7, x, allow_decimal = FALSE, min, max, allow_infinite, allow_na, allow_null ))) { return(invisible(NULL)) } .stop_not_number( x, ..., exit_code = exit_code, allow_decimal = FALSE, min = min, max = max, allow_na = allow_na, allow_null = allow_null, arg = arg, call = call ) } .stop_not_number <- function(x, ..., exit_code, allow_decimal, min, max, allow_na, allow_null, arg, call) { if (allow_decimal) { what <- "a number" } else { what <- "a whole number" } if (exit_code == IS_NUMBER_oob) { min <- min %||% -Inf max <- max %||% Inf if (min > -Inf && max < Inf) { what <- sprintf("%s between %s and %s", what, min, max) } else if (x < min) { what <- sprintf("%s larger than or equal to %s", what, min) } else if (x > max) { what <- sprintf("%s smaller than or equal to %s", what, max) } else { abort("Unexpected state in OOB check", .internal = TRUE) } } stop_input_type( x, what, ..., allow_na = allow_na, allow_null = allow_null, arg = arg, call = call ) } check_symbol <- function(x, ..., allow_null = FALSE, arg = caller_arg(x), call = caller_env()) { if (!missing(x)) { if (is_symbol(x)) { return(invisible(NULL)) } if (allow_null && is_null(x)) { return(invisible(NULL)) } } stop_input_type( x, "a symbol", ..., allow_na = FALSE, allow_null = allow_null, arg = arg, call = call ) } check_arg <- function(x, ..., allow_null = FALSE, arg = caller_arg(x), call = caller_env()) { if (!missing(x)) { if (is_symbol(x)) { return(invisible(NULL)) } if (allow_null && is_null(x)) { return(invisible(NULL)) } } stop_input_type( x, "an argument name", ..., allow_na = FALSE, allow_null = allow_null, arg = arg, call = call ) } check_call <- function(x, ..., allow_null = FALSE, arg = caller_arg(x), call = caller_env()) { if (!missing(x)) { if (is_call(x)) { return(invisible(NULL)) } if (allow_null && is_null(x)) { return(invisible(NULL)) } } stop_input_type( x, "a defused call", ..., allow_na = FALSE, allow_null = allow_null, arg = arg, call = call ) } check_environment <- function(x, ..., allow_null = FALSE, arg = caller_arg(x), call = caller_env()) { if (!missing(x)) { if (is_environment(x)) { return(invisible(NULL)) } if (allow_null && is_null(x)) { return(invisible(NULL)) } } stop_input_type( x, "an environment", ..., allow_na = FALSE, allow_null = allow_null, arg = arg, call = call ) } check_function <- function(x, ..., allow_null = FALSE, arg = caller_arg(x), call = caller_env()) { if (!missing(x)) { if (is_function(x)) { return(invisible(NULL)) } if (allow_null && is_null(x)) { return(invisible(NULL)) } } stop_input_type( x, "a function", ..., allow_na = FALSE, allow_null = allow_null, arg = arg, call = call ) } check_closure <- function(x, ..., allow_null = FALSE, arg = caller_arg(x), call = caller_env()) { if (!missing(x)) { if (is_closure(x)) { return(invisible(NULL)) } if (allow_null && is_null(x)) { return(invisible(NULL)) } } stop_input_type( x, "an R function", ..., allow_na = FALSE, allow_null = allow_null, arg = arg, call = call ) } check_formula <- function(x, ..., allow_null = FALSE, arg = caller_arg(x), call = caller_env()) { if (!missing(x)) { if (is_formula(x)) { return(invisible(NULL)) } if (allow_null && is_null(x)) { return(invisible(NULL)) } } stop_input_type( x, "a formula", ..., allow_na = FALSE, allow_null = allow_null, arg = arg, call = call ) } # Vectors ----------------------------------------------------------------- # TODO: Figure out what to do with logical `NA` and `allow_na = TRUE` check_character <- function(x, ..., allow_na = TRUE, allow_null = FALSE, arg = caller_arg(x), call = caller_env()) { if (!missing(x)) { if (is_character(x)) { if (!allow_na && any(is.na(x))) { abort( sprintf("`%s` can't contain NA values.", arg), arg = arg, call = call ) } return(invisible(NULL)) } if (allow_null && is_null(x)) { return(invisible(NULL)) } } stop_input_type( x, "a character vector", ..., allow_null = allow_null, arg = arg, call = call ) } check_logical <- function(x, ..., allow_null = FALSE, arg = caller_arg(x), call = caller_env()) { if (!missing(x)) { if (is_logical(x)) { return(invisible(NULL)) } if (allow_null && is_null(x)) { return(invisible(NULL)) } } stop_input_type( x, "a logical vector", ..., allow_na = FALSE, allow_null = allow_null, arg = arg, call = call ) } check_data_frame <- function(x, ..., allow_null = FALSE, arg = caller_arg(x), call = caller_env()) { if (!missing(x)) { if (is.data.frame(x)) { return(invisible(NULL)) } if (allow_null && is_null(x)) { return(invisible(NULL)) } } stop_input_type( x, "a data frame", ..., allow_null = allow_null, arg = arg, call = call ) } # nocov end waldo/R/compare-opts.R0000644000176200001440000000337014662171661014332 0ustar liggesuserscompare_opts <- function(..., tolerance = NULL, max_diffs = if (in_ci()) Inf else 10, ignore_srcref = TRUE, ignore_attr = FALSE, ignore_encoding = TRUE, ignore_function_env = FALSE, ignore_formula_env = FALSE, list_as_map = FALSE, quote_strings = TRUE ) { base <- old_opts(...) seen <- new.env(parent = emptyenv()) seen$envs <- list() waldo <- list( tolerance = tolerance, max_diffs = max_diffs, ignore_srcref = ignore_srcref, ignore_attr = ignore_attr, ignore_encoding = ignore_encoding, ignore_function_env = ignore_function_env, ignore_formula_env = ignore_formula_env, list_as_map = list_as_map, quote_strings = quote_strings, seen = seen ) utils::modifyList(waldo, base) } old_opts <- function(..., tol, check.attributes, checkNames) { out <- list() if (!missing(tol)) { warn("`tol` is deprecated; please use `tolerance` instead") out$tolerance <- tol } if (!missing(check.attributes)) { warn("`check.attributes` is deprecated; please use `ignore_attr` instead") out$ignore_attr <- !check.attributes } if (!missing(checkNames)) { warn("`checkNames` no longer supported; please use `ignore_attr` instead") out$ignore_attr <- !checkNames } if (!missing(...)) { args <- substitute(...()) exprs <- vapply(args, expr_deparse, character(1)) names <- names2(args) exprs <- ifelse(names == "", exprs, paste0(names, " = ", exprs)) warn(paste0("Unused arguments (", paste0(exprs, collapse = ', '), ")")) } out } waldo/R/import-standalone-obj-type.R0000644000176200001440000002113414706167014017102 0ustar liggesusers# Standalone file: do not edit by hand # Source: https://github.com/r-lib/rlang/blob/HEAD/R/standalone-obj-type.R # Generated by: usethis::use_standalone("r-lib/rlang", "obj-type") # ---------------------------------------------------------------------- # # --- # repo: r-lib/rlang # file: standalone-obj-type.R # last-updated: 2024-02-14 # license: https://unlicense.org # imports: rlang (>= 1.1.0) # --- # # ## Changelog # # 2024-02-14: # - `obj_type_friendly()` now works for S7 objects. # # 2023-05-01: # - `obj_type_friendly()` now only displays the first class of S3 objects. # # 2023-03-30: # - `stop_input_type()` now handles `I()` input literally in `arg`. # # 2022-10-04: # - `obj_type_friendly(value = TRUE)` now shows numeric scalars # literally. # - `stop_friendly_type()` now takes `show_value`, passed to # `obj_type_friendly()` as the `value` argument. # # 2022-10-03: # - Added `allow_na` and `allow_null` arguments. # - `NULL` is now backticked. # - Better friendly type for infinities and `NaN`. # # 2022-09-16: # - Unprefixed usage of rlang functions with `rlang::` to # avoid onLoad issues when called from rlang (#1482). # # 2022-08-11: # - Prefixed usage of rlang functions with `rlang::`. # # 2022-06-22: # - `friendly_type_of()` is now `obj_type_friendly()`. # - Added `obj_type_oo()`. # # 2021-12-20: # - Added support for scalar values and empty vectors. # - Added `stop_input_type()` # # 2021-06-30: # - Added support for missing arguments. # # 2021-04-19: # - Added support for matrices and arrays (#141). # - Added documentation. # - Added changelog. # # nocov start #' Return English-friendly type #' @param x Any R object. #' @param value Whether to describe the value of `x`. Special values #' like `NA` or `""` are always described. #' @param length Whether to mention the length of vectors and lists. #' @return A string describing the type. Starts with an indefinite #' article, e.g. "an integer vector". #' @noRd obj_type_friendly <- function(x, value = TRUE) { if (is_missing(x)) { return("absent") } if (is.object(x)) { if (inherits(x, "quosure")) { type <- "quosure" } else { type <- class(x)[[1L]] } return(sprintf("a <%s> object", type)) } if (!is_vector(x)) { return(.rlang_as_friendly_type(typeof(x))) } n_dim <- length(dim(x)) if (!n_dim) { if (!is_list(x) && length(x) == 1) { if (is_na(x)) { return(switch( typeof(x), logical = "`NA`", integer = "an integer `NA`", double = if (is.nan(x)) { "`NaN`" } else { "a numeric `NA`" }, complex = "a complex `NA`", character = "a character `NA`", .rlang_stop_unexpected_typeof(x) )) } show_infinites <- function(x) { if (x > 0) { "`Inf`" } else { "`-Inf`" } } str_encode <- function(x, width = 30, ...) { if (nchar(x) > width) { x <- substr(x, 1, width - 3) x <- paste0(x, "...") } encodeString(x, ...) } if (value) { if (is.numeric(x) && is.infinite(x)) { return(show_infinites(x)) } if (is.numeric(x) || is.complex(x)) { number <- as.character(round(x, 2)) what <- if (is.complex(x)) "the complex number" else "the number" return(paste(what, number)) } return(switch( typeof(x), logical = if (x) "`TRUE`" else "`FALSE`", character = { what <- if (nzchar(x)) "the string" else "the empty string" paste(what, str_encode(x, quote = "\"")) }, raw = paste("the raw value", as.character(x)), .rlang_stop_unexpected_typeof(x) )) } return(switch( typeof(x), logical = "a logical value", integer = "an integer", double = if (is.infinite(x)) show_infinites(x) else "a number", complex = "a complex number", character = if (nzchar(x)) "a string" else "\"\"", raw = "a raw value", .rlang_stop_unexpected_typeof(x) )) } if (length(x) == 0) { return(switch( typeof(x), logical = "an empty logical vector", integer = "an empty integer vector", double = "an empty numeric vector", complex = "an empty complex vector", character = "an empty character vector", raw = "an empty raw vector", list = "an empty list", .rlang_stop_unexpected_typeof(x) )) } } vec_type_friendly(x) } vec_type_friendly <- function(x, length = FALSE) { if (!is_vector(x)) { abort("`x` must be a vector.") } type <- typeof(x) n_dim <- length(dim(x)) add_length <- function(type) { if (length && !n_dim) { paste0(type, sprintf(" of length %s", length(x))) } else { type } } if (type == "list") { if (n_dim < 2) { return(add_length("a list")) } else if (is.data.frame(x)) { return("a data frame") } else if (n_dim == 2) { return("a list matrix") } else { return("a list array") } } type <- switch( type, logical = "a logical %s", integer = "an integer %s", numeric = , double = "a double %s", complex = "a complex %s", character = "a character %s", raw = "a raw %s", type = paste0("a ", type, " %s") ) if (n_dim < 2) { kind <- "vector" } else if (n_dim == 2) { kind <- "matrix" } else { kind <- "array" } out <- sprintf(type, kind) if (n_dim >= 2) { out } else { add_length(out) } } .rlang_as_friendly_type <- function(type) { switch( type, list = "a list", NULL = "`NULL`", environment = "an environment", externalptr = "a pointer", weakref = "a weak reference", S4 = "an S4 object", name = , symbol = "a symbol", language = "a call", pairlist = "a pairlist node", expression = "an expression vector", char = "an internal string", promise = "an internal promise", ... = "an internal dots object", any = "an internal `any` object", bytecode = "an internal bytecode object", primitive = , builtin = , special = "a primitive function", closure = "a function", type ) } .rlang_stop_unexpected_typeof <- function(x, call = caller_env()) { abort( sprintf("Unexpected type <%s>.", typeof(x)), call = call ) } #' Return OO type #' @param x Any R object. #' @return One of `"bare"` (for non-OO objects), `"S3"`, `"S4"`, #' `"R6"`, or `"S7"`. #' @noRd obj_type_oo <- function(x) { if (!is.object(x)) { return("bare") } class <- inherits(x, c("R6", "S7_object"), which = TRUE) if (class[[1]]) { "R6" } else if (class[[2]]) { "S7" } else if (isS4(x)) { "S4" } else { "S3" } } #' @param x The object type which does not conform to `what`. Its #' `obj_type_friendly()` is taken and mentioned in the error message. #' @param what The friendly expected type as a string. Can be a #' character vector of expected types, in which case the error #' message mentions all of them in an "or" enumeration. #' @param show_value Passed to `value` argument of `obj_type_friendly()`. #' @param ... Arguments passed to [abort()]. #' @inheritParams args_error_context #' @noRd stop_input_type <- function(x, what, ..., allow_na = FALSE, allow_null = FALSE, show_value = TRUE, arg = caller_arg(x), call = caller_env()) { # From standalone-cli.R cli <- env_get_list( nms = c("format_arg", "format_code"), last = topenv(), default = function(x) sprintf("`%s`", x), inherit = TRUE ) if (allow_na) { what <- c(what, cli$format_code("NA")) } if (allow_null) { what <- c(what, cli$format_code("NULL")) } if (length(what)) { what <- oxford_comma(what) } if (inherits(arg, "AsIs")) { format_arg <- identity } else { format_arg <- cli$format_arg } message <- sprintf( "%s must be %s, not %s.", format_arg(arg), what, obj_type_friendly(x, value = show_value) ) abort(message, ..., call = call, arg = arg) } oxford_comma <- function(chr, sep = ", ", final = "or") { n <- length(chr) if (n < 2) { return(chr) } head <- chr[seq_len(n - 1)] last <- chr[n] head <- paste(head, collapse = sep) # Write a or b. But a, b, or c. if (n > 2) { paste0(head, sep, final, " ", last) } else { paste0(head, " ", final, " ", last) } } # nocov end waldo/R/proxy.R0000644000176200001440000000521414416245252013074 0ustar liggesusers#' Proxy for waldo comparison #' #' @description #' Use this generic to override waldo's default comparison if you need to #' override the defaults (typically because your object stores data in an #' external pointer). #' #' waldo comes with methods for a few common cases: #' #' * data.table: the `.internal.selfref` and `index` attributes #' are set to `NULL`. Both attributes are used for performance optimisation, and #' don't affect the data. #' #' * `xml2::xml_node`: the underlying XML data is stored in memory in C, #' behind an external pointer, so the we best can do is to convert the #' object to a string. #' #' * Classes from the `RProtoBuf` package: like XML objects, these store #' data in memory in C++ and only expose string names to R. Fortunately, #' these have well-understood string representations that we can use for #' comparisons. See #' #' #' @param x An object. #' @param path Path #' @return A list with two components: #' * `object`: the modified object #' * `path`: an updated path showing what modification was applied #' @export compare_proxy <- function(x, path = "x") { if (typeof(x) == "char") { return(list(object = x, path = path)) } UseMethod("compare_proxy") } #' @export compare_proxy.default <- function(x, path) { list(object = x, path = path) } #' @export compare_proxy.data.table <- function(x, path) { attr(x, ".internal.selfref") <- NULL attr(x, "index") <- NULL list(object = x, path = path) } #' @export compare_proxy.xml_node <- function(x, path) { list(object = as.character(x), path = paste0("as.character(", path, ")")) } #' @export compare_proxy.POSIXlt <- function(x, path) { # From R 4.3: More experimentally, a ‘"POSIXlt"’ object may have an attribute # ‘"balanced"’ indicating if it is known to be filled or fully balanced. # This is a performance optimisation that waldo can ignore. attr(x, "balanced") <- NULL list(object = x, path = path) } # RProtoBuf objects ------------------------------------------------------- compare_protobuf <- function(x, path) { list(object = x$toString(), path = paste0(path, "$toString()")) } #' @export compare_proxy.Message <- compare_protobuf #' @export compare_proxy.Descriptor <- compare_protobuf #' @export compare_proxy.EnumDescriptor <- compare_protobuf #' @export compare_proxy.FieldDescriptor <- compare_protobuf #' @export compare_proxy.ServiceDescriptor <- compare_protobuf #' @export compare_proxy.FileDescriptor <- compare_protobuf #' @export compare_proxy.EnumValueDescriptor <- compare_protobuf #' @export compare_proxy.MethodDescriptor <- compare_protobuf waldo/R/compare-value.R0000644000176200001440000001060714706167014014456 0ustar liggesuserscompare_vector <- function(x, y, paths = c("x", "y"), opts = compare_opts()) { # Early exit for numerics (except for) with format methods if (is_numeric(x) && num_equal(x, y, opts$tolerance)) { return() } if (!isTRUE(opts$ignore_attr) && is.object(x) && has_format_method(x)) { x_str <- format(x) y_str <- format(y) out <- compare_character(x_str, y_str, paths, max_diffs = opts$max_diffs) paths <- paste0("unclass(", paths, ")") } else { out <- character() } if (length(out) == 0) { out <- c(out, switch(typeof(x), integer = , double = compare_numeric(x, y, paths, tolerance = opts$tolerance, max_diffs = opts$max_diffs ), complex = compare_complex(x, y, paths, tolerance = opts$tolerance, max_diffs = opts$max_diffs ), logical = compare_logical(x, y, paths, max_diffs = opts$max_diffs), raw = , character = compare_character(x, y, paths, quote = if (opts$quote_strings) '"' else NULL, max_diffs = opts$max_diffs) )) } out } has_format_method <- function(x) { for (class in class(x)) { if (!is.null(utils::getS3method("format", class, optional = TRUE))) { return(TRUE) } } FALSE } compare_logical <- function(x, y, paths = c("x", "y"), max_diffs = Inf) { diff_element( encodeString(x), encodeString(y), paths, quote = NULL, max_diffs = max_diffs ) } compare_character <- function(x, y, paths = c("x", "y"), quote = "\"", max_diffs = Inf) { if (multiline(x) || multiline(y)) { x <- split_by_line(x) y <- split_by_line(y) opts <- compare_opts(max_diffs = max_diffs) if (length(x) == 1 && length(y) == 1) { new_compare(compare_by_line1(x, y, paths, opts)) } else { new_compare(compare_by_line(x, y, paths, opts)) } } else { diff_element( x, y, paths, quote = quote, max_diffs = max_diffs, is_string = TRUE ) } } compare_numeric <- function(x, y, paths = c("x", "y"), tolerance = default_tol(), max_diffs = Inf) { if (num_equal(x, y, tolerance)) { return(new_compare()) } if (length(dim(x)) == 2 && identical(dim(x), dim(y))) { rows <- printed_rows(x, y, paths = paths) out <- diff_rows(rows, paths = paths, max_diffs = max_diffs) if (length(out) > 0) { return(out) } } if (length(x) == length(y)) { digits <- min_digits(x, y, tolerance) x_fmt <- num_exact(x, digits = digits) y_fmt <- num_exact(y, digits = digits) } else { # Not align, so need to find max number of digits x_fmt <- as.character(x) y_fmt <- as.character(y) } out <- diff_element( x_fmt, y_fmt, paths, quote = NULL, justify = "right", max_diffs = max_diffs ) if (length(out) > 0) { out } else { glue::glue("{paths[[1]]} != {paths[[2]]} but don't know how to show the difference") } } compare_complex <- function(x, y, paths = c("x", "y"), tolerance = default_tol(), max_diffs = Inf) { if (length(x) == length(y)) { c( compare_numeric( Re(x), Re(y), paths = paste0("Re(", paths, ")"), tolerance = tolerance, max_diffs = max_diffs ), compare_numeric( Im(x), Im(y), paths = paste0("Im(", paths, ")"), tolerance = tolerance, max_diffs = max_diffs ) ) } else { x_fmt <- format(x) y_fmt <- format(y) diff_element( x_fmt, y_fmt, paths, quote = NULL, justify = "right", max_diffs = max_diffs ) } } # Helpers ----------------------------------------------------------------- num_exact <- function(x, digits = 6) { sprintf(paste0("%0.", digits, "f"), x) } # Minimal number of digits needed to show differences min_digits <- function(x, y, tolerance = default_tol()) { 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 } # This looks ok: # grid <- 10 ^ seq(0, -6, length.out = 1e3) # plot(grid, sapply(grid, digits), log = "x") digits <- function(x) { x <- x[!is.na(x) & x != 0] if (length(x) == 0) { return(0) } scale <- -log10(min(x)) if (scale <= 0) { # Don't add digits if x > 1 0L } else { # Need to first round roughly to avoid tiny FP differences ceiling(round(scale, digits = 2)) } } waldo/R/utils.R0000644000176200001440000000777514706232442013070 0ustar liggesusersoo_type <- function(x) { if (isS4(x)) { "S4" } else if (is.object(x)) { if (inherits(x, "S7_object")) { "S7" } else if (inherits(x, "R6")) { "R6" } else { "S3" } } else { "base" } } friendly_type_of <- function(x) { if (is_missing(x)) { return("absent") } if (!is.object(x) && !isS4(x)) { return(friendly_type(typeof(x))) } if (!isS4(x)) { if (inherits(x, "S7_object")) { paste0("an S7 object of class <", class(x)[[1]], ">") } else if (inherits(x, "R6")) { klass <- paste(setdiff(class(x), "R6"), collapse = "/") paste0("an R6 object of class <", klass, ">") } else { paste0( "an S3 object of class <", paste(class(x), collapse = "/"), ">, ", friendly_type(typeof(x)) ) } } else { paste0("an S4 object of class <", class(x), ">") } } friendly_type <- function(type) { switch(type, logical = "a logical vector", integer = "an integer vector", numeric = , double = "a double vector", complex = "a complex vector", character = "a character vector", raw = "a raw vector", string = "a string", list = "a list", NULL = "NULL", environment = "an environment", externalptr = "a pointer", weakref = "a weak reference", S4 = "an S4 object", name = , symbol = "a symbol", language = "a call", pairlist = "a pairlist node", expression = "an expression vector", quosure = "a quosure", formula = "a formula", char = "an internal string", promise = "an internal promise", ... = "an internal dots object", any = "an internal `any` object", bytecode = "an internal bytecode object", primitive = , builtin = , special = "a primitive function", closure = "a function", type ) } short_val <- function(x) { if (is.object(x) || !is_atomic(x)) { return("") } if (is.character(x)) { x <- encodeString(x, quote = "'") } if (length(x) > 5) { x <- c(x[1:5], "...") } paste0(" (", paste0(x, collapse = ", "), ")") } attrs <- function(x, ignore) { out <- attributes(x) names <- setdiff(names2(out), ignore) first <- intersect(c("class", "names", "dim"), names) rest <- sort(setdiff(names, first)) out[c(first, rest)] } compare_as_numeric <- function(x, y, tol) { !is.null(tol) && is_numeric(x) && is_numeric(y) } is_numeric <- function(x) { is_integer(x) || is_double(x) || is_int64(x) } is_int64 <- function(x) { inherits(x, "integer64") } in_ci <- function() { isTRUE(as.logical(Sys.getenv("CI", "FALSE"))) } if (getRversion() < "3.3.0") { strrep <- function(x, times) { vapply( times, function(n) paste(rep(x, n), collapse = ""), FUN.VALUE = character(1) ) } } ansi_align <- function(x, width = NULL, justify = c("left", "right")) { justify <- arg_match(justify) nchar <- cli::ansi_nchar(x) width <- width %||% max(nchar) padding <- strrep(" ", pmax(0, width - nchar)) switch(justify, left = paste0(x, padding), right = paste0(padding, x) ) } split_by_line <- function(x) { trailing_nl <- grepl("\n$", x) x <- strsplit(x, "\n") x[trailing_nl] <- lapply(x[trailing_nl], c, "") x } multiline <- function(x) any(grepl("\n", x)) default_tol <- function() .Machine$double.eps^0.5 merge_lists <- function(...) { all <- compact(list(...)) Reduce(utils::modifyList, all, init = list()) } compact <- function(x) { is_null <- vapply(x, is.null, logical(1)) x[!is_null] } as_map <- function(x) { attr <- attributes(x) # Remove nulls x <- compact(x) # Sort named components, preserving positions of unnamed nx <- names2(x) is_named <- nx != "" if (any(is_named)) { idx <- seq_along(x) idx[is_named] <- idx[is_named][order(nx[is_named])] x <- x[idx] } # Restore attributes (which might have been lost by [) new_attr <- attributes(x) attr[names(new_attr)] <- new_attr attributes(x) <- attr x } scrub_environment <- function(x) { gsub("", "", x) } waldo/R/num_equal.R0000644000176200001440000000245414713143542013703 0ustar liggesusersnum_equal <- function(x, y, tolerance = default_tol()) { if (length(x) != length(y)) { return(FALSE) } if (any(is.na(x) != is.na(y))) { return(FALSE) } if (is.null(tolerance) && any(is.nan(x) != is.nan(y))) { return(FALSE) } if ((is_int64(x) || is_int64(y)) && is_installed("bit64")) { if (can_int64(x) && can_int64(y)) { x <- bit64::as.integer64(x) y <- bit64::as.integer64(y) } else { cli::cli_abort(c( "No way to coerce to compatible numeric type.", i = "Try again without setting `tolerance`." )) } } else { attributes(x) <- NULL attributes(y) <- NULL } same <- is.na(x) | x == y if (is.null(tolerance)) { return(all(same)) } else if (all(same)) { return(TRUE) } x_diff <- x[!same] y_diff <- y[!same] avg_diff <- mean(abs(x_diff - y_diff)) avg_y <- mean(abs(y_diff)) # compute relative difference when y is "large" but finite if (is.finite(avg_y) && avg_y > tolerance) { avg_diff <- avg_diff / avg_y } avg_diff < tolerance } can_int64 <- function(x) { if (is.integer(x) || inherits(x, "integer64")) { return(TRUE) } # https://yutani.rbind.io/post/savvy-v0.7.1-usize/ in_range <- x >= -2^53 & x <= 2^53 is_whole <- trunc(x) == x all(in_range, is_whole, na.rm = TRUE) } waldo/R/compare-data-frame.R0000644000176200001440000000545014415110067015334 0ustar liggesuserscompare_data_frame <- function(x, y, paths = c("x", "y"), opts = compare_opts()) { # Only show row diffs if columns are atomic, have same names and types and there are rows if (!all_atomic(x) || !all_atomic(y)) { return() } if (!same_cols(x, y)) { return() } if (nrow(x) == 0 || nrow(y) == 0) { return() } rows <- df_rows(x, y, paths = paths, tolerance = opts$tolerance) if (is.null(rows)) { return() } diff_rows(rows, paths = paths, max_diffs = opts$max_diffs) } diff_rows <- function(rows, paths = c("x", "y"), max_diffs = 10) { diffs <- ses_shortest(rows$x, rows$y) if (length(diffs) == 0) { return(new_compare()) } # Align with diffs header <- paste0(" ", names(rows$header), cli::style_bold(rows$header)) format <- lapply(diffs, function(diff) { path_label <- paste0(paths[[1]], " vs ", paths[[2]]) lines <- line_by_line(rows$x, rows$y, diff, max_diffs = max_diffs) paste0(c(path_label, header, lines), collapse = "\n") }) new_compare(unlist(format, recursive = FALSE)) } # Make a character matrix of formatted cell values df_rows <- function(x, y, paths = c("x", "y"), tolerance = NULL) { # If same length, drop identical columns if (nrow(x) == nrow(y)) { is_equal <- function(x, y) { if (is_numeric(x)) { num_equal(x, y, tolerance = tolerance) } else { identical(x, y) } } same <- vapply(seq_along(x), function(j) is_equal(x[[j]], y[[j]]), logical(1)) x <- x[!same] y <- y[!same] } if (ncol(x) == 0) { return() } printed_rows(x, y, paths = paths) } printed_rows <- function(x, y, paths = c("x", "y")) { joint <- rbind(x, y) if (!is.data.frame(joint)) { # i.e is a matrix joint <- as.data.frame(joint) names(joint) <- paste0("[,", format(seq_along(joint)), "]") } # A speedier implementation of print.data.frame cols <- lapply(joint, format) for (i in seq_along(cols)) { cols[[i]] <- format(c(names(joint)[[i]], cols[[i]]), justify = "right") } lines <- do.call(paste, cols) row_idx <- c(seq_len(nrow(x)), seq_len(nrow(y))) row_idx <- paste0(rep(paths, c(nrow(x), nrow(y))), "[", row_idx, ", ] ") names(lines) <- format(c("", row_idx), align = "right") list( header = lines[1], x = lines[2:(nrow(x) + 1)], y = lines[(nrow(x) + 2):length(lines)] ) } same_cols <- function(x, y) { if (!identical(names(x), names(y))) { return(FALSE) } for (j in seq_along(x)) { if (!is.numeric(x[[j]]) || !is.numeric(y[[j]])) { if (!identical(typeof(x[[j]]), typeof(y[[j]]))) { return(FALSE) } } if (!identical(attributes(x[[j]]), attributes(y[[j]]))) { return(FALSE) } } TRUE } unrowname <- function(x) { row.names(x) <- NULL x } all_atomic <- function(x) { all(vapply(x, is_atomic, logical(1))) } waldo/R/ses.R0000644000176200001440000000762114705465170012515 0ustar liggesusers# # # * `lar`: Add the lines in range `r` of the second file # after line `l` of the first file. # * `fct`: Replace the lines in range `f` of the first file # with lines in range `t` of the second file. # * `rdl`: Delete the lines in range `r` from the first file; line `l` is # where they would have appeared in the second file had they not been deleted. ses <- function(x, y) { attributes(x) <- NULL attributes(y) <- NULL if (is.character(x)) { x <- enc2utf8(x) y <- enc2utf8(y) } out <- diffobj::ses(x, y, warn = FALSE, max.diffs = 100) out <- re_match(out, paste0( "(?:(?\\d+),)?(?\\d+)", "(?[acd])", "(?:(?\\d+),)?(?\\d+)" ))[1:5] out$x1 <- ifelse(out$x1 == "", out$x2, out$x1) out$y1 <- ifelse(out$y1 == "", out$y2, out$y1) out$x1 <- as.integer(out$x1) out$x2 <- as.integer(out$x2) out$y1 <- as.integer(out$y1) out$y2 <- as.integer(out$y2) out } ses_elementwise <- function(x, y) { n_x <- length(x) n_y <- length(y) n <- min(n_x, n_y) id <- seq_len(n) same <- (is.na(x[id]) & is.na(y[id])) | x[id] == y[id] same[is.na(same)] <- FALSE neq <- id[!same] if (length(neq) == 0) { n_x <- length(x) n_y <- length(y) if (length(x) > length(y)) { return(ses_df(n_y + 1, n_x, "d", n_y, n_y)) } else if (length(x) < length(y)) { return(ses_df(n_x, n_x, "a", n_x + 1, n_y)) } else { return(ses_df(integer(), integer(), character(), integer(), integer())) } } new_group <- c(TRUE, neq[-1] - 1 != neq[-length(neq)]) group_id <- cumsum(new_group) diffs <- unname(split(neq, group_id)) x1 <- y1 <- vapply(diffs, function(x) x[[1]], integer(1)) x2 <- y2 <- vapply(diffs, function(x) x[[length(x)]], integer(1)) t <- rep("c", length(diffs)) if (length(y) > length(x)) { y2[[length(diffs)]] <- n_y } else if (length(x) > length(y)) { x2[[length(diffs)]] <- n_x } ses_df(x1, x2, t, y1, y2) } ses_shortest <- function(x, y, size = 3) { ses1 <- ses(x, y) if (nrow(ses1) == 0) { return(list()) } ses2 <- ses_elementwise(x, y) context1 <- ses_chunks(ses1, length(x), length(y), size = size) context2 <- ses_chunks(ses2, length(x), length(y), size = size) diff_length <- function(ses) ses$x2[nrow(ses)] - ses$x1[[1]] + 1 diff1 <- sum(vapply(context1, diff_length, double(1)), na.rm = TRUE) diff2 <- sum(vapply(context2, diff_length, double(1))) if (diff1 == diff2) { # If contextual diffs are same length, break tie using total # number of changes if (diff_length(ses1) < diff_length(ses2)) { context1 } else { context2 } } else if (diff1 < diff2) { context1 } else { context2 } } ses_chunks <- function(diff, n_x, n_y, size = 3) { # Compute context around each individual diff diff$x_start <- pmax(diff$x1 - size, 1) diff$x_end <- pmin(diff$x2 + size, n_x) diff$y_start <- pmax(diff$y1 - size, 1) diff$y_end <- pmin(diff$y2 + size, n_y) # Split up into non-contiguous chunks new_group <- c(TRUE, diff$x_start[-1] > diff$x_end[-nrow(diff)]) group_id <- cumsum(new_group) diffs <- unname(split(diff, group_id)) # Fill in rows that are the same in x and y lapply(diffs, diff_complete) } diff_complete <- function(diff) { n <- nrow(diff) diff$pos <- 1:n ctxt <- data.frame( pos = 1:(n + 1) - 0.5, x1 = c(diff$x_start[[1]], diff$x2 + 1), x2 = c(diff$x1 - 1, diff$x_end[[n]]), t = "x", y1 = c(diff$y_start[[1]], diff$y2 + 1), y2 = c(diff$y1 - 1, diff$y_end[[n]]) ) out <- rbind(diff[names(ctxt)], ctxt) # Interleave in correct order out <- out[order(out$pos), , drop = FALSE] out$pos <- NULL # Drop rows with no data needed <- (out$x2 - out$x1) >= 0 | (out$y2 - out$y1) >= 0 out[needed, , drop = FALSE] } ses_df <- function(x1, x2, t, y1, y2) { data.frame(x1 = x1, x2 = x2, t = t, y1 = y1, y2 = y2) } waldo/R/waldo-package.R0000644000176200001440000000041314705465170014412 0ustar liggesusers#' @keywords internal #' @import rlang "_PACKAGE" # The following block is used by usethis to automatically manage # roxygen namespace tags. Modify with care! ## usethis namespace: start ## usethis namespace: end NULL release_extra_revdeps <- function() "testthat" waldo/R/compare.R0000644000176200001440000004432114706207534013346 0ustar liggesusers#' Compare two objects #' #' @description #' This compares two R objects, identifying the key differences. It: #' #' * Orders the differences from most important to least important. #' * Displays the values of atomic vectors that are actually different. #' * Carefully uses colour to emphasise changes (while still being readable #' when colour isn't available). #' * Uses R code (not a text description) to show where differences arise. #' * Where possible, it compares elements by name, rather than by position. #' * Errs on the side of producing too much output, rather than too little. #' #' `compare()` is an alternative to [all.equal()]. #' #' @section Controlling comparisons: #' #' There are two ways for an object (rather than the person calling `compare()` #' or `expect_equal()` to control how it is compared to other objects. #' First, if the object has an S3 class, you can provide a [compare_proxy()] #' method that provides an alternative representation of the object; this is #' particularly useful if important data is stored outside of R, e.g. in #' an external pointer. #' #' Alternatively, you can attach an attribute called `"waldo_opts"` to your #' object. This should be a list of compare options, using the same names #' and possible values as the arguments to this function. This option #' is ignored by default (`ignore_attr`) so that you can set the options in #' the object that you control. (If you don't want to see the attributes #' interactively, you could attach them in a [compare_proxy()] method.) #' #' Options supplied in this way also affect all the children. This means #' options are applied in the following order, from lowest to highest #' precedence: #' #' 1. Defaults from `compare()`. #' 1. The `waldo_opts` for the parents of `x`. #' 1. The `waldo_opts` for the parents of `y`. #' 1. The `waldo_opts` for `x`. #' 1. The `waldo_opts` for `y`. #' 1. User-specified arguments to `compare()`. #' #' Use these techniques with care. If you accidentally cover up an important #' difference you can create a confusing situation where `x` and `y` behave #' differently but `compare()` reports no differences in the underlying objects. #' #' @param x,y Objects to compare. `x` is treated as the reference object #' so messages describe how `y` is different to `x`. #' @param x_arg,y_arg Name of `x` and `y` arguments, used when generated paths #' to internal components. These default to "old" and "new" since it's #' most natural to supply the previous value then the new value. #' @param ... A handful of other arguments are supported with a warning for #' backward comparability. These include: #' #' * `all.equal()` arguments `checkNames` and `check.attributes` #' * `testthat::compare()` argument `tol` #' #' All other arguments are ignored with a warning. #' @param tolerance If non-`NULL`, used as threshold for ignoring small #' floating point difference when comparing numeric vectors. Using any #' non-`NULL` value will cause integer and double vectors to be compared #' based on their values, not their types, and will ignore the difference #' between `NaN` and `NA_real_`. #' #' It uses the same algorithm as [all.equal()], i.e., first we generate #' `x_diff` and `y_diff` by subsetting `x` and `y` to look only locations #' with differences. Then we check that #' `mean(abs(x_diff - y_diff)) / mean(abs(y_diff))` (or just #' `mean(abs(x_diff - y_diff))` if `y_diff` is small) is less than #' `tolerance`. #' @param max_diffs Control the maximum number of differences shown. The #' default shows 10 differences when run interactively and all differences #' when run in CI. Set `max_diffs = Inf` to see all differences. #' @param ignore_srcref Ignore differences in function `srcref`s? `TRUE` by #' default since the `srcref` does not change the behaviour of a function, #' only its printed representation. #' @param ignore_attr Ignore differences in specified attributes? #' Supply a character vector to ignore differences in named attributes. #' By default the `"waldo_opts"` attribute is listed in `ignore_attr` so #' that changes to it are not reported; if you customize `ignore_attr`, you #' will probably want to do this yourself. #' #' For backward compatibility with `all.equal()`, you can also use `TRUE`, #' to all ignore differences in all attributes. This is not generally #' recommended as it is a blunt tool that will ignore many important #' functional differences. #' @param ignore_function_env,ignore_formula_env Ignore the environments of #' functions and formulas, respectively? These are provided primarily for #' backward compatibility with `all.equal()` which always ignores these #' environments. #' @param ignore_encoding Ignore string encoding? `TRUE` by default, because #' this is R's default behaviour. Use `FALSE` when specifically concerned #' with the encoding, not just the value of the string. #' @param list_as_map Compare lists as if they are mappings between names and #' values. Concretely, this drops `NULL`s in both objects and sorts named #' components. #' @param quote_strings Should strings be surrounded by quotes? If `FALSE`, #' only side-by-side and line-by-line comparisons will be used, and there's #' no way to distinguish between `NA` and `"NA"`. #' @returns A character vector with class "waldo_compare". If there are no #' differences it will have length 0; otherwise each element contains the #' description of a single difference. #' @export #' @examples #' # Thanks to diffobj package comparison of atomic vectors shows differences #' # with a little context #' compare(letters, c("z", letters[-26])) #' compare(c(1, 2, 3), c(1, 3)) #' compare(c(1, 2, 3), c(1, 3, 4, 5)) #' compare(c(1, 2, 3), c(1, 2, 5)) #' #' # More complex objects are traversed, stopping only when the types are #' # different #' compare( #' list(x = list(y = list(structure(1, z = 2)))), #' list(x = list(y = list(structure(1, z = "a")))) #' ) #' #' # Where possible, recursive structures are compared by name #' compare(iris, rev(iris)) #' #' compare(list(x = "x", y = "y"), list(y = "y", x = "x")) #' # Otherwise they're compared by position #' compare(list("x", "y"), list("x", "z")) #' compare(list(x = "x", x = "y"), list(x = "x", y = "z")) #' compare <- function(x, y, ..., x_arg = "old", y_arg = "new", tolerance = NULL, max_diffs = if (in_ci()) Inf else 10, ignore_srcref = TRUE, ignore_attr = "waldo_opts", ignore_encoding = TRUE, ignore_function_env = FALSE, ignore_formula_env = FALSE, list_as_map = FALSE, quote_strings = TRUE ) { check_string(x_arg) check_string(y_arg) check_number_decimal(tolerance, allow_null = TRUE, min = 0) check_number_whole(max_diffs, min = 1, allow_infinite = TRUE) check_bool(ignore_srcref) if (!isTRUE(ignore_attr) && !isFALSE(ignore_attr) && !is.character(ignore_attr)) { stop_input_type(ignore_attr, "a TRUE, a FALSE, or a character vector") } check_bool(ignore_encoding) check_bool(ignore_function_env) check_bool(ignore_formula_env) check_bool(list_as_map) check_bool(quote_strings) opts <- compare_opts( ..., tolerance = tolerance, max_diffs = max_diffs, ignore_srcref = ignore_srcref, ignore_attr = ignore_attr, ignore_encoding = ignore_encoding, ignore_formula_env = ignore_formula_env, ignore_function_env = ignore_function_env, list_as_map = list_as_map, quote_strings = quote_strings ) # Record options overridden by user opts$user_specified <- intersect(names(opts), names(match.call())) out <- compare_structure(x, y, paths = c(x_arg, y_arg), opts = opts) new_compare(out, max_diffs) } compare_structure <- function(x, y, paths = c("x", "y"), opts = compare_opts()) { if (!is_missing(x)) { proxy <- compare_proxy(x, paths[[1]]) x <- proxy$object paths[[1]] <- proxy$path } if (!is_missing(y)) { proxy <- compare_proxy(y, paths[[2]]) y <- proxy$object paths[[2]] <- proxy$path } opts <- merge_lists(opts, attr(x, "waldo_opts"), attr(y, "waldo_opts"), opts[opts$user_specified] ) if (is_identical(x, y, opts)) { return(character()) } # Compare type term <- compare_terminate(x, y, paths, tolerance = opts$tolerance, ignore_attr = opts$ignore_attr ) if (length(term) > 0) { return(term) } if (is_list(x) && opts$list_as_map) { x <- as_map(x) y <- as_map(y) } out <- character() # Then length if ((is_list(x) || is_pairlist(x)) && length(x) != length(y)) { out <- c(out, should_be("length {length(x)}", "length {length(y)}")) } # Then attributes/slots if (isS4(x)) { out <- c(out, compare_character(is(x), is(y), glue::glue("is({paths})"))) out <- c(out, compare_by_slot(x, y, paths, opts)) # S4 objects can have attributes that are not slots out <- c(out, compare_by_attr( attrs(x, c(slotNames(x), "class")), attrs(y, c(slotNames(y), "class")), paths, opts) ) } else if (is.object(x) && inherits(x, "S7_object")) { out <- c(out, compare_character(class(x), class(y), glue::glue("class({paths})"))) out <- c(out, compare_by_prop(x, y, paths, opts)) # S7 objects can have attributes that are not slots out <- c(out, compare_by_attr( attrs(x, c(S7::prop_names(x), "class", "S7_class")), attrs(y, c(S7::prop_names(y), "class", "S7_class")), paths, opts) ) } else if (!isTRUE(opts$ignore_attr)) { if (is_call(x) && opts$ignore_formula_env) { attr(x, ".Environment") <- NULL attr(y, ".Environment") <- NULL } if ((is_closure(x) || is_call(x)) && opts$ignore_srcref) { x <- zap_srcref(x) y <- zap_srcref(y) } if (compare_as_numeric(x, y, opts$tolerance)) { opts$ignore_attr <- union(opts$ignore_attr, "class") } out <- c(out, compare_by_attr(attrs(x, opts$ignore_attr), attrs(y, opts$ignore_attr), paths, opts)) } # Then contents if (is_list(x) || is_pairlist(x) || is.expression(x)) { if (is.data.frame(x) && is.data.frame(y)) { out <- c(out, compare_data_frame(x, y, paths, opts = opts)) } x <- unclass(x) y <- unclass(y) ignore_names <- isTRUE(opts$ignore_attr) || "names" %in% opts$ignore_attr if (!ignore_names && is_dictionaryish(x) && is_dictionaryish(y)) { out <- c(out, compare_by_name(x, y, paths, opts)) } else { out <- c(out, compare_by_pos(x, y, paths, opts)) } } else if (is_environment(x)) { if (is_seen(list(x, y), opts$seen$envs)) { # Only report difference between pairs of environments once return(out) } else if (is_named_env(x) || is_named_env(y)) { # Compare by reference out <- c(out, should_be("", "")) } else { # Compare by value x_fields <- as.list.environment(x, all.names = TRUE) y_fields <- as.list.environment(y, all.names = TRUE) # Can't use as.list(sorted = TRUE), https://github.com/r-lib/waldo/issues/84 if (length(x_fields) > 0) x_fields <- x_fields[order(names(x_fields))] if (length(y_fields) > 0) y_fields <- y_fields[order(names(y_fields))] if (env_has(x, ".__enclos_env__")) { # enclosing env of R6 methods is object env opts$ignore_function_env <- TRUE x_fields$.__enclos_env__ <- NULL y_fields$.__enclos_env__ <- NULL } opts$seen$envs <- c(opts$seen$envs, list(list(x, y))) out <- c(out, compare_structure(x_fields, y_fields, paths, opts = opts)) out <- c(out, compare_structure( parent.env(x), parent.env(y), paste0("parent.env(", paths, ")"), opts = opts) ) } } else if (is_closure(x)) { if (opts$ignore_function_env) { environment(x) <- emptyenv() environment(y) <- emptyenv() } out <- c(out, compare_by_fun(x, y, paths, opts)) } else if (is_primitive(x)) { out <- c(out, should_be("`{deparse(x)}`", "`{deparse(y)}`")) } else if (is_symbol(x)) { out <- c(out, should_be("`{deparse(x)}`", "`{deparse(y)}`")) } else if (is_call(x)) { attributes(x) <- NULL attributes(y) <- NULL if (!identical(x, y)) { diff <- compare_character( deparse(x), deparse(y), paths, quote = "`", max_diffs = opts$max_diffs ) if (length(diff) == 0) { # Fallback if deparse equal but AST different diff <- compare_structure(as.list(x), as.list(y), paths, opts = opts) } out <- c(out, diff) } } else if (is_atomic(x)) { if (is_character(x) && !opts$ignore_encoding) { out <- c(out, compare_character( Encoding(x), Encoding(y), glue::glue("Encoding({paths})"), max_diffs = opts$max_diffs )) } out <- c(out, compare_vector(x, y, paths = paths, opts = opts)) } else if (typeof(x) == "externalptr") { x <- utils::capture.output(print(x)) y <- utils::capture.output(print(y)) out <- c(out, should_be("{x}", "{y}")) } else if (typeof(x) == "char") { x <- paste0("CHARSXP: ", deparse(x)) y <- paste0("CHARSXP: ", deparse(y)) out <- c(out, should_be("{x}", "{y}")) } else if (typeof(x) == "...") { # Unevaluated dots are unlikely to lead to any significant differences # in behaviour (they're usually captured incidentally) so we just # ignore } else if (!typeof(x) %in% c("S4", "object")) { abort(glue::glue("{paths[[1]]}: unsupported type '{typeof(x)}'"), call = NULL) } out } is_named_env <- function(x) { environmentName(x) != "" } is_seen <- function(x, envs) { for (env in envs) { if (identical(x, env)) { return(TRUE) } } FALSE } # Fast path for "identical" elements - in the long run we'd eliminate this # by re-writing all of waldo in C, but this gives us a nice performance boost # with for a relatively low cost in the meantime. is_identical <- function(x, y, opts) { # These comparisons aren't 100% correct because they don't affect comparison # of character vectors/functions further down the tree. But I think that's # unlikely to have an impact in practice since they're opt-in. if (is_character(x) && is_character(y) && !opts$ignore_encoding) { identical(x, y) && identical(Encoding(x), Encoding(y)) } else if (is_function(x) && is_function(y) && !opts$ignore_srcref) { identical(x, y) && identical(attr(x, "srcref"), attr(y, "srcref")) } else { identical(x, y) } } compare_terminate <- function(x, y, paths, tolerance = NULL, ignore_attr = FALSE) { type_x <- friendly_type_of(x) type_y <- friendly_type_of(y) if (is_missing(x) && !is_missing(y)) { type_y <- col_d(type_y) } else if (!is_missing(x) && is_missing(y)) { type_x <- col_a(type_x) } else { type_x <- col_c(type_x) type_y <- col_c(type_y) } type_mismatch_msg <- should_be("{type_x}{short_val(x)}", "{type_y}{short_val(y)}") # missing needs to be treated here because `typeof(missing_arg())` is symbol if (is_missing(x) != is_missing(y)) { return(type_mismatch_msg) } if (typeof(x) == typeof(y) && oo_type(x) == oo_type(y)) { return(character()) } ignore_class <- isTRUE(ignore_attr) || "class" %in% ignore_attr if (ignore_class && (typeof(x) == typeof(y))) { return(character()) } if (compare_as_numeric(x, y, tolerance)) { return(character()) } # don't care about difference between builtin and special if (is_primitive(x) && is_primitive(y)) { return(should_be("`{deparse(x)}`", "`{deparse(y)}`")) } type_mismatch_msg } should_be <- function(x, y) { string <- paste0( "`{paths[[1]]}` is ", x, "\n", "`{paths[[2]]}` is ", y ) glue::glue(string, .envir = caller_env(), .trim = FALSE) } # compare_each ------------------------------------------------------------ compare_by <- function(index_fun, extract_fun, path_fun) { function(x, y, paths, opts) { idx <- index_fun(x, y) if (length(idx) == 0) return(character()) x_paths <- path_fun(paths[[1]], idx) y_paths <- path_fun(paths[[2]], idx) out <- character() for (i in seq_along(idx)) { out <- c(out, compare_structure( x = extract_fun(x, idx[[i]]), y = extract_fun(y, idx[[i]]), paths = c(x_paths[[i]], y_paths[[i]]), opts = opts) ) } out } } index_name <- function(x, y) union(names(x), names(y)) extract_name <- function(x, i) if (has_name(x, i)) .subset2(x, i) else missing_arg() path_name <- function(path, i) glue::glue("{path}${i}") compare_by_name <- compare_by(index_name, extract_name, path_name) index_pos <- function(x, y) seq_len(max(length(x), length(y))) extract_pos <- function(x, i) if (i <= length(x)) .subset2(x, i) else missing_arg() path_pos <- function(path, i) glue::glue("{path}[[{i}]]") compare_by_pos <- compare_by(index_pos, extract_pos, path_pos) path_line <- function(path, i) glue::glue("lines({path}[[{i}]])") compare_by_line <- compare_by(index_pos, extract_pos, path_line) path_line1 <- function(path, i) glue::glue("lines({path})") compare_by_line1 <- compare_by(index_pos, extract_pos, path_line1) path_attr <- function(path, i) { # from ?attributes, excluding row.names() because it's not a simple accessor funs <- c("comment", "class", "dim", "dimnames", "levels", "names", "tsp") ifelse(i %in% funs, glue::glue("{i}({path})"), glue::glue("attr({path}, '{i}')")) } compare_by_attr <- compare_by(index_name, extract_name, path_attr) #' @importFrom methods slotNames .hasSlot slot is index_slot <- function(x, y) union(slotNames(x), slotNames(y)) extract_slot <- function(x, i) if (.hasSlot(x, i)) slot(x, i) else missing_arg() path_slot <- function(path, i) glue::glue("{path}@{i}") compare_by_slot <- compare_by(index_slot, extract_slot, path_slot) index_prop <- function(x, y) union(S7::prop_names(x), S7::prop_names(y)) extract_prop <- function(x, i) if (S7::prop_exists(x, i)) S7::prop(x, i) else missing_arg() path_prop <- function(path, i) glue::glue("{path}@{i}") compare_by_prop <- compare_by(index_prop, extract_prop, path_prop) extract_fun <- function(x, i) switch(i, fn_body(x), fn_fmls(x), fn_env(x)) path_fun <- function(path, i) { fun <- unname(c("body", "formals", "environment")[i]) glue::glue("{fun}({path})") } compare_by_fun <- compare_by(function(x, y) 1:3, extract_fun, path_fun) waldo/R/diff.R0000644000176200001440000001652314705465170012634 0ustar liggesusersdiff_align <- function(diff, x, y) { n <- nrow(diff) x_out <- character() y_out <- character() x_idx <- integer() y_idx <- integer() for (i in seq_len(n)) { row <- diff[i, , drop = FALSE] x_i <- seq2(row$x1, row$x2) y_i <- seq2(row$y1, row$y2) # Sometimes (last row?) a change is really one change + many additions if (row$t == "c" && length(x_i) != length(y_i)) { m <- max(length(x_i), length(y_i)) length(x_i) <- m length(y_i) <- m } x_out <- c(x_out, switch(row$t, a = col_x(extract(x, c(x_i, NA[y_i]))), c = col_c(extract(x, x_i)), d = col_d(extract(x, x_i)), x = col_x(extract(x, x_i)) )) y_out <- c(y_out, switch(row$t, a = col_a(extract(y, y_i)), c = col_c(extract(y, y_i)), d = col_x(extract(y, c(y_i, NA[x_i]))), x = col_x(extract(y, y_i)) )) x_idx <- c(x_idx, x_i[x_i != 0], if (row$t == "a") NA[y_i]) y_idx <- c(y_idx, y_i[y_i != 0], if (row$t == "d") NA[x_i]) } # Ensure both contexts are same length if (length(x_out) != length(y_out)) { # TODO: need to figure out when to truncate from left vs right len <- min(length(x_out), length(y_out)) x_out <- x_out[seq(length(x_out) - len + 1, length(x_out))] y_out <- y_out[seq(length(y_out) - len + 1, length(y_out))] x_idx <- x_idx[seq(length(x_idx) - len + 1, length(x_idx))] y_idx <- y_idx[seq(length(y_idx) - len + 1, length(y_idx))] } x_slice <- make_slice(x, x_idx) y_slice <- make_slice(y, y_idx) list( x = x_out, y = y_out, x_slice = x_slice, y_slice = y_slice, x_idx = x_idx, y_idx = y_idx ) } extract <- function(x, idx) { out <- x[idx] out[is.na(idx)] <- "" out } # Only want to show slice if it's partial make_slice <- function(x, idx) { if (all(is.na(idx))) { return(NULL) } idx <- range(idx, na.rm = TRUE) if (idx[[1]] <= 1 && idx[[2]] >= length(x)) { NULL } else { idx } } col_a <- function(x) cli::col_blue(x) col_d <- function(x) cli::col_yellow(x) col_c <- function(x) cli::col_green(x) col_x <- function(x) cli::col_grey(x) # values ------------------------------------------------------------------ diff_element <- function(x, y, paths = c("x", "y"), quote = "\"", justify = "left", max_diffs = 10, width = getOption("width"), is_string = FALSE) { # Must quote before comparison to ensure that "NA" and NA_character # have different representation if (!is.null(quote)) { x <- encodeString(unclass(x), quote = quote) y <- encodeString(unclass(y), quote = quote) } diff <- ses_shortest(x, y) if (length(diff) == 0) { return(new_compare()) } format <- lapply(diff, format_diff_matrix, x = x, y = y, paths = paths, justify = justify, width = width, max_diffs = max_diffs, # Paired comparisons are confusing for unquoted strings use_paired = !is_string || !is.null(quote) ) new_compare(unlist(format, recursive = FALSE)) } format_diff_matrix <- function(diff, x, y, paths, justify = "left", width = getOption("width"), max_diffs = 10, use_paired = TRUE) { alignment <- diff_align(diff, x, y) mat <- rbind(alignment$x, alignment$y) n <- min(ncol(mat), max_diffs) n_trunc <- ncol(mat) - n # Label slices, if needed x_path_label <- label_path(paths[[1]], alignment$x_slice) y_path_label <- label_path(paths[[2]], alignment$y_slice) # Paired lines --------------------------------------------------------------- if (use_paired) { mat_out <- cbind(paste0("`", c(x_path_label, y_path_label), "`:"), mat) if (n_trunc > 0) { mat_out <- mat_out[, seq_len(n + 1)] mat_out <- cbind(mat_out, c(paste0("and ", n_trunc, " more..."), "...")) } out <- apply(mat_out, 2, ansi_align, justify = justify) rows <- apply(out, 1, paste, collapse = " ") if (cli::ansi_nchar(rows[[1]]) <= width) { return(paste0(rows, collapse = "\n")) } } # Side-by-side --------------------------------------------------------------- x_idx_out <- label_idx(alignment$x_idx) y_idx_out <- label_idx(alignment$y_idx) idx_width <- max(nchar(x_idx_out), nchar(y_idx_out)) divider <- ifelse(mat[1,] == mat[2, ], "|", "-") mat_out <- cbind(c(paths[[1]], "|", paths[[2]]), rbind(mat[1, ], divider, mat[2, ])) if (n_trunc > 0) { mat_out <- mat_out[, seq_len(n + 1)] mat_out <- cbind(mat_out, c("...", "", "...")) x_idx_out <- c(x_idx_out[seq_len(n)], "...") y_idx_out <- c(y_idx_out[seq_len(n)], paste0("and ", n_trunc, " more ...")) } mat_out <- rbind( format(c("", x_idx_out), justify = "right"), mat_out, format(c("", y_idx_out), justify = "left") ) out <- apply(mat_out, 1, ansi_align, justify = "left") rows <- apply(out, 1, paste, collapse = " ") if (cli::ansi_nchar(rows[[1]]) <= width) { return(paste0(rows, collapse = "\n")) } # Line-by-line --------------------------------------------------------------- lines <- line_by_line(x, y, diff, max_diffs = max_diffs) paste0( paste0(x_path_label, " vs ", y_path_label), "\n", paste0(lines, collapse = "\n") ) } line_by_line <- function(x, y, diff, max_diffs = 10) { lines <- character() if (nrow(diff) == 0) { return(lines) } line_a <- function(x) if (length(x) > 0) col_a(paste0("+ ", names(x), x)) line_d <- function(x) if (length(x) > 0) col_d(paste0("- ", names(x), x)) line_x <- function(x) if (length(x) > 0) col_x(paste0(" ", names(x), x)) diff_lengths <- cumsum(pmax(diff$x2 - diff$x1, diff$y2 - diff$y1) + 1) all_diff_lengths <- last(diff_lengths) if (all_diff_lengths > max_diffs) { diffs_ok <- which(stats::lag(diff_lengths, 0) <= max_diffs) if (length(diffs_ok) == 0) { diff_ok <- 0 diff_length_partial <- max_diffs } else { diff_ok <- last(diffs_ok) diff_length_partial <- max_diffs - diff_lengths[[diff_ok]] } if (diff_length_partial > 0) { partial_diff <- diff[diff_ok + 1, ] partial_diff$x2 <- min(partial_diff$x2, partial_diff$x1 + diff_length_partial - 1) partial_diff$y2 <- min(partial_diff$y2, partial_diff$y1 + diff_length_partial - 1) } else { partial_diff <- NULL } diff <- rbind(diff[seq_len(diff_ok), ], partial_diff) n_trunc <- all_diff_lengths - max_diffs } else { n_trunc <- 0 } for (i in seq_len(nrow(diff))) { row <- diff[i, , drop = FALSE] x_i <- seq2(row$x1, row$x2) y_i <- seq2(row$y1, row$y2) lines <- c(lines, switch(row$t, x = line_x(x[x_i]), a = c(line_x(x[x_i]), line_a(y[y_i])), c = interleave(line_d(x[x_i]), line_a(y[y_i])), d = line_d(x[x_i]) )) } if (n_trunc > 0) { lines <- c(lines, paste0("and ", n_trunc, " more ...")) } lines } interleave <- function(x, y) { # Only interleave if same number of lines if (length(x) == length(y)) { ord <- c(seq_along(x), seq_along(y)) c(x, y)[order(ord)] } else { c(x, y) } } label_path <- function(path, slice) { if (is.null(slice)) { path } else { paste0(path, "[", slice[[1]], ":", slice[[2]], "]") } } label_idx <- function(idx) { ifelse(is.na(idx), "", paste0("[", idx, "]")) } last <- function(x) { x[[length(x)]] } waldo/R/compare-class.R0000644000176200001440000000115614705465170014451 0ustar liggesusers new_compare <- function(x = character(), max_diffs = if (in_ci()) Inf else 10) { stopifnot(is.character(x)) structure(x, max_diffs = max_diffs, class = "waldo_compare") } #' @export print.waldo_compare <- function(x, n = attr(x, "max_diffs"), ...) { stopifnot(is.numeric(n) && length(n) == 1 && n >= 1) if (length(x) == 0) { cli::cat_bullet("No differences", bullet = "tick", bullet_col = "green") } else { if (length(x) > n) { x <- c(x[seq_len(n)], glue::glue("And {length(x) - floor(n)} more differences ...")) } cat(paste0(x, collapse = "\n\n"), "\n", sep = "") } invisible(x) } waldo/NAMESPACE0000644000176200001440000000124714705465170012614 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method(compare_proxy,Descriptor) S3method(compare_proxy,EnumDescriptor) S3method(compare_proxy,EnumValueDescriptor) S3method(compare_proxy,FieldDescriptor) S3method(compare_proxy,FileDescriptor) S3method(compare_proxy,Message) S3method(compare_proxy,MethodDescriptor) S3method(compare_proxy,POSIXlt) S3method(compare_proxy,ServiceDescriptor) S3method(compare_proxy,data.table) S3method(compare_proxy,default) S3method(compare_proxy,xml_node) S3method(print,waldo_compare) export(compare) export(compare_proxy) import(rlang) importFrom(methods,.hasSlot) importFrom(methods,is) importFrom(methods,slot) importFrom(methods,slotNames) waldo/LICENSE0000644000176200001440000000005314531647116012373 0ustar liggesusersYEAR: 2023 COPYRIGHT HOLDER: waldo authors waldo/NEWS.md0000644000176200001440000001731014713156577012500 0ustar liggesusers# waldo 0.6.1 * Only use special bit64 comparison if package is installed. # waldo 0.6.0 * waldo no longer imports tibble and rematch2 (@olivroy, #196), and requires R 4.0.0. * `compare()` now gives informative errors if you misspecify the argument types (#181). * `compare()` displays an extract digit in numeric comparisons, making it a bit easier to see the different (#141). It can also show numeric differences between int64 objects and integers/doubles when `tolerance` is set (#159). * `compare()` gains basic support for S7 objects (#200), and can now distinguish between objects that differ only in the value of their S4 bit (#189). * `compare(list_as_map = TRUE)` now preserves attributes (#185). # waldo 0.5.3 * waldo no longer imports fansi (@olivroy, #192). # waldo 0.5.2 * Fixes for upcoming R-devel changes. # waldo 0.5.1 * Tolerance is also taken into account when displaying differences (#173). * `NA_real_` and `NaN` are only treated as non-equal when tolerance is non-null. That means that `testthat::expect_equal(NaN, NA_real_)` will pass but `testthat::expect_identical(NaN, NA_real_)` will fail (#174). # waldo 0.5.0 * You can opt-out of quoting strings with `quote_strings = FALSE` (#145). * Improvements to missing value handling: * `NA_character_` and `"NA"` are no longer treated as equal (#162). * `NA_real_` and `NaN` are no longer treated as equal (@sorhawell, #150). * Leading and trailing `NA`s are no longer omitted from output when the lengths of `x` and `y` are unequal (#109). * The `balanced` attribute used by some `POSIXlt` objects in R 4.3 and greater is now ignored (#160). * 3d (and greater) numeric arrays no longer cause an error (#148). * Support for complex numbers is improved (#146). * `ignore_attr = "class"` now works for more types of input (#143). # waldo 0.4.0 * Atomic S3 classes with format methods now use those methods when displaying comparisons (#98). If the printed representation is the same, they fallback to displaying the underlying data. * Rowwise data frame comparisons are now much much faster (#116), and respect the `max_diffs` argument (@krlmlr, #110). * Unnamed environments now compare by value, not by reference (i.e. if two environments contain the same values, they compare the same, even if they're different environments) (#127). Environments that contain self-references are handled correctly (#117). Differences between pairs of environments are only ever reported once. * In the unlikely event that you have bare CHARSXP objects, waldo now handles them (#121). * S4 objects are labelled with their class, not all superclasses (#125). * `compare_proxy()` ignores the `"index"` attribute for data tables (@krlmlr, #107), and works again for `RProtoBuf` objects (@MichaelChirico, #119) * Infinite values can be compared with a tolerance (@dmurdoch, #122). # waldo 0.3.1 * `compare()`ing data frames now works independently of `option(max.print)` (#105). * Fixed regression when comparing vectors with missing values (#102). # waldo 0.3.0 * `compare()` is now considerably faster when comparing complex objects that don't have any differences (thanks to strategic use of `identical()`) (#86). * `compare()` gains two improvements to low-level diffs: * Structurally identical data frames (#78) and numeric matrices (#76) gain a row-by-row diff that makes it easier to see where exactly values differ. * An element-by-element diff will be automatically used if it's shorter than the "smart" diff. This improves diff quality when comparing two vectors that aren't really related (#68). * `compare()` gains a `list_as_map` argument thanks to an idea from @dmurdoch. It allows you to compare the behaviour of two lists when they are used to connect names to values (i.e. the list is operating as a map or dictionary). It removes `NULL`s and sorts named components (#72). * The objects involved in `compare()` (as opposed to the caller of `compare()`) gained much greater ability to control the comparison. * Objects can now contain a `waldo_opts` attribute, a list with the same names and valid values as the arguments to `compare()`, which overrides the default comparisons (@dmurdoch). * `compare_proxy()` is now called earlier (before type comparison) making it more flexible (#65). * `compare_proxy()` gains a second argument, `path`, used to report how the proxy changed the object. This makes it easier to see when and how a proxy is used (#73). * Proxies now exist for comparing RProtoBuf objects, converting them to proto text format (#82, @michaelquinn32). * Comparing a list with symbol to a list without that element no longer errors (@mgirlich, #79). # waldo 0.2.5 * On platforms without UTF-8 support, strings that differ only in their encoding are now correctly considered to be identical (#66). # waldo 0.2.4 * Additional arguments to `compare()` generate a more informative warning (#58). * Numbers use a better algorithm for picking the number of decimal places to show (#63). * ASTs with identical deparsed strings now show exactly how the AST differs. Source references are now more comprehensively stripped using `rlang::zap_srcrefs()` * S3 objects now show the base type, and no longer fails when the types are incompatible. # waldo 0.2.3 * `compare()` gains a new `max_diffs` argument that allows you to control the maximum number of differences shown. Set `max_diffs = Inf` to see all differences (#49) * Logical vectors fall back to element-by-element comparison in more cases (#51). * Long-form diff no longer confuses additions and deletions (#52, @krlmlr). # waldo 0.2.2 * Handle S4 objects that have attributes that are not slots. * Additions are now coloured blue and deletions yellow (instead of the opposite). # waldo 0.2.1 * `compare()` now labels output as `old` and `new`, since that's the most natural way to use it. * `compare()` can selectively ignore attributes by providing vector to `ignore_attr` (#45). * `print()` method gets `n` argument to allow explicitly specifying number of differences to show (@mnazarov). * Improvements to comparison display: * Zero length vectors compare robustly (#39) * Line-by-line comparisons show modifications as deletion then addition, rather than addition then deletion (#44). * Differences between numeric vectors are more robust, particularly in the presence of missing values (#43). The number of digits selected has also been slightly improved so that you're more likely to get exactly the number of digits needed. # waldo 0.2.0 * All objects: class (#26) and names (#31) are ignored when ignoring attributes. * Numeric and logical vectors: clearer display of differences. Numbers are right-aligned, and we show the numbers not the differences. * Character vectors: a trailing newline is no longer ignored (#37). * Lists: all elements of the unnamed lists are compared, not just the last! (#32) * Lists: unclassed prior to comparison (#21). * Data frames: The internal representation of row names is no longer used; instead we use the same result of `rownames()` (#23). * Environments: New `ignore_formula_env` and `ignore_function_env` arguments to ignore formula and function environments for compatibility with `all.equal()` (#24). * Expression objects: can now be compared (#29). * Calls: srcrefs and attributes are ignored. --- * `compare_proxy()` is now exported so that you can provide methods if your objects need special handling (particularly needed for objects that contain external pointers) (#22). * Fixed a partial argument name in `as.list()`. # waldo 0.1.0 * Added a `NEWS.md` file to track changes to the package. waldo/README.md0000644000176200001440000000754614706170172012660 0ustar liggesusers # waldo [![Codecov test coverage](https://codecov.io/gh/r-lib/waldo/branch/main/graph/badge.svg)](https://app.codecov.io/gh/r-lib/waldo?branch=main) [![R-CMD-check](https://github.com/r-lib/waldo/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/r-lib/waldo/actions/workflows/R-CMD-check.yaml) The goal of waldo is to find and concisely describe the difference between a pair of R objects, with the primary goal of making it easier to figure out what’s gone wrong in your unit tests. `waldo::compare()` is inspired by `all.equal()`, but takes additional care to generate actionable insights by: - Ordering the differences from most important to least important. - Displaying the values of atomic vectors that are actually different. - Carefully using colour to emphasise changes (while still being readable when colour isn’t available). - Using R code (not a text description) to show where differences arise. - Where possible, comparing elements by name, rather than by position. - Erring on the side of producing too much output, rather than too little. ## Installation You can install the released version of waldo from [CRAN](https://CRAN.R-project.org) with: ``` r install.packages("waldo") ``` ## Comparisons ``` r library(waldo) ``` When comparing atomic vectors, `compare()` produces diffs (thanks to [diffobj](https://github.com/brodieG/diffobj)) that highlight additions, deletions, and changes, along with a little context: - Deletion ``` r compare(c("a", "b", "c"), c("a", "b")) ``` - Addition ``` r compare(c("a", "b"), c("a", "b", "c")) ``` - Change ``` r compare(c("a", "b", "c"), c("a", "B", "c")) ``` - Long vectors with short differences only show local context around changes, not everything that’s the same. ``` r compare(c("X", letters), c(letters, "X")) ``` Depending on the relative size of the differences and the width of your console you’ll get one of three displays: - The default display is to show the vectors one atop the other: ``` r compare(letters[1:5], letters[1:6]) ``` - If there’s not enough room for that, the two vectors are shown side-by-side: ``` r options(width = 20) compare(letters[1:5], letters[1:6]) ``` - And if there’s still not enough room for side-by-side, the each element is given its own line: ``` r options(width = 10) compare(letters[1:5], letters[1:6]) ``` When comparing more complex objects, waldo creates an executable code path telling you where the differences lie: - Unnamed lists are compared by position: ``` r compare(list(factor("x")), list(1L)) ``` - Named lists, including data frames, are compared by name. For example, note that the following comparison reports a difference in the class and names, but not the values of the columns. ``` r df1 <- data.frame(x = 1:3, y = 3:1) df2 <- tibble::tibble(rev(df1)) compare(df1, df2) ``` - Recursion can be arbitrarily deep: ``` r x <- list(a = list(b = list(c = list(structure(1, e = 1))))) y <- list(a = list(b = list(c = list(structure(1, e = "a"))))) compare(x, y) ``` waldo/man/0000755000176200001440000000000014713156617012146 5ustar liggesuserswaldo/man/compare.Rd0000644000176200001440000001524414706170207014062 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/compare.R \name{compare} \alias{compare} \title{Compare two objects} \usage{ compare( x, y, ..., x_arg = "old", y_arg = "new", tolerance = NULL, max_diffs = if (in_ci()) Inf else 10, ignore_srcref = TRUE, ignore_attr = "waldo_opts", ignore_encoding = TRUE, ignore_function_env = FALSE, ignore_formula_env = FALSE, list_as_map = FALSE, quote_strings = TRUE ) } \arguments{ \item{x, y}{Objects to compare. \code{x} is treated as the reference object so messages describe how \code{y} is different to \code{x}.} \item{...}{A handful of other arguments are supported with a warning for backward comparability. These include: \itemize{ \item \code{all.equal()} arguments \code{checkNames} and \code{check.attributes} \item \code{testthat::compare()} argument \code{tol} } All other arguments are ignored with a warning.} \item{x_arg, y_arg}{Name of \code{x} and \code{y} arguments, used when generated paths to internal components. These default to "old" and "new" since it's most natural to supply the previous value then the new value.} \item{tolerance}{If non-\code{NULL}, used as threshold for ignoring small floating point difference when comparing numeric vectors. Using any non-\code{NULL} value will cause integer and double vectors to be compared based on their values, not their types, and will ignore the difference between \code{NaN} and \code{NA_real_}. It uses the same algorithm as \code{\link[=all.equal]{all.equal()}}, i.e., first we generate \code{x_diff} and \code{y_diff} by subsetting \code{x} and \code{y} to look only locations with differences. Then we check that \code{mean(abs(x_diff - y_diff)) / mean(abs(y_diff))} (or just \code{mean(abs(x_diff - y_diff))} if \code{y_diff} is small) is less than \code{tolerance}.} \item{max_diffs}{Control the maximum number of differences shown. The default shows 10 differences when run interactively and all differences when run in CI. Set \code{max_diffs = Inf} to see all differences.} \item{ignore_srcref}{Ignore differences in function \code{srcref}s? \code{TRUE} by default since the \code{srcref} does not change the behaviour of a function, only its printed representation.} \item{ignore_attr}{Ignore differences in specified attributes? Supply a character vector to ignore differences in named attributes. By default the \code{"waldo_opts"} attribute is listed in \code{ignore_attr} so that changes to it are not reported; if you customize \code{ignore_attr}, you will probably want to do this yourself. For backward compatibility with \code{all.equal()}, you can also use \code{TRUE}, to all ignore differences in all attributes. This is not generally recommended as it is a blunt tool that will ignore many important functional differences.} \item{ignore_encoding}{Ignore string encoding? \code{TRUE} by default, because this is R's default behaviour. Use \code{FALSE} when specifically concerned with the encoding, not just the value of the string.} \item{ignore_function_env, ignore_formula_env}{Ignore the environments of functions and formulas, respectively? These are provided primarily for backward compatibility with \code{all.equal()} which always ignores these environments.} \item{list_as_map}{Compare lists as if they are mappings between names and values. Concretely, this drops \code{NULL}s in both objects and sorts named components.} \item{quote_strings}{Should strings be surrounded by quotes? If \code{FALSE}, only side-by-side and line-by-line comparisons will be used, and there's no way to distinguish between \code{NA} and \code{"NA"}.} } \value{ A character vector with class "waldo_compare". If there are no differences it will have length 0; otherwise each element contains the description of a single difference. } \description{ This compares two R objects, identifying the key differences. It: \itemize{ \item Orders the differences from most important to least important. \item Displays the values of atomic vectors that are actually different. \item Carefully uses colour to emphasise changes (while still being readable when colour isn't available). \item Uses R code (not a text description) to show where differences arise. \item Where possible, it compares elements by name, rather than by position. \item Errs on the side of producing too much output, rather than too little. } \code{compare()} is an alternative to \code{\link[=all.equal]{all.equal()}}. } \section{Controlling comparisons}{ There are two ways for an object (rather than the person calling \code{compare()} or \code{expect_equal()} to control how it is compared to other objects. First, if the object has an S3 class, you can provide a \code{\link[=compare_proxy]{compare_proxy()}} method that provides an alternative representation of the object; this is particularly useful if important data is stored outside of R, e.g. in an external pointer. Alternatively, you can attach an attribute called \code{"waldo_opts"} to your object. This should be a list of compare options, using the same names and possible values as the arguments to this function. This option is ignored by default (\code{ignore_attr}) so that you can set the options in the object that you control. (If you don't want to see the attributes interactively, you could attach them in a \code{\link[=compare_proxy]{compare_proxy()}} method.) Options supplied in this way also affect all the children. This means options are applied in the following order, from lowest to highest precedence: \enumerate{ \item Defaults from \code{compare()}. \item The \code{waldo_opts} for the parents of \code{x}. \item The \code{waldo_opts} for the parents of \code{y}. \item The \code{waldo_opts} for \code{x}. \item The \code{waldo_opts} for \code{y}. \item User-specified arguments to \code{compare()}. } Use these techniques with care. If you accidentally cover up an important difference you can create a confusing situation where \code{x} and \code{y} behave differently but \code{compare()} reports no differences in the underlying objects. } \examples{ # Thanks to diffobj package comparison of atomic vectors shows differences # with a little context compare(letters, c("z", letters[-26])) compare(c(1, 2, 3), c(1, 3)) compare(c(1, 2, 3), c(1, 3, 4, 5)) compare(c(1, 2, 3), c(1, 2, 5)) # More complex objects are traversed, stopping only when the types are # different compare( list(x = list(y = list(structure(1, z = 2)))), list(x = list(y = list(structure(1, z = "a")))) ) # Where possible, recursive structures are compared by name compare(iris, rev(iris)) compare(list(x = "x", y = "y"), list(y = "y", x = "x")) # Otherwise they're compared by position compare(list("x", "y"), list("x", "z")) compare(list(x = "x", x = "y"), list(x = "x", y = "z")) } waldo/man/compare_proxy.Rd0000644000176200001440000000245314416245254015324 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/proxy.R \name{compare_proxy} \alias{compare_proxy} \title{Proxy for waldo comparison} \usage{ compare_proxy(x, path = "x") } \arguments{ \item{x}{An object.} \item{path}{Path} } \value{ A list with two components: \itemize{ \item \code{object}: the modified object \item \code{path}: an updated path showing what modification was applied } } \description{ Use this generic to override waldo's default comparison if you need to override the defaults (typically because your object stores data in an external pointer). waldo comes with methods for a few common cases: \itemize{ \item data.table: the \code{.internal.selfref} and \code{index} attributes are set to \code{NULL}. Both attributes are used for performance optimisation, and don't affect the data. \item \code{xml2::xml_node}: the underlying XML data is stored in memory in C, behind an external pointer, so the we best can do is to convert the object to a string. \item Classes from the \code{RProtoBuf} package: like XML objects, these store data in memory in C++ and only expose string names to R. Fortunately, these have well-understood string representations that we can use for comparisons. See \url{https://protobuf.dev/reference/cpp/api-docs/google.protobuf.text_format/} } } waldo/man/figures/0000755000176200001440000000000014713156617013612 5ustar liggesuserswaldo/man/figures/README/0000755000176200001440000000000014107730175014541 5ustar liggesuserswaldo/man/figures/README/unnamed-chunk-7.svg0000644000176200001440000000472214706170171020167 0ustar liggesusersold|new[3]"c"|"c"[3][4]"d"|"d"[4][5]"e"|"e"[5]-"f"[6]waldo/man/figures/README/unnamed-chunk-6.svg0000644000176200001440000000333514706170171020165 0ustar liggesusers`old[3:5]`:"c""d""e"`new[3:6]`:"c""d""e""f"waldo/man/figures/README/unnamed-chunk-11.svg0000644000176200001440000000373714706170172020250 0ustar liggesusers`class(old)`:"data.frame"`class(new)`:"tbl_df""tbl""data.frame"`names(old)`:"x""y"`names(new)`:"y""x"waldo/man/figures/README/unnamed-chunk-4.svg0000644000176200001440000000330414706170171020157 0ustar liggesusers`old`:"a""b""c"`new`:"a""B""c"waldo/man/figures/README/unnamed-chunk-5.svg0000644000176200001440000000470114706170171020162 0ustar liggesusers`old[1:4]`:"X""a""b""c"`new[1:3]`:"a""b""c"`old[25:27]`:"x""y""z"`new[24:27]`:"x""y""z""X"waldo/man/figures/README/unnamed-chunk-8.svg0000644000176200001440000000317014706170171020164 0ustar liggesusersold[3:5]vsnew[3:6]"b""c""d""e"+"f"waldo/man/figures/README/unnamed-chunk-12.svg0000644000176200001440000000416114706170172020241 0ustar liggesusers`attr(old$a$b$c[[1]],'e')`isadoublevector(1)`attr(new$a$b$c[[1]],'e')`isacharactervector('a')waldo/man/figures/README/unnamed-chunk-3.svg0000644000176200001440000000315714706170171020164 0ustar liggesusers`old`:"a""b"`new`:"a""b""c"waldo/man/figures/README/unnamed-chunk-2.svg0000644000176200001440000000314114706170171020154 0ustar liggesusers`old`:"a""b""c"`new`:"a""b"waldo/man/figures/README/unnamed-chunk-9.svg0000644000176200001440000000155314213653252020167 0ustar liggesuserswaldo/man/figures/README/unnamed-chunk-10.svg0000644000176200001440000000433514706170172020242 0ustar liggesusers`old[[1]]`isanS3objectofclass<factor>,anintegervector`new[[1]]`isanintegervector(1)waldo/man/waldo-package.Rd0000644000176200001440000000145214531647116015133 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/waldo-package.R \docType{package} \name{waldo-package} \alias{waldo} \alias{waldo-package} \title{waldo: Find Differences Between R Objects} \description{ Compare complex R objects and reveal the key differences. Designed particularly for use in testing packages where being able to quickly isolate key differences makes understanding test failures much easier. } \seealso{ Useful links: \itemize{ \item \url{https://waldo.r-lib.org} \item \url{https://github.com/r-lib/waldo} \item Report bugs at \url{https://github.com/r-lib/waldo/issues} } } \author{ \strong{Maintainer}: Hadley Wickham \email{hadley@posit.co} Other contributors: \itemize{ \item Posit Software, PBC [copyright holder, funder] } } \keyword{internal} waldo/DESCRIPTION0000644000176200001440000000210214713223771013070 0ustar liggesusersPackage: waldo Title: Find Differences Between R Objects Version: 0.6.1 Authors@R: c( person("Hadley", "Wickham", , "hadley@posit.co", role = c("aut", "cre")), person("Posit Software, PBC", role = c("cph", "fnd")) ) Description: Compare complex R objects and reveal the key differences. Designed particularly for use in testing packages where being able to quickly isolate key differences makes understanding test failures much easier. License: MIT + file LICENSE URL: https://waldo.r-lib.org, https://github.com/r-lib/waldo BugReports: https://github.com/r-lib/waldo/issues Depends: R (>= 4.0) Imports: cli, diffobj (>= 0.3.4), glue, methods, rlang (>= 1.1.0) Suggests: bit64, R6, S7, testthat (>= 3.0.0), withr, xml2 Config/Needs/website: tidyverse/tidytemplate Config/testthat/edition: 3 Encoding: UTF-8 RoxygenNote: 7.3.2 NeedsCompilation: no Packaged: 2024-11-07 15:32:32 UTC; hadleywickham Author: Hadley Wickham [aut, cre], Posit Software, PBC [cph, fnd] Maintainer: Hadley Wickham Repository: CRAN Date/Publication: 2024-11-07 20:50:01 UTC