tests/testthat/test-tidyeval.R

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

test_that("simple expressions left as is", {
  dt <- lazy_dt(data.frame(x = 1:10, y = 1:10))

  expect_equal(capture_dot(dt, NULL), NULL)
  expect_equal(capture_dot(dt, 10), 10)
  expect_equal(capture_dot(dt, x), quote(x))
  expect_equal(capture_dot(dt, x + y), quote(x + y))
  expect_equal(capture_dot(dt, x[[1]]), quote(x[[1]]))

  # logicals
  expect_equal(eval(capture_dot(dt, T), globalenv()), TRUE)
  expect_equal(eval(capture_dot(dt, F), globalenv()), FALSE)
  expect_equal(capture_dot(dt, TRUE), TRUE)
  expect_equal(capture_dot(dt, FALSE), FALSE)
})

test_that("existing non-variables get inlined", {
  dt <- lazy_dt(data.frame(x = 1:10, y = 1:10))

  n <- 10
  expect_equal(capture_dot(dt, x + n), quote(x + 10))
  expect_equal(capture_dot(dt, x + m), quote(x + m))
  # even if they start with "." (#386)
  .n <- 20
  expect_equal(capture_dot(dt, x + .n), quote(x + 20))
})

test_that("unless we're operating in the global environment", {
  dt <- lazy_dt(data.frame(x = 1:10, y = 1:10))
  quo <- new_quosure(quote(x + n), globalenv())

  expect_equal(capture_dot(dt, !!quo), quote(x + ..n))
  expect_equal(capture_dot(dt, !!quo, j = FALSE), quote(x + n))
})

test_that("ignores accessor calls, #434", {
  df <- tibble(length = 1)

  step <- lazy_dt(tibble(x = 1:3), "DT") %>%
    mutate(y = df$length)

  expect_equal(show_query(step), expr(copy(DT)[, `:=`(y = df$length)]))

  step <- lazy_dt(tibble(x = 1:3), "DT") %>%
    mutate(y = df[["length"]])

  expect_equal(show_query(step), expr(copy(DT)[, `:=`(y = df[["length"]])]))
})

test_that("using environment of inlined quosures", {
  dt <- lazy_dt(data.frame(x = 1:10, y = 1:10))

  n <- 10
  quo <- new_quosure(quote(x + n), env(n = 20))

  expect_equal(capture_dot(dt, f(!!quo)), quote(f(x + 20)))
  expect_equal(capture_dot(dt, f(!!quo), j = FALSE), quote(f(x + 20)))
})

test_that(". gets converted to .SD", {
  dt <- lazy_dt(data.frame(x = 1:10, y = 1:10))

  expect_equal(capture_dot(dt, .), quote(.SD))
  expect_equal(capture_dot(dt, .SD), quote(.SD))
})

test_that("translate context functions", {
  dt <- lazy_dt(data.frame(x = 1:10, y = 1:10))
  expect_equal(capture_dot(dt, cur_data()), quote(.SD))
  expect_error(capture_dot(dt, cur_data_all()), "not available")
  expect_equal(capture_dot(dt, cur_group()), quote(.BY))
  expect_equal(capture_dot(dt, cur_group_id()), quote(.GRP))
  expect_equal(capture_dot(dt, cur_group_rows()), quote(.I))
})


test_that("translates if_else()/ifelse()", {
  df <- data.frame(x = 1:5)

  expect_equal(
    capture_dot(df, ifelse(x < 0, 1, 2)),
    expr(fifelse(x < 0, 1, 2))
  )
  expect_equal(
    capture_dot(df, if_else(x < 0, 1, 2)),
    expr(fifelse(x < 0, 1, 2))
  )

  # Handles unusual argument names/order
  suppressWarnings({
    expect_equal(
      capture_dot(df, ifelse(x < 0, n = 2, yes = 1)),
      expr(fifelse(x < 0, 1, 2))
    )
    expect_equal(
      capture_dot(df, if_else(x < 0, f = 2, true = 1)),
      expr(fifelse(x < 0, 1, 2))
    )
  })


  # tidyeval works inside if_else, #220
  expect_equal(
    capture_dot(df,  if_else(.data$x < 3, 1, 2)),
    expr(fifelse(x < 3, 1, 2))
  )
})

