# 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)
set.seed(1)
unitizer_sect("Tokens Pass", {
vet(INT.1, 1)
vet(INT.1.POS, 1)
vet(INT.1.NEG, -1)
vet(INT.1.POS.STR, 1)
vet(INT.1.NEG.STR, -1)
vet(INT, -1:1)
vet(INT.POS, 0:3)
vet(INT.NEG, 0:-3)
vet(INT.POS.STR, 1:3)
vet(INT.NEG.STR, -(1:3))
vet(NUM.1, 1.44)
vet(NUM.1.POS, 1.44)
vet(NUM.1.NEG, -1.44)
vet(NUM, runif(5))
vet(NUM.POS, runif(5))
vet(NUM.NEG, -runif(5))
vet(CHR, character())
vet(CHR.1, "hello")
vet(CHR, letters)
vet(CPX, 1:10 + .5i)
vet(CPX.1, 1 + .5i)
vet(LGL, c(TRUE, FALSE))
vet(LGL.1, TRUE)
} )
unitizer_sect("Tokens Fail", {
vet(INT.1, 1.2)
vet(INT.1, 1:2)
vet(INT.1, NA_integer_)
vet(INT.1, Inf)
vet(INT.1.POS, -1)
vet(INT.1.POS, 1:2)
vet(INT.1.NEG, 1)
vet(INT.1.NEG, -(1:2))
vet(INT.1.POS.STR, 0)
vet(INT.1.NEG.STR, 0)
vet(INT, c(-1:1, NA_integer_))
vet(INT, letters)
vet(INT.POS, -(1:3))
vet(INT.NEG, 1:3)
vet(INT.POS.STR, 0:3)
vet(INT.NEG.STR, -(0:3))
vet(NUM.1, 1.44 + 1:2)
vet(NUM.1.POS, -runif(1) - 1)
vet(NUM.1.NEG, runif(1) + 1)
vet(NUM, c(NA_real_, 1))
vet(NUM, NULL)
vet(NUM.POS, -runif(5) - 1)
vet(NUM.NEG, runif(5) + 1)
vet(CHR.1, letters)
vet(CHR, list(1, 2, 3))
vet(CPX, list(1, 2, 3))
vet(CPX.1, list(1, 2, 3))
vet(LGL, NA)
vet(LGL, letters)
vet(LGL.1, 1:2 == 1:2)
})
unitizer_sect("Custom expressions", {
vet(. > 5, 1:10)
vet(. > 5, 6:10)
# corner cases
vet(.(c(TRUE, NA, TRUE)), 1:5)
vet(.(1:5), 1:5)
vet(.(1:5, 1:5), 1:5) # error
vet(.(list(1, 2, 3)), 1:3) # error
vet(.(c('hello world', 'goodbye moon')), 1:3)
})
unitizer_sect("Compound Expressions", {
vet(INT.1 || NULL, 1) # Pass
vet(INT.1 || NULL, NULL) # Pass
vet(INT.1 || NULL, 1.4) # Fail
vet(INT.1 || NULL || character(3L), 1) # Pass
vet(INT.1 || NULL || character(3L), 1.2) # Fail
vet(INT.1 || NULL || character(3L), letters) # Fail
# Pass
vet(
(matrix(integer(), 0) && nrow(.) == ncol(.)) || NULL,
matrix(1:16, nrow=4)
)
# Fail
vet(
(matrix(integer(), 0) && nrow(.) == ncol(.)) || NULL,
matrix(1:16, nrow=2)
)
# Fail
vet(
(matrix(integer(), 0) && nrow(.) == ncol(.)) || NULL,
matrix(runif(16), nrow=4)
)
# custom expression partially defined in parent env
exp.a <- quote(all(. > 0))
exp.b <- quote(is.vector(.))
vet(exp.a && exp.b, -(1:3))
# some testing of nesting, this could conflict with prior exp.a
# if not done properly
local({
exp.a <- quote(all(. < 0))
vet(exp.a, -(1:3))
})
# Duplicate expressions should get collapsed in error message
vet(1 || "a" || 1 || "a" || 1 || letters, 1:3)
})
unitizer_sect("Other Return Modes", {
vet(INT.1 || NULL || LGL, "hello", format="text")
vet(INT.1 || NULL || LGL, "hello", format="raw")
vet(INT.1 || NULL || LGL, "hello", format="full")
vet(INT.1 || NULL || LGL, "hello", format="halloween")
vet(INT.1 || NULL || LGL, "hello", format=1:10)
vet(INT.1 || NULL || LGL, "hello", format="text", stop=TRUE)
vet(INT.1 || NULL || LGL, "hello", format="text", stop=1:3)
})
unitizer_sect("Multi-line Stuff", {
# with a validator with message attached
vet(
NO.NA,
c(234234131431, 123413413413, 1341341341, 12341234134, 562456234, 24624624,
2452345234, 2345234524, 23452452, 2243524352, 254254234, 2452452435, NA)
)
vet(
NO.NA || !anyNA(.),
c(234234131431, 123413413413, 1341341341, 12341234134, 562456234, 24624624,
2452345234, 2345234524, 23452452, 2243524352, 254254234, 2452452435, NA)
)
# No message
vet(
!anyNA(.),
c(234234131431, 123413413413, 1341341341, 12341234134, 562456234, 24624624,
2452345234, 2345234524, 23452452, 2243524352, 254254234, 2452452435, NA)
)
vet(!anyNA(.), c(234234131431, 123413413413, NA))
# stored validation
val.exp <- quote(!anyNA(.))
vet(val.exp, c(234234131431, 123413413413, NA))
})
unitizer_sect("Embedded String Errors", {
vet(all_bw(., 0, 1), 0:5)
vet(all.equal(., 1:5), 1:6)
})
unitizer_sect("Language", {
# Note issue #18; not 100% sure this is correct, actually it should be, the
# validator expression is always substituted, and any symbols pointing to
# language are used as language.
vet(quote(quote(a + b)), quote(x2 + x3))
x <- quote(quote(a + b))
vet(x, quote(x2 + x3))
vet(quote(a + b), quote(2 + x3))
vet(quote(a + b), quote(x1 + x2 + x3))
# Test recursive substitution across environments, first check that all the
# symbols we use don't actually exist currently
unlist(lapply(c('aaA', 'bbB', 'ccC', 'ddD', 'eeE'), find))# should be length 0
x <- quote(aaA + bbB)
my.env <- new.env()
my.env$y <- quote(ccC - ddD)
# FALSE because `x` is expanded
evalq(vet(quote(x * y), quote(A * (B - C))), envir=my.env)
# TRUE because `eeE` is not expanded (but `y` is)
evalq(vet(quote(eeE * y), quote(A * (B - C))), envir=my.env)
# TRUE because expansion matches
evalq(vet(quote(x * y), quote((A + D) * (B - C))), envir=my.env)
# potentialy infinite recursion
expA <- expB <- expC <- expD <- expE <- 0
expA <- quote(expB && expC)
expB <- quote(expD * expE)
expE <- quote(expA || expD)
vet(expA, TRUE)
# check that symbols (i.e. not call) are resolved recursively too
expE <- quote(expA)
vet(expA, TRUE)
# Check that `..` is expanded properly
. <- quote(. > 0)
vet(.., 1.4)
. <- quote(numeric(1L))
vet(.., 1.5)
})
unitizer_sect("Errors", {
vet(1, 1, env="hello")
})
unitizer_sect("Custom tokens", {
cust.tok.1 <- vet_token(quote(TRUE), "%sshould be logical(1L)")
vet(cust.tok.1, TRUE)
vet(cust.tok.1, 1:2)
# impossible tokens
vet_token(quote(TRUE), "should be logical(1L)")
vet_token(quote(TRUE), letters)
# hack impossile token (`vet_token` itself wont allow it)
cust.tok.2 <- quote(. > 2)
attr(cust.tok.2, "err.msg") <- letters
vet(cust.tok.2, TRUE)
})
unitizer_sect("Result Buffer", {
# testing that result buffer expands correctly
set1 <- vetr_settings(result.list.size.init=1)
vet.exp <- quote(1 || 1:2 || 1:3 || 1:4 || 1:5 || 1:6 || 1:7 || 1:8)
vet(vet.exp, 1:8, settings=set1)
vet(vet.exp, 1:9, settings=set1)
set2 <- vetr_settings(result.list.size.init=1, result.list.size.max=7)
vet(vet.exp, 1:8, settings=set2)
vet(vet.exp, 1:9, settings=set2)
set3 <- vetr_settings(result.list.size.init=1, result.list.size.max=8)
vet(vet.exp, 1:8, settings=set3)
vet(vet.exp, 1:9, settings=set3)
# impossible settings
set4 <- vetr_settings(result.list.size.init="hello", result.list.size.max=8)
set5 <- vetr_settings(result.list.size.init=1, result.list.size.max="hello")
vet(1, 1, settings=set4)
vet(1, 1, settings=set5)
})
unitizer_sect("pkg::fun calls (issue #100)", {
vet(base::sum(.), 1:10)
vet((base::.)(identity), is.function)
vet((base::.)(identity), is.integer)
})
unitizer_sect("promises (issue #106)", {
env1 <- new.env()
delayedAssign("x", stop('error 1'), assign.env=env1)
env2 <- new.env()
delayedAssign("x", stop('error 2'), assign.env=env2)
env0 <- list2env(list(x=TRUE), new.env())
vet(env1, env0) # error 1
vet(env0, env2) # error 2
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.