tests/testthat/test-map.R

In purrr: Functional Programming Tools

test_that("preserves names", {
  out <- map(list(x = 1, y = 2), identity)
  expect_equal(names(out), c("x", "y"))
})

test_that("creates simple call", {
  out <- map(1, function(x) sys.call())[[1]]
  expect_equal(out, quote(.f(.x[[i]], ...)))
})

test_that("fails on non-vectors", {
  expect_snapshot(map(environment(), identity), error = TRUE)
  expect_snapshot(map(quote(a), identity), error = TRUE)
})

test_that("works with vctrs records (#963)", {
  x <- new_rcrd(list(x = c(1, 2), y = c("a", "b")))
  out <- list(new_rcrd(list(x = 1, y = "a")), new_rcrd(list(x = 2, y = "b")))
  expect_identical(map(x, identity), out)
})

test_that("works with matrices/arrays (#970)", {
  expect_identical(
    map_int(matrix(1:4, nrow = 2), identity),
    1:4
  )
})

test_that("all inform about location of problem", {
  fail_at_3 <- function(x, bad) {
    if (x == 3) bad else x
  }

  expect_snapshot(error = TRUE, {
    map_int(1:3, ~ fail_at_3(.x, 2:1))
    map_int(1:3, ~ fail_at_3(.x, "x"))
    map(1:3, ~ fail_at_3(.x, stop("Doesn't work")))
  })

  cnd <- catch_cnd(map(1:3, ~ fail_at_3(.x, stop("Doesn't work"))))
  expect_s3_class(cnd, "purrr_error_indexed")
  expect_equal(cnd$location, 3)
  expect_equal(cnd$name, NULL)
})

test_that("error location uses name if present", {
  fail_at_3 <- function(x, bad) {
    if (x == 3) bad else x
  }

  expect_snapshot(error = TRUE, {
    map_int(c(a = 1, b = 2, c = 3), ~ fail_at_3(.x, stop("Error")))
    map_int(c(a = 1, b = 2, 3), ~ fail_at_3(.x, stop("Error")))
  })

  cnd <- catch_cnd(map(c(1, 2, c = 3), ~ fail_at_3(.x, stop("Doesn't work"))))
  expect_s3_class(cnd, "purrr_error_indexed")
  expect_equal(cnd$location, 3)
  expect_equal(cnd$name, "c")
})

test_that("0 length input gives 0 length output", {
  expect_equal(map(list(), identity), list())
  expect_equal(map(NULL, identity), list())

  expect_equal(map_lgl(NULL, identity), logical())
})

test_that("map() always returns a list", {
  expect_bare(map(mtcars, mean), "list")
})

test_that("types automatically coerced correctly", {
  expect_identical(map_lgl(c(NA, 0, 1), identity), c(NA, FALSE, TRUE))

  expect_identical(map_int(c(NA, FALSE, TRUE), identity), c(NA, 0L, 1L))
  expect_identical(map_int(c(NA, 1, 2), identity), c(NA, 1L, 2L))

  expect_identical(map_dbl(c(NA, FALSE, TRUE), identity), c(NA, 0, 1))
  expect_identical(map_dbl(c(NA, 1L, 2L), identity), c(NA, 1, 2))

  expect_identical(map_chr(NA, identity), NA_character_)
})

test_that("logical and integer NA become correct double NA", {
  expect_identical(
    map_dbl(list(NA, NA_integer_), identity),
    c(NA_real_, NA_real_)
  )
})

test_that("map forces arguments in same way as base R", {
  f_map <- map(1:2, function(i) function(x) x + i)
  f_base <- lapply(1:2, function(i) function(x) x + i)

  expect_equal(f_map[[1]](0), f_base[[1]](0))
  expect_equal(f_map[[2]](0), f_base[[2]](0))
})

test_that("walk is used for side-effects", {
  expect_output(walk(1:3, str))
})

test_that("primitive dispatch correctly", {
  local_bindings(.env = global_env(),
    as.character.test_class = function(x) "dispatched!"
  )
  x <- structure(list(), class = "test_class")
  expect_identical(map(list(x, x), as.character), list("dispatched!", "dispatched!"))
})

test_that("map() with empty input copies names", {
  named_list <- named(list())
  expect_identical(    map(named_list, identity), named(list()))
  expect_identical(map_lgl(named_list, identity), named(lgl()))
  expect_identical(map_int(named_list, identity), named(int()))
  expect_identical(map_dbl(named_list, identity), named(dbl()))
  expect_identical(map_chr(named_list, identity), named(chr()))
})


# map_vec -----------------------------------------------------------------

test_that("still iterates using [[", {
  df <- data.frame(x = 1, y = 2, z = 3)
  expect_equal(map_vec(df, length), c(x = 1, y = 1, z = 1))
})

test_that("requires output be length 1 and have common type", {
  expect_snapshot(error = TRUE, {
    map_vec(1:2, ~ rep(1, .x))
    map_vec(1:2, ~ if (.x == 1) factor("x") else 1)
  })
})

test_that("row-binds data frame output", {
  out <- map_vec(1:2, ~ data.frame(x = .x))
  expect_equal(out, data.frame(x = 1:2))
})

test_that("concatenates list output", {
  out <- map_vec(1:2, ~ list(.x))
  expect_equal(out, list(1, 2))
})

test_that("can enforce .ptype", {
  expect_snapshot(error = TRUE, {
    map_vec(1:2, ~ factor("x"), .ptype = integer())
  })
})