test_that("translates coalesce()", {
  df <- data.frame(x = 1:5)
  expect_equal(
    capture_dot(df, coalesce(x, 1)),
    expr(fcoalesce(x, 1))
  )
})

test_that("can use local variable with coalesce() and replace_na()", {
  dt <- lazy_dt(data.frame(x = c(1, NA)), "dt")
  n <- 10
  expect_equal(
    capture_dot(dt, coalesce(x, n)),
    expr(fcoalesce(x, 10))
  )
  expect_equal(
    capture_dot(dt, replace_na(x, n)),
    expr(fcoalesce(x, 10))
  )
})

test_that("translates case_when()", {
  dt <- lazy_dt(data.frame(x = 1:10, y = 1:10))

  expect_equal(
    capture_dot(dt, case_when(x1 ~ y1, x2 ~ y2, x3 ~ TRUE, TRUE ~ y4)),
    quote(fcase(x1, y1, x2, y2, x3, TRUE, rep(TRUE, .N), y4))
  )

  # can use T for default, #272
  expect_equal(
    capture_dot(dt, case_when(x1 ~ y1, x2 ~ y2, x3 ~ TRUE, T ~ y4)),
    quote(fcase(x1, y1, x2, y2, x3, TRUE, rep(TRUE, .N), y4))
  )

  # can use `.default` and `.default` doesn't need to be in last position, #429
  expect_equal(
    capture_dot(dt, case_when(x1 ~ y1, x2 ~ y2, .default = y4, x3 ~ TRUE)),
    quote(fcase(x1, y1, x2, y2, x3, TRUE, rep(TRUE, .N), y4))
  )

  # translates recursively
  expect_equal(
    capture_dot(dt, case_when(x == 1 ~ n())),
    quote(fcase(x == 1, .N))
  )

  # Errors on `.ptype`
  expect_error(
    capture_dot(dt, case_when(x1 ~ y1, .ptype = double()))
  )

  # Errors on `.size`
  expect_error(
    capture_dot(dt, case_when(x1 ~ y1, .size = 1))
  )
})

test_that("translates case_match()", {
  dt <- lazy_dt(data.frame(x = 1:5))

  # Works without `.default`
  expect_equal(
    capture_dot(dt, case_match(x, c(1, 2) ~ 1, 3 ~ 2)),
    quote(fcase(x %in% c(1, 2), 1, x == 3, 2))
  )

  # Works with `.default`
  expect_equal(
    capture_dot(dt, case_match(x, c(1, 2) ~ 1, 3 ~ 2, .default = 3)),
    quote(fcase(x %in% c(1, 2), 1, x == 3, 2, rep(TRUE, .N), 3))
  )
})

test_that("translates lag()/lead()", {
  df <- data.frame(x = 1:5, y = 1:5)
  expect_equal(
    capture_dot(df, lag(.data$x)),
    expr(shift(x, type = "lag"))
  )
  expect_equal(
    capture_dot(df, lead(x, 2, default = 3)),
    expr(shift(x, n = 2, fill = 3, type = "lead"))
  )
  # Errors with order_by
  expect_snapshot_error(
    capture_dot(df, lag(x, order_by = y)),
  )
})

test_that("can use local variable with lag()/lead()", {
  dt <- lazy_dt(data.frame(x = c(1, NA)), "dt")
  n <- 10
  expect_equal(
    capture_dot(dt, lag(x, n)),
    expr(shift(x, n = 10, type = "lag"))
  )
})

test_that("can process many expressions in one go", {
  dt <- lazy_dt(data.frame(x = 1:10, y = 1:10))
  n <- 10
  dots <- capture_dots(dt, x = x + n, y = y)
  expect_named(dots, c("x", "y"))
  expect_equal(dots$x, quote(x + 10))
})

