test-expr-kernel.R
In basetable: Fast and Memory-Efficient Base R Table Manipulation

test_that("bt_compile_expr only accepts the supported grammar", {
  d <- data.frame(a = 1:3, b = 4:6, c = 7:9, s = letters[1:3])
  expect_null(bt_compile_expr(quote(sqrt(a)), d))    # unknown function
  expect_null(bt_compile_expr(quote(a + z), d))      # z not a column
  expect_null(bt_compile_expr(quote(a %in% b), d))   # unsupported op
  expect_null(bt_compile_expr(quote("x"), d))        # string literal
  expect_null(bt_compile_expr(quote(s == a), d))     # string column
  expect_type(bt_compile_expr(quote(a > 1 & b < c), d), "list")
  expect_type(bt_compile_expr(quote(ifelse(a > 0, b, -c)), d), "list")
})

test_that("subset() gives identical results through the native kernel and eval()", {
  df <- as.data.frame(iris)
  df$flag <- df$Sepal.Length > 5

  preds <- list(
    quote(Sepal.Length > 5),
    quote(Sepal.Length >= 5 & Petal.Width < 1),
    quote((Sepal.Length - Sepal.Width) / Petal.Length > 2),
    quote(Sepal.Length * 2 <= Petal.Length + 8),
    quote(!flag | Petal.Length > 4),
    quote(flag & !(Sepal.Width > 3)),
    quote(Sepal.Length %% 2 > 0.5),
    quote(ifelse(flag, Petal.Length, Petal.Width) > 3),
    quote(-Sepal.Width + Sepal.Length > 2)
  )

  for (p in preds) {
    kernel <- eval(bquote(subset(df, .(p))))
    r <- eval(p, df, parent.frame())
    r[is.na(r)] <- FALSE
    manual <- df[r, , drop = FALSE]
    expect_equal(as.data.frame(kernel), manual, ignore_attr = TRUE, info = deparse(p))
  }
})

test_that("kernel matches eval() on NA propagation and three-valued logic", {
  df <- data.frame(
    x = c(1, NA, 3, 4, NA),
    y = c(NA, 2, 3, NA, 5),
    b = c(TRUE, NA, FALSE, TRUE, NA)
  )
  for (p in list(quote(x > 2), quote(x > 2 & y < 4), quote(x > 2 | y < 4),
                 quote(b | x > 3), quote(b & y > 1), quote(!b))) {
    plan <- basetable:::bt_compile_expr(p, df)
    r_kernel <- .Call(basetable:::bt_expr_, df, plan$code, plan$args, plan$consts, FALSE)
    r_eval <- eval(p, df)
    expect_identical(r_kernel, r_eval, info = deparse(p))
  }
})

test_that("subset() still errors when the predicate is not logical", {
  df <- data.frame(x = 1:5)
  expect_error(subset(df, subset = x + 1), "logical vector")
})

test_that("the single-comparison fast path matches the general kernel and eval()", {
  df <- data.frame(a = c(1, NA, 3, 4, 5), b = c(5, 4, NA, 2, 1))
  for (p in list(quote(a > b), quote(a >= 2), quote(3 < a), quote(a == b),
                 quote(a != b), quote(a <= b), quote(b > a))) {
    fast <- eval(bquote(basetable::subset(df, .(p))))
    r <- eval(p, df); r[is.na(r)] <- FALSE
    expect_equal(as.data.frame(fast), df[r, , drop = FALSE],
                 ignore_attr = TRUE, info = deparse(p))
  }
})

test_that("two-comparison AND fast path matches eval()", {
  df <- data.frame(a = c(1, NA, 3, 4, 5, 6), b = c(6, 5, NA, 3, 2, 1),
                   c = c(0, 1, 2, 3, 4, 5))
  for (p in list(quote(a > 2 & b < 5), quote(a >= b & c < 4),
                 quote(a < 5 & b > 1), quote(a != c & b >= 2),
                 quote(3 < a & c <= 3))) {
    fast <- eval(bquote(basetable::subset(df, .(p))))
    r <- eval(p, df); r[is.na(r)] <- FALSE
    expect_equal(as.data.frame(fast), df[r, , drop = FALSE],
                 ignore_attr = TRUE, info = deparse(p))
  }
})

