# 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("Single template validation", {
fun0 <- function(x, y, z)
vetr(x=matrix(integer(), ncol=3), y=integer(2L), z=logical(1L))
fun0(1, 2, 3)
fun0(matrix(1), 2, 3)
fun0(matrix(1:3, nrow=1), 2, 3)
fun0(matrix(1:3, nrow=1), 2:3, 3)
fun0(matrix(1:3, nrow=1), c(2.0, 3.0), 3) # integer like
fun0(matrix(1:3, nrow=1), c(2.0, 3.0), TRUE)
})
unitizer_sect("Multi-template validation", {
fun1 <- function(x, y, z)
vetr(
x=matrix(integer(), ncol=3) || integer(3L),
y=integer(2L) || NULL || logical(1L),
z=logical(1L)
)
fun1(1:3, "fail", "fail") # x passes
fun1(matrix(1:9, ncol=3), "fail", "fail") # x passes
fun1(letters[1:3], "fail", "fail") # x fails
fun1(1:3, 1:2, "fail") # x,y pass
fun1(1:3, NULL, "fail") # x,y pass
fun1(1:3, FALSE, "fail") # x,y pass
fun1(1:3, FALSE, FALSE) # all pass
})
unitizer_sect("Template and Straight Eval", {
fun2 <- function(x, y, z)
vetr(
x=(matrix(integer(), ncol=3) || integer(3L)) && .(!any(is.na(.))),
y=integer(3L) && .(all(. > 0)),
z=logical(1L) && .(!is.na(.))
)
fun2(matrix(c(1:8, NA), nrow=3), NULL, NULL)
fun2(matrix(c(1:9), nrow=3), -1:1, NULL)
fun2(matrix(c(1:9), nrow=3), 1:3, NA)
fun2(matrix(c(1:9), nrow=3), 1:3, TRUE)
})
unitizer_sect("Complex OR outcomes", {
fun2a <- function(x)
vetr(
x=setNames(character(3L), letters[1:3]) || matrix("", 3, 1) ||
list(character(), x=integer())
)
fun2a(letters[1:3])
})
unitizer_sect("Errors in Arguments", {
fun3 <- function(x, y)
vetr(x=logical(1L), y=integer(3L))
fun3(stop("boom"))
fun3(TRUE, stop("boomBOOM"))
fun3(1:3, stop("boomBOOM"))
fun4 <- function(x, y)
vetr(x=stop("BOOM"), y=integer(3L))
fun4(NULL, 1:3)
fun5 <- function(x, y)
vetr(x=integer(3L), y=NULL || .(stop("hah")))
fun5(1:3, NULL)
fun5(1:2, NULL)
fun6 <- function(x, y)
vetr(x=integer(3L), y=NULL && .(stop("hah")))
fun6(1:3, NULL)
})
unitizer_sect("Args evaled in correct env?", {
fun7 <- function(x, y=z + 2) { z <- "boom"; vetr(x=TRUE, y=1L) }
fun7a <- function(x, y=z + 2) { z <- 40; vetr(x=TRUE, y=1L) }
z <- 1
fun7(TRUE) # fail because z in fun is character
fun7a(TRUE) # works
fun8 <- function(x, y=z + 2) { a <- b <- TRUE; vetr(x=TRUE, y=1L) }
fun8a <- function(x, y=z + 2) { a <- b <- NULL; vetr(x=TRUE, y=1L) }
a <- NULL
b <- TRUE
fun8(a && b) # fail because a in parent is NULL
a <- TRUE
fun8a(a && b) # works despite NULLs in function
# Make sure we can access defined templates in lexical parents
fun_make <- function() {
a <- matrix(1:9, 3)
tpl <- matrix(numeric(), 3)
function(x) {
vetr(tpl)
TRUE
}
}
fun <- fun_make()
a <- b <- 1:9
local({
NULL
a <- character()
fun(a)
})
local({
b <- character()
fun(b)
})
# make sure we can access variables that are not in fun lexical scope
fun8b <- function(x) vetr(x=length(.) > 0 && integer())
get("zfqwefkj") # should fail
local({
zfqwefkj <- 200L
fun8b(zfqwefkj)
})
})
unitizer_sect("Compound Expression Scope Issues", {
a <- quote(!anyNA(.))
fun <- function(x) {
a <- quote(all(. > 0))
b <- quote(is.vector(.))
vetr(a && b)
TRUE
}
fun(-(1:3))
})
unitizer_sect("Non-equal args and validation exps", {
fun8 <- function(x="hello", y=TRUE, z)
vetr(x=integer(), z=integer(2L))
fun8(1L, NULL, 1:2)
fun8(1L, 1:2, NULL)
fun8(1L, 1:2)
fun8(1L)
# default argument fails validation
fun8(z=1:2)
})
unitizer_sect("Referencing argument in vet exp error", {
fun1 <- function(x, y) vetr(x > 0, . < 3)
fun1(1:10, 1:10)
fun2 <- function(x, y) vetr(. > 0 && all(y > 0), y < 3)
fun2(TRUE, 1:10)
# also check with vet, although not as important
x <- 1:10
vet(x > 0, x)
vet((x + 1) > 0, x + 1) # this doesn't cause error, but maybe should?
})
unitizer_sect("Default arg mix-up", {
fun10a <- function(x, y=TRUE, z=999) vetr(INT, LGL.1, INT.1)
fun10a(1, z=1:3)
fun10b <- function(x, y=TRUE, z=999) vetr(INT, z=INT.1)
fun10b(1, z=1:3)
})
unitizer_sect("Dots", {
f <- function(x, y=1L, z=1L, ...) vetr(1L, 1L, 1L)
f(2L, w=3L)
f <- function(x, y=1L, ...) vetr(1L, 1L, 1L)
f(2L, z=3L)
})
unitizer_sect("Don't access promises in environments", {
fenv <- function(env) vetr(environment())
env <- FALSE
fenv(environment())
})
unitizer_sect("Invocation via `do.call` (#109)", {
f <- function(x) vetr(is.function(.))
do.call(f, list(mean))
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.