test_that("can use anonymous functions", {
  dt <- lazy_dt(data.frame(x = 1:2, y = 1))

  expect_equal(
    capture_dot(dt, x = sapply(x, function(x) x)) %>% deparse(),
    "sapply(x, function(x) x)"
  )
})

test_that("can splice a data frame", {
  df <- data.frame(b = rep(2, 3), c = rep(3, 3))
  dots <- capture_dots(df, !!!df)
  expect_equal(dots, as.list(df))
})

test_that("can use glue, (#344)", {
  df <- data.table(a = letters[1:3], b = letters[1:3])
  expect_equal(
    capture_dot(df, glue::glue("{a}_{b}")),
    quote(glue::glue("{a}_{b}", .envir = .SD))
  )
  expect_equal(
    capture_dot(df, glue::glue("{a}_{b}"), j = FALSE),
    quote(glue::glue("{a}_{b}"))
  )

  out <- df %>%
    transmute(a_b = glue::glue("{a}_{b}")) %>%
    collect()
  expect_equal(out$a_b, c("a_a", "b_b", "c_c"))
})

test_that("properly handles anonymous functions, #362", {
  df <- data.table(a = list(1, 1, 1))
  expect_equal(
    capture_dot(df, sapply(a, function(x) x + n())),
    quote(sapply(a, function(x) x + .N))
  )
})

test_that("translates `consecutive_id()`", {
  df <- data.frame(x = 1:5, y = 1:5)
  expect_equal(
    capture_dot(df, consecutive_id(x, y)),
    expr(rleid(x, y))
  )
})

# evaluation --------------------------------------------------------------

test_that("can access functions in local env", {
  dt <- lazy_dt(data.frame(g = c(1, 1, 2), x = 1:3))
  f <- function(x) 100

  expect_equal(dt %>% summarise(n = f()) %>% pull(), 100)
})

test_that("can disambiguate using .data and .env", {
  dt <- lazy_dt(data.frame(x = 1))
  x <- 2

  expect_equal(capture_dot(dt, .data$x), quote(x))
  expect_equal(capture_dot(dt, .env$x), quote(..x))

  out <- dt %>% summarise(data = .data$x, env = .env$x) %>% as_tibble()
  expect_equal(out, tibble(data = 1, env = 2))

  var <- "x"
  out <- dt %>% summarise(data = .data[[var]], env = .env[[var]]) %>% collect()
  expect_equal(out, tibble(data = 1, env = 2))
})

test_that("locals are executed before call", {
  dt <- lazy_dt(data.frame(x = 1, y = 2))

  expect_equal(
    dt %>% step_locals(exprs(a = 1, b = 2, c = a + b), "c") %>% dt_eval(),
    3
  )
})

test_that("errors when `where()` is used, #271/#368", {
  dt <- lazy_dt(data.frame(x = 1, y = 2))
  expect_snapshot_error(
    select(dt, where(is.numeric))
  )
  expect_snapshot_error(
    mutate(dt, across(!where(is.character), ~ .x + 1))
  )
})

# dplyr verbs -------------------------------------------------------------

test_that("n() is equivalent to .N", {
  dt <- lazy_dt(data.frame(g = c(1, 1, 2), x = 1:3))

  expect_equal(
    dt %>% summarise(n = n()) %>% pull(),
    3L
  )
  expect_equal(
    dt %>% group_by(g) %>% summarise(n = n()) %>% pull(),
    c(2L, 1L)
  )
})

test_that("row_number() is equivalent seq_len(.N)", {
  dt <- lazy_dt(data.frame(g = c(1, 1, 2), x = 1:3))

  expect_equal(
    dt %>% mutate(n = row_number()) %>% pull(),
    1:3L
  )
  expect_equal(
    dt %>% group_by(g) %>% mutate(n = row_number()) %>% pull(),
    c(1:2, 1)
  )
})