test_that("parallel stream compaction in subset() is correct", {
  skip_on_cran()
  set.seed(3)
  n <- 1.5e6
  d <- data.frame(x = rnorm(n), i = sample(1:9, n, TRUE),
                  s = sample(letters, n, TRUE), stringsAsFactors = FALSE)
  old <- getOption("basetable.threads"); on.exit(options(basetable.threads = old), add = TRUE)
  options(basetable.threads = 8L)
  a <- as.data.frame(subset(d, x > 0.3))
  options(basetable.threads = 1L)
  b <- as.data.frame(subset(d, x > 0.3))
  expect_identical(a, b)
  m <- d$x > 0.3
  ref <- d[m, , drop = FALSE]; rownames(ref) <- NULL; rownames(a) <- NULL
  expect_equal(a, ref)
})

test_that("fused filter kernel: threaded and serial agree, and match eval()", {
  skip_on_cran()
  set.seed(11)
  n <- 1.2e6
  d <- data.frame(
    x = rnorm(n), y = rnorm(n),
    k = sample(1:5, n, TRUE),
    s = sample(letters, n, TRUE),
    stringsAsFactors = FALSE
  )
  d$x[sample(n, 1000)] <- NA
  old <- getOption("basetable.threads")
  on.exit(options(basetable.threads = old), add = TRUE)
  for (p in list(quote(x > 0.5), quote(x > 0 & y < 0), quote(0.2 < x & y <= 0.3))) {
    options(basetable.threads = 8L)
    a <- as.data.frame(eval(bquote(basetable::subset(d, .(p)))))
    options(basetable.threads = 1L)
    b <- as.data.frame(eval(bquote(basetable::subset(d, .(p)))))
    expect_identical(a, b, info = deparse(p))
    r <- eval(p, d); r[is.na(r)] <- FALSE
    ref <- d[r, , drop = FALSE]; rownames(ref) <- NULL
    expect_equal(a, ref, ignore_attr = TRUE, info = deparse(p))
  }
})

test_that("fused filter honours select and drops NA rows like base subset()", {
  set.seed(12)
  d <- data.frame(x = c(rnorm(50), NA, NA), g = sample(letters[1:3], 52, TRUE),
                  id = 1:52, stringsAsFactors = FALSE)
  out <- as.data.frame(basetable::subset(d, x > 0, select = c("g", "id")))
  ref <- d[d$x > 0 & !is.na(d$x), c("g", "id"), drop = FALSE]; rownames(ref) <- NULL
  expect_equal(out, ref, ignore_attr = TRUE)
})

test_that("fused filter handles integer and logical columns", {
  d <- data.frame(
    i = c(1L, 2L, NA_integer_, 4L, 5L),
    flag = c(TRUE, FALSE, NA, TRUE, FALSE),
    x = seq_len(5)
  )
  cases <- list(
    quote(i > 2L),
    quote(2L < i & i <= 5L),
    quote(flag == TRUE),
    quote(flag != FALSE & i >= 1L)
  )
  for (p in cases) {
    out <- as.data.frame(eval(bquote(basetable::subset(d, .(p)))))
    r <- eval(p, d); r[is.na(r)] <- FALSE
    ref <- d[r, , drop = FALSE]; rownames(ref) <- NULL
    expect_equal(out, ref, ignore_attr = TRUE, info = deparse(p))
  }
})

test_that("shapes outside the fused kernel still work via the mask path", {
  set.seed(13)
  d <- data.frame(x = rnorm(2000), y = rnorm(2000), i = sample(1:100, 2000, TRUE))
  cases <- list(quote(x > y), quote(x > 0 | y > 0), quote(abs(x) > 1))
  for (p in cases) {
    out <- as.data.frame(eval(bquote(basetable::subset(d, .(p)))))
    r <- eval(p, d); r[is.na(r)] <- FALSE
    ref <- d[r, , drop = FALSE]; rownames(ref) <- NULL
    expect_equal(out, ref, ignore_attr = TRUE, info = deparse(p))
  }
})