tests/testthat/test-tidyeval-across.R

In dtplyr: Data Table Back-End for 'dplyr'

test_that("across() translates NULL", {
  dt <- lazy_dt(data.frame(a = 1,  b = 2))

  expect_equal(
    capture_across(dt, across(a:b)),
    list(a = expr(a), b = expr(b))
  )
})

test_that("across() drops groups", {
  dt <- lazy_dt(data.frame(a = 1, b = 2))

  expect_equal(
    capture_across(group_by(dt, a), across(everything())),
    list(b = expr(b))
  )
  expect_equal(
    capture_across(group_by(dt, b), across(everything())),
    list(a = expr(a))
  )
})

test_that("across() translates functions", {
  dt <- lazy_dt(data.frame(a = 1,  b = 2))

  expect_equal(
    capture_across(dt, across(a:b, log)),
    exprs(a = log(a), b = log(b))
  )

  expect_equal(
    capture_across(dt, across(a:b, log, base = 2)),
    exprs(a = log(a, base = 2), b = log(b, base = 2))
  )

  expect_equal(
    capture_across(dt, across(a, list(log, exp))),
    exprs(a_1 = log(a), a_2 = exp(a))
  )
})

test_that("across() captures anonymous functions", {
  dt <- lazy_dt(data.frame(a = 1))

  expect_equal(
   capture_across(dt, across(a, function(x) log(x))),
   list(a = call2(function(x) log(x), quote(a)))
  )
})

test_that("dots are translated too", {
  fun <- function() {
    dt <- lazy_dt(data.frame(a = 1, b = 2))
    z <- TRUE
    capture_across(dt, across(a, mean, na.rm = z))
  }

  expect_equal(fun(), exprs(a = mean(a, na.rm = TRUE)))
})

test_that("across() translates formulas", {
  dt <- lazy_dt(data.frame(a = 1,  b = 2))

  expect_equal(
    capture_across(dt, across(a:b, ~ log(.x))),
    exprs(a = log(a), b = log(b))
  )

  # and recursively translates
  expect_equal(
    capture_across(dt, across(a, ~ .x / n())),
    exprs(a = a / .N)
  )

  expect_equal(
    capture_across(dt, across(a:b, ~2)),
    exprs(a = 2, b = 2)
  )

  expect_equal(
    capture_across(dt, across(a:b, list(~log(.x)))),
    exprs(a_1 = log(a), b_1 = log(b))
  )
})

test_that("across() does not support formulas with dots", {
  dt <- lazy_dt(data.frame(a = 1,  b = 2))

  expect_snapshot({
    (expect_error(capture_across(dt, across(a:b, ~log(.x, base = .y), base = 2))))
    (expect_error(capture_across(dt, across(a:b, list(~log(.x, base = .y)), base = 2))))
  })
})

test_that("across() gives informative errors", {
  dt <- lazy_dt(data.frame(a = 1,  b = 2))
  expect_snapshot(error = TRUE, {
    capture_across(dt, across(a, 1))
    capture_across(dt, across(a, list(1)))
  })
})

test_that("across() can use named selections", {
  dt <- lazy_dt(data.frame(x = 1, y = 2))

  # no fns
  expect_equal(
    capture_across(dt, across(c(a = x, b = y))),
    list(a = quote(x), b = quote(y))
  )
  expect_equal(
    capture_across(dt, across(all_of(c(a = "x", b = "y")))),
    list(a = quote(x), b = quote(y))
  )

  # one fn
  expect_equal(
    capture_across(dt, across(c(a = x, b = y), mean)),
    list(a = quote(mean(x)), b = quote(mean(y)))
  )
  expect_equal(
    capture_across(dt, across(all_of(c(a = "x", b = "y")), mean)),
    list(a = quote(mean(x)), b = quote(mean(y)))
  )

  # multiple fns
  expect_equal(
    capture_across(dt, across(c(a = x, b = y), list(mean, nm = sum))),
    list(
      a_1 = quote(mean(x)), a_nm = quote(sum(x)),
      b_1 = quote(mean(y)), b_nm = quote(sum(y))
    )
  )
  expect_equal(
    capture_across(dt, across(all_of(c(a = "x", b = "y")), list(mean, nm = sum))),
    list(
      a_1 = quote(mean(x)), a_nm = quote(sum(x)),
      b_1 = quote(mean(y)), b_nm = quote(sum(y))
    )
  )
})

test_that("across() can handle empty selection", {
  dt <- lazy_dt(data.table(x = 1, y = 2), "DT")

  expect_equal(
    dt %>% mutate(across(character(), c)) %>% show_query(),
    expr(DT)
  )
})

test_that("across() .cols is evaluated in across()'s calling environment", {
  dt <- lazy_dt(data.frame(y = 1))
  fun <- function(x) capture_across(dt, across(all_of(x)))
  expect_equal(
    fun("y"),
    list(y = expr(y))
  )
})

