Nothing
#' @param N number of repetitions for random regression tests
regtest.bit <- function(N = 50) {
OK <- TRUE
pool <- c(FALSE, TRUE)
if (!identical(unattr(as.bit(c(FALSE, NA, TRUE))[]), c(FALSE, FALSE, TRUE))) {
message("bit error: wrong coercion of triboolean to (bi)boolean")
OK <- FALSE
}
l <- TRUE
b <- as.bit(l)
i <- -c(1, 0, 1, NA)
if (!inherits(try(b[i], silent=TRUE), "try-error")) {
message("bit error: did not throw on mixing zero with negative subscripts")
OK <- FALSE
}
i <- c(2, 1, 0, 1, NA)
if (!identical(l[i], unattr(b[i]))) {
message("\nregression test difference between b[i] and l[i]")
message(l[i])
message(unattr(b[i]))
OK <- FALSE
}
l[0] <- TRUE
b[0] <- TRUE
if (!identical(l, unattr(b[]))) {
message("\nregression test difference after assigning at R position zero")
message(l)
message(unattr(b[]))
OK <- FALSE
}
l[2] <- TRUE
b[2] <- TRUE
if (!identical(ifelse(is.na(l), FALSE, l), unattr(b[]))) {
message("\nregression test difference after assigning after vector length (at 2)")
message(l)
message(unattr(b[]))
OK <- FALSE
}
l[.BITS + 1] <- FALSE
b[.BITS + 1] <- NA
if (!identical(ifelse(is.na(l), FALSE, l), unattr(b[]))) {
message("\nregression test difference after assigning after vector length (at .BITS + 1)")
message(l)
message(unattr(b[]))
OK <- FALSE
}
if (!identical(ifelse(is.na(l[TRUE]), FALSE, l[TRUE]), unattr(b[TRUE]))) {
message("\nregression test difference after subscripting with scalar TRUE")
message(l)
message(unattr(b[]))
OK <- FALSE
}
if (!identical(ifelse(is.na(l[FALSE]), FALSE, l[FALSE]), unattr(b[FALSE]))) {
message("\nregression test difference after subscripting with scalar FALSE")
message(l)
message(unattr(b[]))
OK <- FALSE
}
for (i in 1:N) {
n <- sample(1:(2 * .BITS), 1)
l <- sample(pool, n, TRUE)
# check direct coercion
b <- as.bit(l)
l2 <- as.logical(b)
if (!identical(l, l2)) {
message("\nregression test difference between logical")
message(l)
message("and as.logical(as.bit(logical))")
message(l2)
OK <- FALSE
}
# summary functions with logical return
s <- c(all=all(l), any=any(l))
s2 <- c(all=all(b), any=any(b))
if (!identical(s, s2)) {
message("\nregression test difference between logical summaries")
message(s)
message("and bit summaries")
message(s2)
OK <- FALSE
}
# summary functions with integer return
if (any(l)) {
s <- c(
min=min(as.which(l)),
max=max(as.which(l)),
range=range(as.which(l)),
sum=sum(l),
summary=c(
`FALSE`=length(l) - sum(l),
`TRUE`=sum(l),
Min.=min(as.which(l)),
Max.=max(as.which(l))
)
)
} else {
s <- c(
min=NA_integer_,
max=NA_integer_,
range=c(NA_integer_, NA_integer_),
sum=sum(l),
summary=c(
`FALSE`=length(l) - sum(l),
`TRUE`=sum(l),
Min.=NA_integer_,
Max.=NA_integer_
)
)
}
s2 <- c(min=min(b), max=max(b), range=range(b), sum=sum(b), summary=summary(b))
if (!identical(s, s2)) {
message("\nregression test difference between logical summaries")
message(s)
message("and bit summaries")
message(s2)
OK <- FALSE
}
# check positive whichs
w <- as.which(l)
w2 <- as.which(as.bit(w, n))
if (!identical(w, w2)) {
message("\nregression test difference between which")
message(w)
message("and as.which(as.bit.which(which))")
message(w2)
OK <- FALSE
}
# check automatic whichs (pos or neg whatever shorter)
s <- sum(l)
if (s == 0) {
w <- FALSE
} else if (s == n) {
w <- TRUE
} else if (s > n %/% 2L) {
w <- -rev(which(!l))
} else {
w <- which(l)
}
w2 <- as.vector(as.bitwhich(as.bit(l)))
if (!identical(w, w2)) {
message("\nregression test difference between which")
message(w)
message("and as.which(as.bit.which(which))")
message(w2)
OK <- FALSE
}
# check boolean operators
l2 <- sample(c(FALSE, TRUE), n, TRUE)
b2 <- as.bit(l2)
ops <- c(
NOT = identical(!l, as.logical(!b))
, AND = identical(l & l2, as.logical(b & b2))
, OR = identical(l | l2, as.logical(b | b2))
, XOR = identical(xor(l, l2), as.logical(xor(b, b2)))
, NEQ = identical(l != l2, as.logical(b != b2))
, EQ = identical(l == l2, as.logical(b == b2))
)
if (!all(ops)) {
message("\nbit differs for boolean operators(s)")
message(ops)
message(cbind(l=l, l2=l))
OK <- FALSE
}
w <- as.bitwhich(l)
w2 <- as.bitwhich(l2)
ops <- c(
NOT = identical(!l, as.logical(!w))
, AND = identical(l & l2, as.logical(w & w2))
, OR = identical(l | l2, as.logical(w | w2))
, XOR = identical(xor(l, l2), as.logical(xor(w, w2)))
, NEQ = identical(l != l2, as.logical(w != w2))
, EQ = identical(l == l2, as.logical(w == w2))
)
if (!all(ops)) {
message("\nbitwhich differs for boolean operators(s)")
message(ops)
message(cbind(l=l, l2=l))
OK <- FALSE
}
rm(l2, b2, w2)
# check extractors
n2 <- sample(1:n, 1)
j <- sample(1:n, n2)
if (!identical(l[j], unattr(b[j]))) {
message("\nregression test difference when extracting")
OK <- FALSE
}
# check replacement (index)
new_value <- sample(pool, n2, TRUE)
l[j] <- new_value
b[j] <- new_value
if (!identical(l, unattr(b[]))) {
message("\nregression test difference when replacing with index")
OK <- FALSE
}
# check replacement (recycle)
if (n %% 2) {
new_value <- sample(pool, 1)
l[] <- new_value
b[] <- new_value
} else {
l[] <- pool
b[] <- pool
}
if (!identical(l, as.logical(b))) {
message("\nregression test difference when replacing with recylcling")
OK <- FALSE
}
}
l0 <- c(FALSE, FALSE, FALSE)
l1 <- c(FALSE, FALSE, TRUE)
l2 <- c(FALSE, TRUE, TRUE)
l3 <- c(TRUE, TRUE, TRUE)
bw0 <- as.bitwhich(l0)
bw1 <- as.bitwhich(l1)
bw2 <- as.bitwhich(l2)
bw3 <- as.bitwhich(l3)
OK <- OK && identical(l0, as.logical(bw0))
OK <- OK && identical(l1, as.logical(bw1))
OK <- OK && identical(l2, as.logical(bw2))
OK <- OK && identical(l3, as.logical(bw3))
OK <- OK && identical(l0 & l0, as.logical(bw0 & bw0))
OK <- OK && identical(l0 & l1, as.logical(bw0 & bw1))
OK <- OK && identical(l0 & l2, as.logical(bw0 & bw2))
OK <- OK && identical(l0 & l3, as.logical(bw0 & bw3))
OK <- OK && identical(l1 & l0, as.logical(bw1 & bw0))
OK <- OK && identical(l1 & l1, as.logical(bw1 & bw1))
OK <- OK && identical(l1 & l2, as.logical(bw1 & bw2))
OK <- OK && identical(l1 & l3, as.logical(bw1 & bw3))
OK <- OK && identical(l2 & l0, as.logical(bw2 & bw0))
OK <- OK && identical(l2 & l1, as.logical(bw2 & bw1))
OK <- OK && identical(l2 & l2, as.logical(bw2 & bw2))
OK <- OK && identical(l2 & l3, as.logical(bw2 & bw3))
OK <- OK && identical(l3 & l0, as.logical(bw3 & bw0))
OK <- OK && identical(l3 & l1, as.logical(bw3 & bw1))
OK <- OK && identical(l3 & l2, as.logical(bw3 & bw2))
OK <- OK && identical(l3 & l3, as.logical(bw3 & bw3))
OK <- OK && identical(l0 | l0, as.logical(bw0 | bw0))
OK <- OK && identical(l0 | l1, as.logical(bw0 | bw1))
OK <- OK && identical(l0 | l2, as.logical(bw0 | bw2))
OK <- OK && identical(l0 | l3, as.logical(bw0 | bw3))
OK <- OK && identical(l1 | l0, as.logical(bw1 | bw0))
OK <- OK && identical(l1 | l1, as.logical(bw1 | bw1))
OK <- OK && identical(l1 | l2, as.logical(bw1 | bw2))
OK <- OK && identical(l1 | l3, as.logical(bw1 | bw3))
OK <- OK && identical(l2 | l0, as.logical(bw2 | bw0))
OK <- OK && identical(l2 | l1, as.logical(bw2 | bw1))
OK <- OK && identical(l2 | l2, as.logical(bw2 | bw2))
OK <- OK && identical(l2 | l3, as.logical(bw2 | bw3))
OK <- OK && identical(l3 | l0, as.logical(bw3 | bw0))
OK <- OK && identical(l3 | l1, as.logical(bw3 | bw1))
OK <- OK && identical(l3 | l2, as.logical(bw3 | bw2))
OK <- OK && identical(l3 | l3, as.logical(bw3 | bw3))
OK <- OK && identical(xor(l0, l0), as.logical(xor(bw0, bw0)))
OK <- OK && identical(xor(l0, l1), as.logical(xor(bw0, bw1)))
OK <- OK && identical(xor(l0, l2), as.logical(xor(bw0, bw2)))
OK <- OK && identical(xor(l0, l3), as.logical(xor(bw0, bw3)))
OK <- OK && identical(xor(l1, l0), as.logical(xor(bw1, bw0)))
OK <- OK && identical(xor(l1, l1), as.logical(xor(bw1, bw1)))
OK <- OK && identical(xor(l1, l2), as.logical(xor(bw1, bw2)))
OK <- OK && identical(xor(l1, l3), as.logical(xor(bw1, bw3)))
OK <- OK && identical(xor(l2, l0), as.logical(xor(bw2, bw0)))
OK <- OK && identical(xor(l2, l1), as.logical(xor(bw2, bw1)))
OK <- OK && identical(xor(l2, l2), as.logical(xor(bw2, bw2)))
OK <- OK && identical(xor(l2, l3), as.logical(xor(bw2, bw3)))
OK <- OK && identical(xor(l3, l0), as.logical(xor(bw3, bw0)))
OK <- OK && identical(xor(l3, l1), as.logical(xor(bw3, bw1)))
OK <- OK && identical(xor(l3, l2), as.logical(xor(bw3, bw2)))
OK <- OK && identical(xor(l3, l3), as.logical(xor(bw3, bw3)))
OK <- OK && identical(c(l0, l0), as.logical(c(bw0, bw0)))
OK <- OK && identical(c(l0, l1), as.logical(c(bw0, bw1)))
OK <- OK && identical(c(l0, l2), as.logical(c(bw0, bw2)))
OK <- OK && identical(c(l0, l3), as.logical(c(bw0, bw3)))
OK <- OK && identical(c(l1, l0), as.logical(c(bw1, bw0)))
OK <- OK && identical(c(l1, l1), as.logical(c(bw1, bw1)))
OK <- OK && identical(c(l1, l2), as.logical(c(bw1, bw2)))
OK <- OK && identical(c(l1, l3), as.logical(c(bw1, bw3)))
OK <- OK && identical(c(l2, l0), as.logical(c(bw2, bw0)))
OK <- OK && identical(c(l2, l1), as.logical(c(bw2, bw1)))
OK <- OK && identical(c(l2, l2), as.logical(c(bw2, bw2)))
OK <- OK && identical(c(l2, l3), as.logical(c(bw2, bw3)))
OK <- OK && identical(c(l3, l0), as.logical(c(bw3, bw0)))
OK <- OK && identical(c(l3, l1), as.logical(c(bw3, bw1)))
OK <- OK && identical(c(l3, l2), as.logical(c(bw3, bw2)))
OK <- OK && identical(c(l3, l3), as.logical(c(bw3, bw3)))
N <- 2L * .BITS
l <- logical(N)
b <- bit(N)
for (i in 1:N) {
l[i] <- TRUE
b[i] <- TRUE
if (!identical(l, as.logical(b))) {
message("\nregression test difference when replacing at position", i, "")
OK <- FALSE
}
}
OK
}
test_that("old regtest is still OK", {
expect_true(regtest.bit())
})
test_that("some old regression tests are also OK for bitwhich", {
expect_error(TRUE[c(-1, 1)], label="positive mixed with zeros")
expect_error(as.bit(TRUE)[c(-1, 1)], label="positive mixed with zeros")
expect_error(as.bitwhich(TRUE)[c(-1, 1)], label="positive mixed with zeros")
expect_error(TRUE[c(-1, NA)], label="NA mixed with zeros")
expect_error(as.bit(TRUE)[c(-1, NA)], label="NA mixed with zeros")
expect_error(as.bitwhich(TRUE)[c(-1, NA)], label="NA mixed with zeros")
expect_identical(
as.bit(TRUE)[c(2, 1, 0, 1, NA)],
TRUE[c(2, 1, 0, 1, NA)],
ignore_attr="vmode"
)
expect_identical(
as.bitwhich(TRUE)[c(2, 1, 0, 1, NA)],
TRUE[c(2, 1, 0, 1, NA)],
ignore_attr="vmode"
)
l = FALSE
l[0L] = TRUE
b = as.bit(FALSE)
b[0L] = TRUE
expect_identical(as.logical(b), l)
w = as.bitwhich(FALSE)
w[0L] = TRUE
expect_identical(as.logical(w), l)
l = FALSE
l[2L] = TRUE
b = as.bit(FALSE)
b[2L] = TRUE
expect_identical(as.logical(b), l)
w = as.bitwhich(FALSE)
w[2L] = TRUE
expect_identical(as.logical(w), l)
l = FALSE
l[.BITS + 1L] = FALSE
l[is.na(l)] = FALSE
b = as.bit(FALSE)
b[.BITS + 1L] = NA
expect_identical(as.logical(b), l)
w = as.bitwhich(FALSE)
w[.BITS + 1L] = NA
expect_identical(as.logical(w), l)
expect_identical(
as.bit(rep(c(FALSE, TRUE), .BITS))[TRUE],
rep(c(FALSE, TRUE), .BITS)[TRUE],
ignore_attr="vmode",
label="subscripting with scalar TRUE"
)
expect_identical(
as.bitwhich(rep(c(FALSE, TRUE), .BITS))[TRUE],
rep(c(FALSE, TRUE), .BITS)[TRUE],
ignore_attr="vmode",
label="subscripting with scalar TRUE"
)
expect_identical(
as.bit(rep(c(FALSE, TRUE), .BITS))[FALSE],
rep(c(FALSE, TRUE), .BITS)[FALSE],
ignore_attr="vmode",
label="subscripting with scalar FALSE"
)
expect_identical(
as.bitwhich(rep(c(FALSE, TRUE), .BITS))[FALSE],
rep(c(FALSE, TRUE), .BITS)[FALSE],
ignore_attr="vmode",
label="subscripting with scalar FALSE"
)
})
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.