# Copyright (C) 2023 Brodie Gaslam
#
# This file is part of "vetr - Trust, but Verify"
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# Go to <https://www.r-project.org/Licenses/GPL-2> for a copy of the license.
library(vetr)
unitizer_sect("Atomic", {
alike(integer(), 1:3) # TRUE
alike(integer(5L), 1:3) # FALSE
alike(integer(3L), 1:3) # TRUE
alike(numeric(), c(1, 2, 3)) # TRUE
alike(numeric(), 1L) # TRUE
alike(numeric(), c(1.1,.053,41.8)) # TRUE
alike(integer(3L), 1:3 + .01)
alike(integer(6L), seq(1/6, 1, 1/6) * 6) # FALSE, not true integers
alike(integer(4L), letters[1:4])
alike(letters[1:4], c("hello", "goodbye", "ba", "da")) # TRUE
alike(integer(), NULL) # FALSE, corner case test
alike(c(a=1, b=2), 3) # Length mismatch
alike(c(a=1, b=2), c(1, 2)) # Names
} )
unitizer_sect("lists", {
lst <- list(list( 1, 2), list( 3, list( 4, list( 5, list(6, 6.1, 6.2)))))
lst.2 <- list(list(11, 21), list(31, list(41, list(51, list(61 )))))
alike(lst, lst.2) # length mismatch
lst.3 <- lst.2
lst.3[[2]][[2]][[2]][[2]] <- matrix(1:9, nrow=3)
alike(lst, lst.3) # object type mismatch
alike(1:10, "hello") # object type mismatch, no dive
alike(lst, lst) # obvious match
lst.4 <- lst
lst.4[[2]][[2]] <- list()
alike(lst.4, lst) # should match
alike(lst, lst.4) # should not match because template has more detail
# Named lists
lst.5 <- list(1, list(a = 1, b = 2, c = list(d = 1)))
lst.6 <- list(1, list(a = 1, b = 2, c = list(d = "hello")))
lst.5.1 <- list(1, list(a = 1, b = 2, `c d` = list(d = 1)))
lst.6.1 <- list(1, list(a = 1, b = 2, `c d` = list(d = "hello")))
alike(lst.5, lst.6)
alike(lst.6, lst.5)
alike(lst.5.1, lst.6.1)
alike(lst.6.1, lst.5.1)
# Pair lists
alike(pairlist(a=1, b="character"), pairlist(a=1, b=letters))
alike(pairlist(1, "character"), pairlist(1, letters))
})
unitizer_sect("NULL values as wildcards", {
alike(NULL, 1:3) # not a wild card at top level
alike(list(NULL), list(1:3)) # but yes when nested
alike(list(NULL, NULL), list(list(list(1, 2, 3)), 1:25))
alike(list(NULL), list(1, 2))
alike(list(), list(1, 2))
})
unitizer_sect("Matrix / Arrays", {
alike(matrix(integer(), ncol=7), matrix(1:21, nrow=3))
alike(matrix(integer(), nrow=3), matrix(1:21, nrow=3))
alike(matrix(character(), nrow=3), matrix(1:21, nrow=3))
alike(matrix(integer(), nrow=4), matrix(1:21, nrow=3))
alike(
matrix(integer(), ncol=3, dimnames=list(NULL, c("R", "G", "B"))),
matrix(1:21, ncol=3, dimnames=list(NULL, c("R", "G", "B")))
)
alike(
matrix(integer(), nrow=3, dimnames=list(c("R", "G", "B"), NULL)),
matrix(1:21, ncol=3, dimnames=list(NULL, c("R", "G", "B")))
)
alike(
matrix(integer(), nrow=3, dimnames=list(c("R", "G", "B"), NULL)),
matrix(1:9, nrow=3, dimnames=list(NULL, c("R", "G", "B")))
)
alike(
matrix(integer(), nrow=3, dimnames=list(c("R", "G", "B"), NULL)),
matrix(
1:9, nrow=3, dimnames=list(c("R", "G", "B"),
c("bacon", "turkey", "bravo"))
) )
alike(matrix(1:9, nrow = 3), 1:9)
# Adding tests from docs
mx.tpl <- matrix(
integer(), ncol=3, dimnames=list(row.id=NULL, c("R", "G", "B"))
)
mx.cur <- matrix(
sample(0:255, 12), ncol=3, dimnames=list(row.id=1:4, rgb=c("R", "G", "B"))
)
mx.cur2 <-
matrix(sample(0:255, 12), ncol=3, dimnames=list(1:4, c("R", "G", "B")))
alike(mx.tpl, mx.cur)
alike(mx.tpl, mx.cur2)
} )
unitizer_sect("Data Frames", {
alike(mtcars, 1:3)
alike(1:3, mtcars)
alike(
data.frame(),
data.frame(a=1:3, b=letters[1:3])
) # TRUE
alike( # TRUE, note this is recursive
data.frame(a=integer(), b=factor()),
data.frame(a=1:3, b=letters[1:3], stringsAsFactors=TRUE)
)
# FALSE mis-match at index[[1]]
alike(
data.frame(a=factor(), b=factor()),
data.frame(a=1:3, b=letters[1:3])
)
# FALSE mis-match at index[[2]] (class)
alike(
list(NULL, structure("a", class="x")),
list(NULL, structure("a", class="y"))
)
# TRUE, more complex nested structure
# row.names / names (note use `structure` to get around `data.frame` checks)
alike(
list(
integer(), data.frame(a=integer(), b=numeric()),
matrix(integer(), nrow=3)
),
list(1:10, data.frame(a=1:200, b=runif(20)), matrix(1:27, nrow=3))
)
df.tpl <- structure(
list(1:4, factor(LETTERS[1:4], levels=LETTERS)),
row.names=c("one", "", "", ""), names=c("id", ""), class="data.frame"
)
df.cur <- `row.names<-`(
data.frame(id=5:8, val=factor(LETTERS[21:24], levels=LETTERS)),
c("one", "two", "tre", "qtr")
)
df.cur2 <- `row.names<-`(
data.frame(id=5:8, val=factor(LETTERS[21:24], levels=LETTERS)),
c("uno", "due", "tre", "qtr")
)
alike(df.tpl, df.cur) # TRUE
alike(df.cur, df.tpl) # Nope, names won't match reversed
alike(df.tpl, df.cur2) # Nope, row.names won't match
# NA names
df.tpl <-
structure(list(1:4, letters[1:4]), names=c("id", NA), class="data.frame")
df.cur <-
structure(list(1:4, letters[1:4]), names=c("id", "val"), class="data.frame")
alike(df.tpl, df.tpl)
alike(df.tpl, df.cur)
# special treatment
alike(mtcars, iris)
alike(mtcars, mtcars[1:10,])
alike(mtcars[-5], mtcars)
})
unitizer_sect("Time Series", {
ts.1 <- ts(runif(24), 1970, frequency=12)
ts.2 <- ts(runif(24), 1970, frequency=4)
ts.3 <- abstract(ts.1, "end")
ts.4 <- abstract(ts.2, "frequency")
alike(ts.1, ts.2)
alike(ts.3, ts.1)
alike(ts.1, ts.3)
alike(ts.3, ts.2)
ts.5 <- ts(matrix(runif(24 * 3), ncol=3), 1970, frequency=12)
ts.6 <- ts(matrix(runif(12 * 3), ncol=3), 1970, frequency=12)
alike(ts.5, ts.6)
alike(ts.5, matrix(runif(24 * 3), ncol=3))
})
unitizer_sect("Factors", {
f1 <- factor(letters[1:5])
f2 <- factor(letters[1:5], levels=letters[5:1])
f3 <- f1
levels(f3)[[5]] <- ""
f4 <- factor(c(letters[1:4], "f"))
alike(f1, f2) # FALSE
alike(f1, f3) # FALSE
alike(f1, f4) # FALSE
alike(f3, f1) # TRUE, wildcard matches anything
alike(f3, f4) # TRUE, wildcard matches anything
})
unitizer_sect("Environments / Pairlists", {
env0 <- new.env()
env1 <- list2env(list(a=character(), b=list(), c=NULL))
env2 <- list2env(list(a="hello", b=iris, c=matrix(1:3)))
env3 <- list2env(list(a="hello", b=iris))
env4 <- list2env(list(a="hello", b=iris, c=logical(1L), d=logical(1L)))
env5 <- list2env(list(b=iris, a="hello", c=matrix(1:3)))
alike(env0, env2) # zero length, matches anything
alike(env1, env2) # TRUE
alike(env1, env3) # length mismatch
alike(env3, env1) # component mismatch
alike(env1, env4) # TRUE length mismatch but longer allowed
alike(env1, env5) # order change, should still match
# Test infinite recursion protection
rec.env <- rec.env.cpy <- new.env()
for(i in 1:50) {
rec.env.cpy$a <- new.env()
rec.env.cpy <- rec.env.cpy$a
}
rec.env.cpy$a <- rec.env;
alike(rec.env, rec.env)
plst1 <- pairlist(a=character(), b=list(), c=NULL)
plst2 <- pairlist(a="hello", b=iris, c=matrix(1:3))
plst3 <- pairlist(a="hello", b=iris)
plst4 <- pairlist(a="hello", b=iris, c=logical(1L), d=logical(1L))
plst5 <- pairlist(a=character(), b=list(), integer())
plst6 <- pairlist(a=character(), b=list(), boogey=1:3)
plst7 <- pairlist(a=character(), boogey=1:3, b=list())
alike(plst1, plst2) # TRUE
alike(plst1, plst3) # length mismatch
alike(plst1, plst4) # length mismatch
alike(plst1, plst5) # fail, missing name
alike(plst5, plst6) # TRUE, no name matches anything
alike(plst5, plst7) # FALSE, order matters in pair lists
# Nesting
env7 <- list2env(list(a=character(), b=plst1))
env8 <- list2env(list(a=letters[1:3], b=plst2))
env9 <- list2env(list(a=letters[1:3], b=plst5))
alike(env7, env8) # pass
alike(env7, env9) # fail
# Overwhelm env nesting
env.nest.1 <- env.nest.1.cpy <- new.env()
env.nest.2 <- env.nest.2.cpy <- new.env()
for(i in 1:26) {
env.nest.1.cpy[[letters[i]]] <- new.env();
env.nest.1.cpy <- env.nest.1.cpy[[letters[i]]]
env.nest.2.cpy[[letters[i]]] <- new.env();
env.nest.2.cpy <- env.nest.2.cpy[[letters[i]]]
}
alike(env.nest.1, env.nest.2, settings=vetr_settings(env.depth.max=16))
# Global env test
alike(.GlobalEnv, env.nest.1)
})
unitizer_sect("Calls / Formulas", {
alike(quote(1 + 1), quote(x + y))
alike(quote(fun(1 + 1)), quote(fun(x + y, 9)))
alike(quote(fun(x + y, 9)), quote(fun(1 + 1)))
# Need to add parens in error messages, which we will illustrate with an
# operator
"%plusq%" <- function(x, y) call("+", substitute(x), substitute(y))
alike(quote(1 + 1), 1 %plusq% b)
# With defined fun
fun <- function(a, b, c) NULL
# TRUE, since constants including NULL match any constants
alike(quote(fun(b=fun2(x, y), 1, 3)), quote(fun(NULL, fun2(a, b), 1)))
alike( # FALSE, match.call disabled
quote(fun(b=fun2(x, y), 1, 3)), quote(fun(NULL, fun2(a, b), 1)),
settings=vetr_settings(lang.mode=1)
)
# FALSE, mismatch
alike(quote(fun(b=fun2(x, y), 1, 3)), quote(fun(fun2(a, b), NULL, 1)))
alike(quote(fun(a=1)), quote(fun(b=1))) # FALSE, name mismatch
alike(quote(fun(1, 2)), quote(fun(1))) # FALSE
alike(quote(fun(1)), quote(fun(1, 2))) # FALSE
alike(quote(fun(1, 2)), quote(fun2(1, 2))) # FALSE, fun mismatch
# FALSE, fun mismatch, nested
alike(quote(fun(1, fun2(3))), quote(fun(1, fun(3))))
# zero len matches anything
alike(quote(fun()), quote(fun(a, b, c))) # TRUE
alike(quote(fun()), quote(fun2(a, b, c))) # FALSE, still need match fun names
alike(quote(fun(a, fun2())), quote(fun(b, fun2(a, b, c)))) # TRUE
# Attributes on sub-components should not affect anything
# actually, these tests need to be with alike since lang_alike doesn't check
# attributes
c0 <- quote(fun(a, b, a, 25))
c0.1 <- c0.2 <- c0
attr(c0.1, "blah") <- "hello"
attr(c0.2, "blah") <- 1:3
alike(c0, c0.1) # TRUE
alike(c0.1, c0) # Missing attribute
alike(c0.1, c0.2) # Attribute mismatch
# Formulas
alike(x ~ y, z ~ w)
alike(x ~ y, z ~ w + 1)
alike(x ~ y + 2, z ~ w + 1)
alike(x ~ y + z:y, w ~ v + u:v)
alike(z ~ w + 1, x ~ y)
alike(y ~ x ^ 2 + x * z + z + w:z, q ~ l ^ 2 + l * j + j + w:j)
alike(y ~ x ^ 2 + x * z + z + w:z, q ~ l ^ 3 + l * j + j + w:j)
# # Repeating parses to deal with potential parse issues in clean R runs
exp.1 <- parse(text="x + y; fun2(fun(1, 2, 3), z)", keep.source=TRUE)
exp.2 <- parse(text="z + 2; fun(fun2(1, 2, 3), q)", keep.source=TRUE)
exp.3 <- parse(text="z + fun(3); fun(fun2(a, b, c), 3)", keep.source=TRUE)
alike(exp.1, exp.2)
alike(exp.2, exp.3)
alike(exp.3, exp.2)
exp.4 <- expression(1 + 1, 2 + x)
exp.5 <- expression(1 + 1, 5 + y)
exp.6 <- expression(1 + 1, 2 + 2)
alike(exp.4, exp.5) # TRUE
alike(exp.4, exp.6) # FALSE
# Symbols
alike(quote(x), quote(y)) # TRUE
alike(NULL, quote(x)) # FALSE, overridden by type comparison
alike(quote((NULL)), quote(y)) # TRUE, NULL matches anything as language object
alike(quote(NULL), quote(x)) # FALSE, quoting NULL doesn't make it language
alike(quote(x), c0) # FALSE
alike(c0, quote(x)) # FALSE
alike(quote((x)), quote(y)) # TRUE, parens shouldn't matter
} )
# Most fun tests in internal/type, here to make sure interface working
unitizer_sect("Functions", {
alike(print, print.data.frame) # TRUE
alike(print.data.frame, print) # FALSE
alike(`&&`, function() NULL) # TRUE
# check srcref issues
fun <- fun2 <- function() NULL
attributes(fun2) <- NULL
alike(fun, fun2) # TRUE
alike(fun, fun2, settings=vetr_settings(attr.mode=2L))
alike(fun2, fun, settings=vetr_settings(attr.mode=1L))
alike(fun2, fun, settings=vetr_settings(attr.mode=2L))
})
# Subset of tests for version with settings
unitizer_sect("settings", {
alike(1L, 1.0, settings=vetr_settings(type.mode=1L))
alike(1.0, 1L, settings=vetr_settings(type.mode=1L))
alike(1.0, 1L, settings=vetr_settings(type.mode=2L)) # FALSE
alike(1:101, 1:101 + 0.0) # FALSE
# TRUE
alike(1:101, 1:101 + 0.0, settings=vetr_settings(fuzzy.int.max.len=200))
# TRUE
alike(1:101, 1:101 + 0.0, settings=vetr_settings(fuzzy.int.max.len=-1))
alike(list(a=1:10), data.frame(a=1:10))
alike(list(a=1:10), data.frame(a=1:10), settings=vetr_settings(attr.mode=1L))
# FALSE
alike(list(a=1:10), data.frame(a=1:10), settings=vetr_settings(attr.mode=2L))
fun <- function(a, b, c) NULL
call.a <- quote(fun(b=fun2(x, y), 1, 3))
call.b <- quote(fun(NULL, fun2(a, b), 1))
# FALSE, function not defined in empty env
alike(call.a, call.b, settings=vetr_settings(env=emptyenv()))
# FALSE, also not defined this way
alike(call.a, call.b, env=emptyenv())
# TRUE, verify that settings takes precedence
alike(
call.a, call.b, env=emptyenv(), settings=vetr_settings(env=environment())
)
# TRUE
alike(
call.a, call.b
)
# FALSE
alike(`&&`, function() NULL, settings=vetr_settings(type.mode=1))
# Error
alike(1, 2, settings=letters)
alike(1, 2, settings=list())
alike(1, 2, settings=setNames(vector("list", 16), letters[1:16]))
alike(1, 2, settings=vector("list", 16))
} )
# These are also part of the examples, but here as well so that issues are
# detected during development and not the last minute package checks
unitizer_sect("Examples", {
alike(1L, 1.0) # TRUE, because 1.0 is integer-like
alike(1L, 1.1) # FALSE, 1.1 is not integer-like
alike(1.1, 1L) # TRUE, by default, integers are always considered real
alike(1:100, 1:100 + 0.0) # TRUE
# FALSE, we do not check numerics for integerness if longer than 100
alike(1:101, 1:101 + 0.0)
# Scalarness can now be checked at same time as type
alike(integer(1L), 1) # integer-like and length 1?
alike(logical(1L), TRUE) # logical and length 1?
alike(integer(1L), 1:3)
alike(logical(1L), c(TRUE, TRUE))
# Zero length match any length of same type
alike(integer(), 1:10)
alike(1:10, integer()) # but not the other way around
# Recursive objects compared recursively
alike(
list(integer(), list(character(), logical(1L))),
list(1:10, list(letters, TRUE))
)
alike(
list(integer(), list(character(), logical(1L))),
list(1:10, list(letters, c(TRUE, FALSE)))
)
# `NULL` is a wild card when nested within recursive objects
alike(list(NULL, NULL), list(iris, mtcars))
alike(NULL, mtcars) # but not at top level
# Since `data.frame` are lists, we can compare them recursively:
iris.fake <- transform(iris, Species=as.character(Species))
alike(iris, iris.fake)
iris.fake2 <- transform(
iris,
Species=factor(Species, levels="[[<-"(levels(Species), 3, "americana"))
)
alike(iris, iris.fake2) # we even check attributes (factor levels must match)!
# We can use partially specified objects as templates
iris.tpl <- abstract(iris)
str(iris.tpl)
alike(iris.tpl, iris)
# any row sample of iris matches our iris template
alike(iris.tpl, iris[sample(1:nrow(iris), 10), ])
alike(iris.tpl, iris[c(2, 1, 3, 4, 5)]) # but column order matters
# Also works with matrices / arrays
alike(matrix(integer(), 3, 3), matrix(1:9, nrow=3)) # 3 x 3 integer
# 3 x 3, but not integer!
alike(matrix(integer(), 3, 3), matrix(runif(9), nrow=3))
# partial spec, any 3 row integer matrix
alike(matrix(integer(), 3), matrix(1:12, nrow=3))
alike(matrix(integer(), 3), matrix(1:12, nrow=4))
# Any logical matrix (but not arrays)
alike(matrix(logical()), array(rep(TRUE, 8), rep(2, 3)))
# In order for objects to be alike, they must share a family tree, not just
# a common class
obj.tpl <- structure(TRUE, class=letters[1:3])
obj.cur.1 <- structure(TRUE, class=c("x", letters[1:3]))
obj.cur.2 <- structure(TRUE, class=c(letters[1:3], "x"))
alike(obj.tpl, obj.cur.1)
alike(obj.tpl, obj.cur.2)
# You can compare language objects; these are alike if they are self
# consistent; we don't care what the symbols are, so long as they are used
# consistently across target and current:
# TRUE, symbols are consistent (adding two different symbols)
alike(quote(x + y), quote(a + b))
alike(quote(x + y), quote(a - b)) # FALSE, different function
alike(quote(x + y), quote(a + a)) # FALSE, inconsistent symbols
} )
unitizer_sect("Raw", {
# check for warning, in the future if we properly support RAW then this will
# no longer produce a warning. Really just looking for a valid STRSXP type.
alike(as.raw(integer(3)), as.raw(integer(3)))
})
unitizer_sect("Errors", {
alike(NULL, NULL, settings=vetr_settings(type.mode=3))
alike(NULL, NULL, settings=vetr_settings(attr.mode=letters))
alike(NULL, NULL, settings=vetr_settings(lang.mode=letters))
alike(NULL, NULL, settings=vetr_settings(fuzzy.int.max.len=NA_integer_))
alike(NULL, NULL, settings=vetr_settings(suppress.warnings=NA))
alike(NULL, NULL, settings=vetr_settings(env=letters))
alike(NULL, NULL, settings=vetr_settings(width=letters))
alike(NULL, NULL, settings=vetr_settings(env.depth.max=-1L))
})
unitizer_sect("Attributes", {
# There are implicit and explicit attribute checks elsewhere, this
# is just for a corner case that showed up in coverage
obj.tpl <- structure(integer(), a=integer())
obj.obj <- structure(1:10, a=1:3)
alike(obj.tpl, obj.obj)
# issue93 More corner cases from the transition to sorted attribute checks
obj.tpl.a <- structure(integer(), class='foo')
obj.obj.a <- structure(matrix(1:3))
alike(obj.tpl.a, obj.obj.a)
obj.tpl.b <- structure(matrix(integer()), class='foo')
obj.obj.b <- structure(matrix(1:3))
alike(obj.tpl.b, obj.obj.b)
obj.tpl.c <- structure(matrix(integer()), class='foo')
obj.obj.c <- structure(matrix(1:3), class='foo')
alike(obj.tpl.c, obj.obj.c)
obj.tpl.d <- structure(integer(), class='foo')
obj.obj.d <- structure(matrix(1:3), class='foo')
alike(obj.tpl.d, obj.obj.d)
obj.tpl.e <- structure(integer())
obj.obj.e <- structure(matrix(1:3), class='foo')
alike(obj.tpl.e, obj.obj.e)
obj.tpl.f <- structure(integer(), a=integer())
obj.obj.f <- structure(matrix(1:3), z=integer(), class='foo')
alike(obj.tpl.f, obj.obj.f)
obj.tpl.g <- structure(integer(), a=integer())
obj.obj.g <- structure(matrix(1:3), z=integer(), class='foo')
alike(obj.tpl.g, obj.obj.g)
obj.tpl.h <- structure(matrix(integer()))
obj.obj.h <- structure(1:3, a=integer())
alike(obj.tpl.h, obj.obj.h)
alike(obj.tpl.h, obj.obj.h, settings=vetr_settings(attr.mode=2))
obj.tpl.i <- structure(character(), a=integer(), class='boo')
obj.obj.i <- structure(matrix(1:3))
alike(obj.tpl.i, obj.obj.i)
obj.tpl.k <- integer()
obj.obj.k <- matrix(1:3)
alike(obj.tpl.k, obj.obj.k)
alike(obj.tpl.k, obj.obj.k, settings=vetr_settings(attr.mode=2))
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.