test_that("across() output can be used as a data frame", {
  df <- lazy_dt(tibble(x = 1:3, y = 1:3, z = c("a", "a", "b")))
  res <- df %>%
    mutate(across_df = rowSums(across(c(x, y), ~ .x + 1))) %>%
    collect()

  expect_named(res, c("x", "y", "z", "across_df"))
  expect_equal(res$across_df, c(4, 6, 8))

  expr <- dt_squash(expr(across(c(x, y), ~ .x + 1)), df$env, df, is_top = FALSE)
  expect_equal(expr, expr(data.table(x = x + 1, y = y + 1)))
})

test_that("pick() works", {
  df <- lazy_dt(tibble(x = 1:3, y = 1:3, z = c("a", "a", "b")))
  res <- df %>%
    mutate(row_sum = rowSums(pick(x, y))) %>%
    collect()

  expect_named(res, c("x", "y", "z", "row_sum"))
  expect_equal(res$row_sum, c(2, 4, 6))

  expr <- dt_squash(expr(pick(x, y)), df$env, df, is_top = FALSE)
  expect_equal(expr, expr(data.table(x = x, y = y)))

  # Top level pick works
  expect_equal(group_by(df, pick(x, y))$groups, c("x", "y"))
})

test_that("`across()` ignores variables in `.by`, #412", {
  dt <- lazy_dt(data.table(x = 1:3, y = c("a", "a", "b")))
  step <- dt %>%
    mutate(across(everything(), ~ .x + 1), .by = y)

  expect_equal(as_tibble(step), tibble(x = 2:4, y = c("a", "a", "b")))
  expect_true(length(step$groups) == 0)

  step <- dt %>%
    summarize(across(everything(), sum), .by = y)

  expect_equal(as_tibble(step), tibble(y = c("a", "b"), x = c(3, 3)))
})

# if_all ------------------------------------------------------------------

test_that("if_all collapses multiple expressions", {
  dt <- lazy_dt(data.frame(a = 1,  b = 2))
  expect_equal(capture_if_all(dt, if_all(everything(), is.na)), expr(is.na(a) & is.na(b)))
})

test_that("if_all works without `.fns` argument", {
  dt <- lazy_dt(data.frame(a = 1,  b = 2))
  expect_equal(capture_if_all(dt, if_all(c(a:b))), expr(a & b))
})


test_that("if_all() drops groups", {
  dt <- lazy_dt(data.frame(a = 1, b = 2))

  expect_equal(
    capture_if_all(group_by(dt, a), if_all(everything())),
    sym("b")
  )
  expect_equal(
    capture_if_all(group_by(dt, b), if_all(everything())),
    sym("a")
  )
})

test_that("if_all() translates functions", {
  dt <- lazy_dt(data.frame(a = 1,  b = 2))

  expect_equal(
    capture_if_all(dt, if_all(a:b, log)),
    expr(log(a) & log(b))
  )

  expect_equal(
    capture_if_all(dt, if_all(a:b, log, base = 2)),
    expr(log(a, base = 2) & log(b, base = 2))
  )

  expect_equal(
    capture_if_all(dt, if_all(a, list(log, exp))),
    expr(log(a) & exp(a))
  )
})

test_that("if_all() captures anonymous functions", {
  dt <- lazy_dt(data.frame(a = 1))

  expect_equal(
   capture_if_all(dt, if_all(a, function(x) log(x))),
   call2(function(x) log(x), quote(a))
  )
})

test_that("if_all() translates dots", {
  fun <- function() {
    dt <- lazy_dt(data.frame(a = 1, b = 2))
    z <- TRUE
    capture_if_all(dt, if_all(a, mean, na.rm = z))
  }

  expect_equal(fun(), expr(mean(a, na.rm = TRUE)))
})

test_that("if_all() translates formulas", {
  dt <- lazy_dt(data.frame(a = 1,  b = 2))

  expect_equal(
    capture_if_all(dt, if_all(a:b, ~ log(.x))),
    expr(log(a) & log(b))
  )

  expect_equal(
    capture_if_all(dt, if_all(a:b, ~2)),
    expr(2 & 2)
  )

  expect_equal(
    capture_if_all(dt, if_all(a:b, list(~log(.x)))),
    expr(log(a) & log(b))
  )
})

test_that("if_all() gives informative errors", {
  dt <- lazy_dt(data.frame(a = 1,  b = 2))
  expect_snapshot(error = TRUE, {
    capture_if_all(dt, if_all(a, 1))
    capture_if_all(dt, if_all(a, list(1)))
  })
})

test_that("if_all() cannot rename variables", {
  dt <- lazy_dt(data.frame(x = 1, y = 2))

  # no fns
  expect_snapshot(
    (expect_error(capture_if_all(dt, if_all(c(a = x, b = y)))))
  )
})

test_that("if_all() can handle empty selection", {
  skip("tidyselect issue #221")
  dt <- lazy_dt(data.table(x = 1, y = 2), "DT")

  expect_equal(
    dt %>% mutate(if_all(character(), c)) %>% show_query(),
    expr(DT)
  )
})

test_that("if_all() .cols is evaluated in across()'s calling environment", {
  dt <- lazy_dt(data.frame(y = 1))
  fun <- function(x) capture_if_all(dt, if_all(all_of(x)))
  expect_equal(
    fun("y"),
    expr(y)
  )
})