tests/testthat/test-old-regtest.R

In bit: Classes and Methods for Fast Memory-Efficient Boolean Selections

#' @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"
  )
})