tests/testthat/test-apply.R

In jmbarbone/jordan: Miscellaneous, Analytic R Kernels

times <- function(x, n = 2L) {
  x * n
}

test_that("vap_int()", {
  expect_equal(
    vapply(1:10, times, integer(1)),
    vap_int(1:10, times)
  )

  # Adds names
  expect_equal(
    names(vap_int(1:10, times, .nm = TRUE)),
    as.character(1:10)
  )

  x <- 1:10
  names(x) <- letters[1:10]
  expect_equal(
    names(vap_int(x, times, .nm = TRUE)),
    letters[1:10]
  )
})


test_that("vap_dbl()", {
  expect_equal(
    vapply(1:10, times, n = 2, double(1)),
    vap_dbl(1:10, times)
  )

  # Adds names
  expect_equal(
    names(vap_dbl(1:10, times, n = 2, .nm = TRUE)),
    as.character(1:10)
  )

  x <- 1:10
  names(x) <- letters[1:10]
  expect_equal(
    names(vap_dbl(x, times, n = 2, .nm = TRUE)),
    letters[1:10]
  )
})

test_that("vap_cplx()", {
  foo <- function(x) {
    x + 1i
  }

  expect_equal(
    vapply(1:10, foo, complex(1)),
    vap_cplx(1:10, foo)
  )

  # Adds names
  expect_equal(
    names(vap_cplx(1:10, foo, .nm = TRUE)),
    as.character(1:10)
  )

  x <- 1:10
  names(x) <- letters[1:10]
  expect_equal(
    names(vap_cplx(x, foo, .nm = TRUE)),
    letters[1:10]
  )
})

test_that("vap_chr()", {
  foo <- function(x) {
    letters[x]
  }

  expect_equal(
    vapply(1:10, foo, character(1)),
    vap_chr(1:10, foo)
  )

  # Adds names
  expect_equal(
    names(vap_chr(1:10, foo, .nm = TRUE)),
    as.character(1:10)
  )

  x <- 1:10
  names(x) <- letters[1:10]
  expect_equal(
    names(vap_chr(x, foo, .nm = TRUE)),
    letters[1:10]
  )
})

test_that("vap_date", {
  foo <- function(x) {
    Sys.Date() + x
  }

  expect_s3_class(
    vap_date(1:10, foo),
    "Date"
  )

  # Adds names
  expect_equal(
    names(vap_date(1:10, foo, .nm = TRUE)),
    as.character(1:10)
  )

  x <- 1:10
  names(x) <- letters[1:10]
  expect_equal(
    names(vap_date(x, foo, .nm = TRUE)),
    letters[1:10]
  )
})

test_that("vap_lgl()", {
  foo <- function(x) {
    c(FALSE, TRUE)[x %% 2 + 1]
  }

  expect_equal(
    vapply(1:10, foo, logical(1)),
    vap_lgl(1:10, foo)
  )

  # Adds names
  expect_equal(
    names(vap_lgl(1:10, foo, .nm = TRUE)),
    as.character(1:10)
  )

  x <- 1:10
  names(x) <- letters[1:10]
  expect_equal(
    names(vap_lgl(x, foo, .nm = TRUE)),
    letters[1:10]
  )
})

test_that("capply()", {
  nm <- c("one", "two", "three")
  x <- set_names(1:3, nm)
  res0 <- c(1, 4, 9)
  res1 <- set_names(res0, nm)
  foo <- function(x) x^2

  # Should appropriately set names
  expect_equal(capply(x, foo, .nm = FALSE), res0)
  expect_equal(capply(x, foo, .nm = TRUE),  res1)

  # Combines full lists
  x <- list(c(1:3), NA_real_, 4, 5, NULL, 6:7)
  res <- c(1, 4, 9, NA, 16, 25, 36, 49)
  expect_equal(capply(x, foo), res)
})


# slappy ------------------------------------------------------------------

test_that("slapply()", {
  x <- 1:10
  foo <- function(i) i^i

  res <- slapply(x, foo, .names = FALSE)
  exp <- foo(x)
  expect_identical(res, exp)

  res <- slapply(x, foo)
  exp <- set_names(x^x, x)
  expect_identical(res, exp)

  res <- slapply(x, foo, .simplify = TRUE)
  exp <- simplify2array(exp)
  expect_identical(res, exp)

  x <- set_names(x)
  res <- slapply(x, foo)
  exp <- set_names(x^x, x)
  expect_identical(res, exp)
})