tests/testthat/test-hop.R

In DavisVaughan/slurrr: Sliding Window Functions

test_that("trivial case works", {
  expect_equal(
    hop(1:2, 1:2, 1:2, ~.x),
    list(1L, 2L)
  )
})

test_that(".starts and .stops don't have to be ascending", {
  expect_equal(hop(1:5, c(2, 1), c(3, 2), identity), list(2:3, 1:2))
})

test_that(".starts must be before .stops", {
  expect_snapshot({
    (expect_error(hop(1:5, c(2, 3, 1), c(1, 1, 2), identity)))
    (expect_error(hop(1:5, c(2, 3, 1), c(1, 1, 2), identity)))
  })
})

test_that("empty input returns a list", {
  expect_equal(hop(integer(), integer(), integer(), ~.x), list())
})

test_that("empty `.x`, but size `n > 0` `.starts` and `.stops` returns size `n` empty ptype", {
  expect_equal(hop(integer(), 1:2, 2:3, ~.x), list(integer(), integer()))
})

test_that("empty `.x`, but size `n > 0` `.starts` and `.stops`: sizes and types are checked first", {
  expect_snapshot({
    (expect_error(hop(integer(), 1:3, 1:2, ~.x), class = "vctrs_error_incompatible_size"))
    (expect_error(hop(integer(), 1, "x", ~.x), class = "vctrs_error_subscript_type"))
  })
})

test_that(".starts must not contain NA values", {
  expect_snapshot({
    (expect_error(hop(1:2, c(1, NA), 1:2, identity), class = "slider_error_endpoints_cannot_be_na"))
    (expect_error(hop(1:2, c(NA, 1), 1:2, identity), class = "slider_error_endpoints_cannot_be_na"))
  })
})

test_that(".stops must not contain NA values", {
  expect_snapshot({
    (expect_error(hop(1:2, 1:2, c(1, NA), identity), class = "slider_error_endpoints_cannot_be_na"))
    (expect_error(hop(1:2, 1:2, c(NA, 1), identity), class = "slider_error_endpoints_cannot_be_na"))
  })
})

test_that("recycling is used for .starts/.stops", {
  expect_equal(
    hop(1:2, 1, 1:2, ~.x),
    list(
      1L,
      1:2
    )
  )

  expect_equal(
    hop(1:2, 1:2, 2, ~.x),
    list(
      1:2,
      2L
    )
  )

  expect_snapshot({
    expect_error(hop(1:2, 1:2, 1:3, ~.x), class = "vctrs_error_incompatible_size")
  })
})

test_that("0 length .starts/.stops are allowed", {
  expect_equal(hop(1, integer(), integer(), ~.x), list())
})

test_that("output size is the common size of .starts/.stops", {
  expect_equal(
    hop(1:5, 1, 2, ~.x),
    list(1:2)
  )

  expect_equal(
    hop(1:2, c(1, 1, 2), c(1, 2, 2), ~.x),
    list(1L, 1:2, 2L)
  )
})

test_that("out of bounds .starts/.stops result in size-0 slices", {
  expect_equal(
    hop(1:2, 3, 4, ~.x),
    list(integer())
  )

  expect_equal(
    hop(1:2, c(3, 4), c(4, 6), ~.x),
    list(integer(), integer())
  )
})

test_that("negative / 0 out of bounds .starts/.stops result in size-0 slices", {
  expect_equal(
    hop(1:2, c(-1, 4), c(0, 6), ~.x),
    list(integer(), integer())
  )

  expect_equal(
    hop(1:2, c(-1, 1, 4), c(0, 2, 6), ~.x),
    list(integer(), 1:2, integer())
  )
})

test_that("duplicated .starts/.stops pairs are allowed", {
  expect_equal(
    hop(1:4, c(1, 2, 2), c(2, 2, 2), ~.x),
    list(
      1:2,
      2L,
      2L
    )
  )
})

test_that("`.starts` and `.stops` must be integerish", {
  expect_snapshot({
    (expect_error(hop(1, "x", 1, identity), class = "vctrs_error_subscript_type"))
    (expect_error(hop(1, 1, "x", identity), class = "vctrs_error_subscript_type"))
  })
})

test_that("`error_call` and `.error_call` args aren't swallowed", {
  fn <- function(x, error_call) {
    abort("hi", call = error_call)
  }
  fn_dot <- function(x, .error_call) {
    abort("hi", call = .error_call)
  }

  expect_snapshot(error = TRUE, {
    hop(1, 1, 1, fn, error_call = call("foo"))
  })
  expect_snapshot(error = TRUE, {
    hop(1, 1, 1, fn_dot, .error_call = call("foo"))
  })
})

# ------------------------------------------------------------------------------
# input names

test_that("names exist on inner sliced elements", {
  names <- letters[1:5]
  x <- set_names(1:5, names)
  exp <- as.list(names)
  expect_equal(hop(x, 1:5, 1:5, ~names(.x)), exp)
})

test_that("names are never placed on the output", {
  x <- set_names(1:5, letters[1:5])
  expect_null(names(hop(x, 1:5, 1:5, ~.x)))
})