Nothing
library("testthat")
library("bit")
regtest.bit <- function(
N = 50 # number of repetitions for random regression tests
)
{
#.BITS <- bit:::.BITS # available in package namespace
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."=as.integer(NA), "Max."=as.integer(NA)) )
}
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 <- sample(pool, n2, TRUE)
l[j] <- new
b[j] <- new
if (!identical(l, unattr(b[]))){
message("\nregression test difference when replacing with index")
OK <- FALSE
}
# check replacement (recycle)
if (n%%2){
new <- sample(pool, 1)
l[] <- new
b[] <- new
}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
}
context("old regression test")
test_that("old regtest is still OK", {
expect_identical(regtest.bit(), TRUE)
})
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_equivalent(as.bit(TRUE)[c(2, 1, 0, 1, NA)], TRUE[c(2, 1, 0, 1, NA)])
expect_equivalent(as.bitwhich(TRUE)[c(2, 1, 0, 1, NA)], TRUE[c(2, 1, 0, 1, NA)])
expect_identical({b <- as.bit(FALSE); b[0] <- TRUE; as.logical(b)}, {l <- FALSE; l[0] <- TRUE; l})
expect_identical({w <- as.bitwhich(FALSE); w[0] <- TRUE; as.logical(w)}, {l <- FALSE; l[0] <- TRUE; l})
expect_identical({b <- as.bit(FALSE); b[2] <- TRUE; as.logical(b)}, {l <- FALSE; l[2] <- TRUE; l})
expect_identical({w <- as.bitwhich(FALSE); w[2] <- TRUE; as.logical(w)}, {l <- FALSE; l[2] <- TRUE; l})
expect_identical({b <- as.bit(FALSE); b[bit:::.BITS+1] <- NA; as.logical(b)}, {l <- FALSE; l[bit:::.BITS+1] <- FALSE; l[is.na(l)]<- FALSE; l})
expect_identical({w <- as.bitwhich(FALSE); w[bit:::.BITS+1] <- NA; as.logical(w)}, {l <- FALSE; l[bit:::.BITS+1] <- FALSE; l[is.na(l)]<- FALSE; l})
expect_equivalent(as.bit(rep(c(FALSE,TRUE), bit:::.BITS))[TRUE], rep(c(FALSE,TRUE), bit:::.BITS)[TRUE], label="subscripting with scalar TRUE")
expect_equivalent(as.bitwhich(rep(c(FALSE,TRUE), bit:::.BITS))[TRUE], rep(c(FALSE,TRUE), bit:::.BITS)[TRUE], label="subscripting with scalar TRUE")
expect_equivalent(as.bit(rep(c(FALSE,TRUE), bit:::.BITS))[FALSE], rep(c(FALSE,TRUE), bit:::.BITS)[FALSE], label="subscripting with scalar FALSE")
expect_equivalent(as.bitwhich(rep(c(FALSE,TRUE), bit:::.BITS))[FALSE], rep(c(FALSE,TRUE), bit:::.BITS)[FALSE], 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.