test_that("row_number(x) is equivalent to rank", {
  dt <- lazy_dt(data.frame(x = c(10, 30, 20)))
  expect_equal(
    dt %>% mutate(n = row_number(x)) %>% pull(),
    c(1L, 3L, 2L)
  )
})

test_that("ranking functions are translated", {
  df <- lazy_dt(tibble(x = c(1, 2, NA, 1, 0, NaN)))

  res <- df %>%
    mutate(percent_rank = percent_rank(x),
           min_rank = min_rank(x),
           dense_rank = dense_rank(x),
           cume_dist = cume_dist(x))

  expect_equal(pull(res, percent_rank), c(1 / 3, 1, NA, 1 / 3, 0, NA))
  expect_equal(pull(res, min_rank), c(2L, 4L, NA, 2L, 1L, NA))
  expect_equal(pull(res, dense_rank), c(2L, 3L, NA, 2L, 1L, NA))
  expect_equal(pull(res, cume_dist), c(.75, 1, NA, .75, .25, NA))
})

test_that("scoped verbs produce nice output", {
  dt <- lazy_dt(data.table(x = 1:5), "DT")

  expect_equal(
    dt %>% summarise_all(mean) %>% show_query(),
    expr(DT[, .(x = mean(x))])
  )
  expect_equal(
    dt %>% summarise_all(~ mean(.)) %>% show_query(),
    expr(DT[, .(x = mean(x))])
  )

  expect_equal(
    dt %>% summarise_all(row_number) %>% show_query(),
    expr(DT[, .(x = frank(x, ties.method = "first", na.last = "keep"))])
  )
  expect_equal(
    dt %>% summarise_all(~ n()) %>% show_query(),
    expr(DT[, .(x = .N)])
  )
})

test_that("non-Gforce verbs work", {
  dt <- lazy_dt(data.table(x = 1:2), "DT")
  add <- function(x) sum(x)

  expect_equal(dt %>% summarise_at(vars(x), add) %>% pull(), 3)
  expect_equal(dt %>% mutate_at(vars(x), add) %>% pull(), c(3, 3))
})

test_that("`desc(col)` is translated to `-col` inside arrange", {
  dt <- lazy_dt(data.table(x = c("a", "b")), "DT")
  step <- arrange(dt, desc(x))
  out <- collect(step)

  expect_equal(show_query(step), expr(DT[order(-x)]))
  expect_equal(out$x, c("b", "a"))

  # Can namespace `desc()`
  step <- arrange(dt, dplyr::desc(x))
  out <- collect(step)

  expect_equal(show_query(step), expr(DT[order(-x)]))
  expect_equal(out$x, c("b", "a"))
})

test_that("desc() checks the number of arguments", {
  expect_snapshot(error = TRUE, capture_dot(df, desc(a, b)))
})

test_that("n_distinct() is translated to uniqueN()", {
  # Works with multiple inputs
  expect_equal(
    dt_squash(expr(n_distinct(c(1, 1, 2), c(1, 2, 1)))),
    expr(uniqueN(data.table(c(1, 1, 2), c(1, 2, 1))))
  )
  # Works with single column selection (in summarise())
  expect_equal(
    dt_squash(expr(n_distinct(x))),
    expr(uniqueN(x))
  )
  dt <- lazy_dt(data.table(x = c("a", "a", "b", NA)), "DT")
  step <- summarise(dt, num = n_distinct(x, na.rm = TRUE))
  out <- collect(step)
  expect_equal(
    show_query(step),
    expr(DT[, .(num = uniqueN(x, na.rm = TRUE))])
  )
  expect_equal(out$num, 2)
})

# fun_name ----------------------------------------------------------------

test_that("finds name of functions with GForce implementations", {
  expect_equal(fun_name(mean), expr(mean))

  # unless overridden
  mean <- function() {}
  expect_equal(fun_name(mean), NULL)
})