waldo/ 0000755 0001762 0000144 00000000000 14520717652 011371 5 ustar ligges users waldo/NAMESPACE 0000644 0001762 0000144 00000001275 14415265275 012617 0 ustar ligges users # 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(glue,glue)
importFrom(methods,.hasSlot)
importFrom(methods,is)
importFrom(methods,slot)
importFrom(methods,slotNames)
waldo/LICENSE 0000644 0001762 0000144 00000000053 14520545026 012366 0 ustar ligges users YEAR: 2023
COPYRIGHT HOLDER: waldo authors
waldo/README.md 0000644 0001762 0000144 00000007546 14520545026 012656 0 ustar ligges users
# waldo
[](https://app.codecov.io/gh/r-lib/waldo?branch=main)
[](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/ 0000755 0001762 0000144 00000000000 14520545653 012144 5 ustar ligges users waldo/man/waldo-package.Rd 0000644 0001762 0000144 00000001452 14520545026 015126 0 ustar ligges users % 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/man/compare_proxy.Rd 0000644 0001762 0000144 00000002453 14416245254 015324 0 ustar ligges users % 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/ 0000755 0001762 0000144 00000000000 14520545653 013610 5 ustar ligges users waldo/man/figures/README/ 0000755 0001762 0000144 00000000000 14107730175 014541 5 ustar ligges users waldo/man/figures/README/unnamed-chunk-12.svg 0000644 0001762 0000144 00000004161 14520015300 020222 0 ustar ligges users waldo/man/figures/README/unnamed-chunk-2.svg 0000644 0001762 0000144 00000003141 14520015277 020153 0 ustar ligges users waldo/man/figures/README/unnamed-chunk-11.svg 0000644 0001762 0000144 00000003737 14520015300 020231 0 ustar ligges users waldo/man/figures/README/unnamed-chunk-5.svg 0000644 0001762 0000144 00000004701 14520015277 020161 0 ustar ligges users waldo/man/figures/README/unnamed-chunk-9.svg 0000644 0001762 0000144 00000001553 14213653252 020167 0 ustar ligges users waldo/man/figures/README/unnamed-chunk-10.svg 0000644 0001762 0000144 00000004335 14520015300 020223 0 ustar ligges users waldo/man/figures/README/unnamed-chunk-4.svg 0000644 0001762 0000144 00000003304 14520015277 020156 0 ustar ligges users waldo/man/figures/README/unnamed-chunk-6.svg 0000644 0001762 0000144 00000003335 14520015277 020164 0 ustar ligges users waldo/man/figures/README/unnamed-chunk-7.svg 0000644 0001762 0000144 00000004722 14520015300 020151 0 ustar ligges users waldo/man/figures/README/unnamed-chunk-3.svg 0000644 0001762 0000144 00000003157 14520015277 020163 0 ustar ligges users waldo/man/figures/README/unnamed-chunk-8.svg 0000644 0001762 0000144 00000003170 14520015300 020146 0 ustar ligges users waldo/man/compare.Rd 0000644 0001762 0000144 00000015244 14426254670 014070 0 ustar ligges users % 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{NULLs} 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/DESCRIPTION 0000644 0001762 0000144 00000002136 14520717652 013101 0 ustar ligges users Package: waldo
Title: Find Differences Between R Objects
Version: 0.5.2
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 (>= 3.6)
Imports: cli, diffobj (>= 0.3.4), fansi, glue, methods, rematch2, rlang
(>= 1.0.0), tibble
Suggests: covr, R6, testthat (>= 3.0.0), withr, xml2
Config/Needs/website: tidyverse/tidytemplate
Config/testthat/edition: 3
Encoding: UTF-8
RoxygenNote: 7.2.3
NeedsCompilation: no
Packaged: 2023-11-01 22:05:31 UTC; hadleywickham
Author: Hadley Wickham [aut, cre],
Posit Software, PBC [cph, fnd]
Maintainer: Hadley Wickham
Repository: CRAN
Date/Publication: 2023-11-02 13:10:02 UTC
waldo/tests/ 0000755 0001762 0000144 00000000000 14520545653 012533 5 ustar ligges users waldo/tests/testthat/ 0000755 0001762 0000144 00000000000 14520717652 014373 5 ustar ligges users waldo/tests/testthat/test-diff.R 0000644 0001762 0000144 00000003264 14415256260 016404 0 ustar ligges users test_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/test-compare-class.R 0000644 0001762 0000144 00000000541 14073210415 020210 0 ustar ligges users test_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/f2.R 0000644 0001762 0000144 00000000034 13641461304 015013 0 ustar ligges users function(x = 1, y = 2) {
}
waldo/tests/testthat/charsxp-2.rds 0000644 0001762 0000144 00000000053 14212417513 016701 0 ustar ligges users ‹ ‹àb```b`adb`bf``aàò™“‹ Ðw£= waldo/tests/testthat/charsxp-1.rds 0000644 0001762 0000144 00000000053 14212417513 016700 0 ustar ligges users ‹ ‹àb```b`adb`bf``aàò™Óòó[ž/Ç waldo/tests/testthat/test-ses.R 0000644 0001762 0000144 00000002554 14115424043 016260 0 ustar ligges users test_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.R 0000644 0001762 0000144 00000026057 14415351771 017132 0 ustar ligges users test_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("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)
compare(f1, f4, ignore_srcref = FALSE)
"diff environment"
environment(f1) <- base_env()
environment(f2) <- global_env()
compare(f1, f2)
})
})
test_that("can choose to compare srcrefs", {
expect_snapshot({
f1 <- f2 <- function() {}
attr(f2, "srcref") <- "{ }"
compare(f2, f1)
compare(f2, 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 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("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/_snaps/ 0000755 0001762 0000144 00000000000 14520014337 015644 5 ustar ligges users waldo/tests/testthat/_snaps/diff.md 0000644 0001762 0000144 00000007654 14502077375 017125 0 ustar ligges users # 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/proxy.md 0000644 0001762 0000144 00000000662 14463243020 017352 0 ustar ligges users # 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-class.md 0000644 0001762 0000144 00000000650 14463243016 020724 0 ustar ligges users # 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/compare-opts.md 0000644 0001762 0000144 00000000723 14463243016 020605 0 ustar ligges users # 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-value.md 0000644 0001762 0000144 00000024001 14520014337 020723 0 ustar ligges users # 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
`y`: 1 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 10 3
`y`: 1 2 3
Code
# equal length
x <- c(1, 2, 3)
compare_numeric(x, x + c(-1, 0, 1) * 0.001)
Output
`x`: 1.000 2.000 3.000
`y`: 0.999 2.000 3.001
Code
compare_numeric(x, x + c(-1, 0, 1) * 1e-04)
Output
`x`: 1.0000 2.0000 3.0000
`y`: 0.9999 2.0000 3.0001
Code
compare_numeric(x, x + c(-1, 0, 1) * 1e-05)
Output
`x`: 1.00000 2.00000 3.00000
`y`: 0.99999 2.00000 3.00001
Code
compare_numeric(x, x + c(-1, 0, 1) * 1e-06)
Output
`x`: 1.000000 2.000000 3.000000
`y`: 0.999999 2.000000 3.000001
Code
compare_numeric(x, x + c(-1, 0, 1) * 1e-07)
Output
`x`: 1.0000000 2.0000000 3.0000000
`y`: 0.9999999 2.0000000 3.0000001
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.00000000 2.00000000 3.00000000
`y`: 0.99999999 2.00000000 3.00000001
Code
compare_numeric(x, x + c(-1, 0, 1) * 1e-09, tolerance = NULL)
Output
`x`: 1.000000000 2.000000000 3.000000000
`y`: 0.999999999 2.000000000 3.000000001
Code
compare_numeric(x, x + c(-1, 0, 1) * 1e-10, tolerance = NULL)
Output
`x`: 1.0000000000 2.0000000000 3.0000000000
`y`: 0.9999999999 2.0000000000 3.0000000001
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.00000000 2.00000000 3.00000000
`y`: 1.00000000 2.00000000 4.00000000
Code
compare_numeric(x, y, tolerance = NULL)
Output
`x`: 1.000000000 2.000000000 3.000000000
`y`: 1.000000001 2.000000001 4.000000000
# 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.0
`unclass(new)`: 1.5
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 2
`unclass(new)`: 2 1
# ignore_attr never uses format method
Code
compare(.POSIXct(1, "UTC"), .POSIXct(2, "UTC"), ignore_attr = TRUE)
Output
`old`: 1
`new`: 2
# 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 1
`Im(new)`: 2 2
# 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/_snaps/compare-data-frame.md 0000644 0001762 0000144 00000006377 14463243016 021634 0 ustar ligges users # 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"), stringsAsFactors = FALSE)
df2 <- data.frame(x = c(1, 100, 3), y = 1, z = c("a", "B", "c"),
stringsAsFactors = FALSE)
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.md 0000644 0001762 0000144 00000037716 14520014337 017632 0 ustar ligges users # 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)
# 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
`formals(new)$y`: 1
`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
compare(f1, f4, ignore_srcref = FALSE)
Output
`attr(old, 'srcref')`: 2 8 2 33 8 33 2 2
`attr(new, 'srcref')`: 14 8 16 1 8 1 14 16
`attr(body(old), 'srcref')` is length 1
`attr(body(new), 'srcref')` is length 2
`attr(body(old), 'srcref')[[1]]`: 2 31 2 31 31 31 2 2
`attr(body(new), 'srcref')[[1]]`: 14 31 14 31 31 31 14 14
`attr(body(old), 'srcref')[[2]]` is absent
`attr(body(new), 'srcref')[[2]]` is an S3 object of class , an integer vector
`attr(body(old), 'wholeSrcref')`: 1 0 2 33 0 33 1 2
`attr(body(new), 'wholeSrcref')`: 1 0 16 1 0 1 1 16
`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
f1 <- f2 <- (function() { })
attr(f2, "srcref") <- "{ }"
compare(f2, f1)
Output
v No differences
Code
compare(f2, f1, ignore_srcref = FALSE)
Output
`attr(old, 'srcref')` is a character vector ('{ }')
`attr(new, 'srcref')` is an S3 object of class , an integer vector
# 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 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
# 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
`new$x`: 11
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
`parent.env(new)$x`: 2
# 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
`new[[1]]$x`: 2
`old[[3]]$x`: 1
`new[[3]]$x`: 3
# 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
`proxy(new)$x`: 2
# 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/test-compare-opts.R 0000644 0001762 0000144 00000001144 14075101361 020071 0 ustar ligges users test_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-num_equal.R 0000644 0001762 0000144 00000002602 14426254670 017462 0 ustar ligges users test_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_))
})
waldo/tests/testthat/test-utils.R 0000644 0001762 0000144 00000001142 14212415373 016622 0 ustar ligges users 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-compare-data-frame.R 0000644 0001762 0000144 00000003776 14212417410 021120 0 ustar ligges users test_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"), stringsAsFactors = FALSE)
df2 <- data.frame(x = c(1, 100, 3), y = 1, z = c("a", "B", "c"), stringsAsFactors = FALSE)
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-compare-value.R 0000644 0001762 0000144 00000013715 14520014337 020230 0 ustar ligges users test_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.21, 0.23), 2)
expect_equal(min_digits(1.93, 1.92), 2)
expect_equal(min_digits(1, 1.1), 1)
expect_equal(min_digits(1, 1.01), 2)
expect_equal(min_digits(1, 1.001), 3)
expect_equal(min_digits(1, 1.0001), 4)
expect_equal(min_digits(1, 1.00001), 5)
expect_equal(min_digits(1, 1.000001), 6)
expect_equal(min_digits(1, 1.0000001), 7)
expect_equal(min_digits(1, 1.00000001), 8)
expect_equal(min_digits(1, 1.000000001), 8)
expect_equal(min_digits(1, 1.0000000001), 8)
expect_equal(min_digits(1, 1.000000001, tolerance = NULL), 9)
expect_equal(min_digits(1, 1.0000000001, tolerance = NULL), 10)
})
waldo/tests/testthat/test-proxy.R 0000644 0001762 0000144 00000002045 14415265275 016657 0 ustar ligges users test_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.R 0000644 0001762 0000144 00000000066 13637650533 014522 0 ustar ligges users library(testthat)
library(waldo)
test_check("waldo")
waldo/R/ 0000755 0001762 0000144 00000000000 14520545027 011565 5 ustar ligges users waldo/R/compare-value.R 0000644 0001762 0000144 00000010521 14520014337 014442 0 ustar ligges users compare_vector <- function(x, y, paths = c("x", "y"), opts = compare_opts()) {
# Early exit for numerics (except for) with format methods
if (typeof(x) %in% c("integer", "double") && 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()) {
attributes(x) <- NULL
attributes(y) <- NULL
n <- digits(abs(x - y))
if (!is.null(tolerance)) {
n <- min(n, digits(tolerance))
}
n
}
# 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.R 0000644 0001762 0000144 00000007106 14520014327 013046 0 ustar ligges users oo_type <- function(x) {
if (is.object(x)) {
if (isS4(x)) {
"S4"
} 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)) {
return(friendly_type(typeof(x)))
}
if (!isS4(x)) {
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)]
}
is_numeric <- function(x) is_integer(x) || is_double(x)
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)
)
}
}
fansi_align <- function(x, width = NULL, justify = c("left", "right")) {
justify <- arg_match(justify)
nchar <- fansi::nchar_ctl(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) {
# Remove nulls
is_null <- vapply(x, is.null, logical(1))
x <- x[!is_null]
# 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]
}
x
}
scrub_environment <- function(x) {
gsub("", "", x)
}
waldo/R/waldo-package.R 0000644 0001762 0000144 00000000444 14415111303 014376 0 ustar ligges users #' @keywords internal
#' @import rlang
#' @importFrom glue glue
"_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-class.R 0000644 0001762 0000144 00000001150 14073632206 014435 0 ustar ligges users
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("And {length(x) - floor(n)} more differences ..."))
}
cat(paste0(x, collapse = "\n\n"), "\n", sep = "")
}
invisible(x)
}
waldo/R/compare-opts.R 0000644 0001762 0000144 00000003370 14415351771 014330 0 ustar ligges users compare_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/num_equal.R 0000644 0001762 0000144 00000001307 14426254670 013705 0 ustar ligges users num_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)
}
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
}
waldo/R/compare-data-frame.R 0000644 0001762 0000144 00000005450 14415110067 015334 0 ustar ligges users compare_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.R 0000644 0001762 0000144 00000007637 14274453635 012530 0 ustar ligges users #
#
# * `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 <- rematch2::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) {
tibble::tibble(x1 = x1, x2 = x2, t = t, y1 = y1, y2 = y2)
}
waldo/R/proxy.R 0000644 0001762 0000144 00000005214 14416245252 013074 0 ustar ligges users #' 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/diff.R 0000644 0001762 0000144 00000016527 14416073351 012633 0 ustar ligges users diff_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, fansi_align, justify = justify)
rows <- apply(out, 1, paste, collapse = " ")
if (fansi::nchar_ctl(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, fansi_align, justify = "left")
rows <- apply(out, 1, paste, collapse = " ")
if (fansi::nchar_ctl(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.R 0000644 0001762 0000144 00000041521 14520545027 013341 0 ustar ligges users #' 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 `NULLs` 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
) {
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("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 (!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)
}
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("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("{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 (!is.null(tolerance) && is_numeric(x) && is_numeric(y)) {
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(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("{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("{path}[[{i}]]")
compare_by_pos <- compare_by(index_pos, extract_pos, path_pos)
path_line <- function(path, i) glue("lines({path}[[{i}]])")
compare_by_line <- compare_by(index_pos, extract_pos, path_line)
path_line1 <- function(path, i) 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("{i}({path})"), 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("{path}@{i}")
compare_by_slot <- compare_by(index_slot, extract_slot, path_slot)
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("{fun}({path})")
}
compare_by_fun <- compare_by(function(x, y) 1:3, extract_fun, path_fun)
waldo/NEWS.md 0000644 0001762 0000144 00000015737 14520545641 012501 0 ustar ligges users # 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/MD5 0000644 0001762 0000144 00000006030 14520717652 011700 0 ustar ligges users 265d1064de4610b24a7a81800ae2a5d4 *DESCRIPTION
7be88896a6c4a4461e69c8cb0d82e1f0 *LICENSE
b30c86906f7c5a77d840c6d5d4287961 *NAMESPACE
bb98847cd901532ba174c9552040bc0b *NEWS.md
e2921f1b1c70550d2ac90f88bd084718 *R/compare-class.R
e3fa946b455d123f24ea38ddd7eb7b3a *R/compare-data-frame.R
ab974bd790ddd93f35f1ec53ba4b9bae *R/compare-opts.R
8e04cf1379ef69889fd787a94561cd90 *R/compare-value.R
973b82e495fb602097403bdbc82473ce *R/compare.R
e0ced7f7e20ecd8c100b6ff5e4bd4e3e *R/diff.R
b80a643a675aabe53ff45ae9d795529a *R/num_equal.R
c9daace37b97c65f323da7071875be61 *R/proxy.R
14856801b08dba84c4985fcfb2e5dbc6 *R/ses.R
e4ea14320409d844eb82d68100e78a86 *R/utils.R
70c4487627973ab5bafe5bb76b802cad *R/waldo-package.R
67ba06d288bfb007535182b9f97984d3 *README.md
1fb642b37dbefe54b061f2d040096b21 *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
32410215de11d8c2d57c845c574a81e4 *tests/testthat/_snaps/compare-data-frame.md
4a213b3316196456e07f0aa5c20b7258 *tests/testthat/_snaps/compare-opts.md
789d633ce840cb88d2426b003d588c4b *tests/testthat/_snaps/compare-value.md
353d92bbb4222ebcdeb9c29eb5941dcc *tests/testthat/_snaps/compare.md
2df20b96552271e99d4fb5a923ba7ae7 *tests/testthat/_snaps/diff.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
55ed8e9b0208b1b30c335c417714df8b *tests/testthat/test-compare-data-frame.R
f11ea680ea30726171d2f730343fb8db *tests/testthat/test-compare-opts.R
a122f04237bd1ad9b7340fa47fd9adbf *tests/testthat/test-compare-value.R
dfcaff0a8b671cb831a3510690051089 *tests/testthat/test-compare.R
5c5c5fc75460eb70a27758f9637af005 *tests/testthat/test-diff.R
b304ebbece20a4f47e9d346c35c77514 *tests/testthat/test-num_equal.R
5a0d0e27462fceaf4a39970da39cdade *tests/testthat/test-proxy.R
9de0e996a6bffee4ec41a45310e5c5fc *tests/testthat/test-ses.R
4160215fb598a406231a4a716de50d3b *tests/testthat/test-utils.R