However, the goal of purrr is not to try and simulate a purer functional programming language in R; we don’t want to implement a second-class version of Haskell in R. The goal is to give you similar expressiveness to an FP language, while allowing you to write code that looks and works like R:
Instead of point free (tacit) style, we use the pipe, %>%, to write code that can be read from left to right.
Instead of currying, we use ... to pass in extra arguments.
Anonymous functions are verbose in R, so we provide two convenient shorthands. For unary functions, ~ .x + 1 is equivalent to function(.x) .x + 1. For chains of transformations functions, . %>% f() %>% g() is equivalent to function(.) . %>% f() %>% g() (this shortcut is provided by magrittr).
R is weakly typed, so we need map variants that describe the output type (like map_int(), map_dbl(), etc) because don’t the return type of .f.
R has named arguments, so instead of providing different functions for minor variations (e.g. detect() and detectLast()) we use a named argument, .right. Type-stable functions are easy to reason about so additional arguments will never change the type of the output.
purrr/inst/doc/other-langs.Rmd 0000644 0001762 0000144 00000004060 13124217327 016037 0 ustar ligges users ---
title: "Functional programming in other languages"
output: rmarkdown::html_vignette
vignette: >
%\VignetteIndexEntry{Functional programming in other languages}
%\VignetteEngine{knitr::rmarkdown}
%\VignetteEncoding{UTF-8}
---
purrr draws inspiration from many related tools:
* List operations defined in the Haskell [prelude][haskell]
* Scala's [list methods][scala].
* Functional programming librarys for javascript:
[underscore.js](http://underscorejs.org),
[lodash](https://lodash.com) and
[lazy.js](http://danieltao.com/lazy.js/).
* [rlist](http://renkun.me/rlist/), another R package to support working
with lists. Similar goals but somewhat different philosophy.
However, the goal of purrr is not to try and simulate a purer functional programming language in R; we don't want to implement a second-class version of Haskell in R. The goal is to give you similar expressiveness to an FP language, while allowing you to write code that looks and works like R:
* Instead of point free (tacit) style, we use the pipe, `%>%`, to write code
that can be read from left to right.
* Instead of currying, we use `...` to pass in extra arguments.
* Anonymous functions are verbose in R, so we provide two convenient shorthands.
For unary functions, `~ .x + 1` is equivalent to `function(.x) .x + 1`.
For chains of transformations functions, `. %>% f() %>% g()` is
equivalent to `function(.) . %>% f() %>% g()` (this shortcut is provided
by magrittr).
* R is weakly typed, so we need `map` variants that describe the output type
(like `map_int()`, `map_dbl()`, etc) because don't the return type of `.f`.
* R has named arguments, so instead of providing different functions for
minor variations (e.g. `detect()` and `detectLast()`) we use a named
argument, `.right`. Type-stable functions are easy to reason about so
additional arguments will never change the type of the output.
[scala]:http://www.scala-lang.org/api/current/index.html#scala.collection.immutable.List
[haskell]:http://hackage.haskell.org/package/base-4.7.0.1/docs/Prelude.html#g:11
purrr/tests/ 0000755 0001762 0000144 00000000000 13171650762 012576 5 ustar ligges users purrr/tests/testthat.R 0000644 0001762 0000144 00000000066 12465413273 014562 0 ustar ligges users library(testthat)
library(purrr)
test_check("purrr")
purrr/tests/testthat/ 0000755 0001762 0000144 00000000000 13171733547 014441 5 ustar ligges users purrr/tests/testthat/test-utils.R 0000644 0001762 0000144 00000001456 13124217327 016676 0 ustar ligges users context("utils")
test_that("%@% is an infix attribute accessor", {
expect_identical(mtcars %@% "names", attr(mtcars, "names"))
})
test_that("rbernoulli is a special case of rbinom", {
set.seed(1)
x <- rbernoulli(10)
set.seed(1)
y <- ifelse(rbinom(10, 1, 0.5) == 1, TRUE, FALSE)
expect_equal(x, y)
})
test_that("rdunif works", {
expect_length(rdunif(100, 10), 100)
})
test_that("rdunif fails if a and b are not unit length numbers", {
expect_error(rdunif(1000, 1, "a"))
expect_error(rdunif(1000, 1, c(0.5, 0.2)))
expect_error(rdunif(1000, FALSE, 2))
expect_error(rdunif(1000, c(2, 3), 2))
})
test_that("has_names returns vector of logicals", {
expect_equal(has_names(letters %>% set_names()), rep_along(letters, TRUE))
expect_equal(has_names(letters), rep_along(letters, FALSE))
})
purrr/tests/testthat/test-pluck.R 0000644 0001762 0000144 00000007764 13137651733 016673 0 ustar ligges users context("pluck")
test_that("contents must be a vector", {
expect_error(pluck(quote(x), list(1)), "Don't know how to pluck")
})
# pluck vector --------------------------------------------------------------
test_that("can pluck by position", {
x <- list("a", 1, c(TRUE, FALSE))
# double
expect_identical(pluck(x, list(1)), x[[1]])
expect_identical(pluck(x, list(2)), x[[2]])
expect_identical(pluck(x, list(3)), x[[3]])
# integer
expect_identical(pluck(x, list(1L)), x[[1]])
expect_identical(pluck(x, list(2L)), x[[2]])
expect_identical(pluck(x, list(3L)), x[[3]])
})
test_that("can pluck by name", {
x <- list(a = "a", b = 1, c = c(TRUE, FALSE))
expect_identical(pluck(x, list("a")), x[["a"]])
expect_identical(pluck(x, list("b")), x[["b"]])
expect_identical(pluck(x, list("c")), x[["c"]])
})
test_that("can pluck from atomic vectors", {
expect_identical(pluck(TRUE, list(1)), TRUE)
expect_identical(pluck(1L, list(1)), 1L)
expect_identical(pluck(1, list(1)), 1)
expect_identical(pluck("a", list(1)), "a")
})
test_that("can pluck by name and position", {
x <- list(a = list(list(b = 1)))
expect_equal(pluck(x, list("a", 1, "b")), 1)
})
test_that("require length 1 vectors", {
expect_error(pluck(1, list(letters)), "must have length 1")
expect_error(pluck(1, list(TRUE)), "must be a character or numeric")
})
test_that("special indexes never match", {
x <- list(a = 1, b = 2, c = 3)
expect_null(pluck(x, list(NA_character_)))
expect_null(pluck(x, list("")))
expect_null(pluck(x, list(NA_integer_)))
expect_null(pluck(x, list(NA_real_)))
expect_null(pluck(x, list(NaN)))
expect_null(pluck(x, list(Inf)))
expect_null(pluck(x, list(-Inf)))
})
test_that("special values return NULL", {
# unnamed input
expect_null(pluck(list(1, 2), list("a")))
# zero length input
expect_null(pluck(integer(), list(1)))
# past end
expect_null(pluck(1:4, list(10)))
expect_null(pluck(1:4, list(10L)))
})
test_that("handles weird names", {
x <- list(1, 2, 3, 4, 5)
names(x) <- c("a", "a", NA, "", "b")
expect_equal(pluck(x, list("a")), 1)
expect_equal(pluck(x, list("b")), 5)
expect_null(pluck(x, list("")))
expect_null(pluck(x, list(NA_character_)))
})
# closures ----------------------------------------------------------------
test_that("can pluck attributes", {
x <- structure(
list(
structure(
list(),
x = 1
)
),
y = 2
)
expect_equal(pluck(x, list(attr_getter("y"))), 2)
expect_equal(pluck(x, list(1, attr_getter("x"))), 1)
})
test_that("attr_getter() evaluates eagerly", {
getters <- list_len(2)
attrs <- c("foo", "bar")
for (i in seq_along(attrs)) {
getters[[i]] <- attr_getter(attrs[[i]])
}
x <- set_attrs(list(), foo = "foo", bar = "bar")
expect_identical(getters[[1]](x), "foo")
})
test_that("delegate error handling to Rf_eval()", {
expect_error(pluck(letters, list(function() NULL)), "unused argument")
expect_error(pluck(letters, list(function(x, y) y)), "missing, with no default")
})
# environments ------------------------------------------------------------
test_that("pluck errors with invalid indices", {
expect_error(pluck(environment(), list(1)), "not a string")
expect_error(pluck(environment(), list(letters)), "not a string")
})
test_that("pluck returns missing with missing index", {
expect_equal(pluck(environment(), list(NA_character_)), NULL)
})
test_that("plucks by name", {
env <- new.env(parent = emptyenv())
env$x <- 10
expect_equal(pluck(env, list("x")), 10)
})
# S4 ----------------------------------------------------------------------
newA <- methods::setClass("A", list(a = "numeric", b = "numeric"))
A <- newA(a = 1, b = 10)
test_that("pluck errors with invalid indices", {
expect_error(pluck(A, list(1)), "not a string")
expect_error(pluck(A, list(letters)), "not a string")
})
test_that("pluck returns missing with missing index", {
expect_equal(pluck(A, list(NA_character_)), NULL)
})
test_that("plucks by name", {
expect_equal(pluck(A, list("a")), 1)
})
purrr/tests/testthat/test-splice.R 0000644 0001762 0000144 00000001011 13124217327 017000 0 ustar ligges users context("splice")
test_that("predicate controls which elements get spliced", {
x <- list(1, 2, list(3, 4))
expect_equal(splice_if(x, ~ FALSE), x)
expect_equal(splice_if(x, is.list), list(1, 2, 3, 4))
})
test_that("splice() produces correctly named lists", {
inputs <- list(arg1 = "a", arg2 = "b")
out1 <- splice(inputs, arg3 = c("c1", "c2"))
expect_named(out1, c("arg1", "arg2", "arg3"))
out2 <- splice(inputs, arg = list(arg3 = 1, arg4 = 2))
expect_named(out2, c("arg1", "arg2", "arg3", "arg4"))
})
purrr/tests/testthat/test-output.R 0000644 0001762 0000144 00000001773 13137651733 017107 0 ustar ligges users context("output")
test_that("safely has NULL error when successful", {
out <- safely(log10)(10)
expect_equal(out, list(result = 1, error = NULL))
})
test_that("safely has NULL result on failure", {
out <- safely(log10)("a")
expect_equal(out$result, NULL)
expect_equal(out$error$message,
"non-numeric argument to mathematical function")
})
test_that("quietly captures output", {
f <- function() {
cat(1)
message(2, appendLF = FALSE)
warning(3)
4
}
expect_output(quietly(f)(), NA)
expect_message(quietly(f)(), NA)
expect_warning(quietly(f)(), NA)
out <- quietly(f)()
expect_equal(out, list(
result = 4,
output = "1",
warnings = "3",
messages = "2"
))
})
test_that("possibly returns default value on failure", {
expect_identical(possibly(log, NA_real_)("a"), NA_real_)
})
test_that("auto_browse() not intended for primitive functions", {
expect_error(auto_browse(log)(NULL), "primitive functions")
expect_error(auto_browse(identity)(NULL), NA)
})
purrr/tests/testthat/test-as-mapper.R 0000644 0001762 0000144 00000004233 13137651733 017426 0 ustar ligges users context("as_mapper")
# formulas ----------------------------------------------------------------
test_that("can refer to first argument in three ways", {
expect_equal(map_dbl(1, ~ . + 1), 2)
expect_equal(map_dbl(1, ~ .x + 1), 2)
expect_equal(map_dbl(1, ~ ..1 + 1), 2)
})
test_that("can refer to second arg in two ways", {
expect_equal(map2_dbl(1, 2, ~ .x + .y + 1), 4)
expect_equal(map2_dbl(1, 2, ~ ..1 + ..2 + 1), 4)
})
# vectors --------------------------------------------------------------
# test_that(".null generates warning", {
# expect_warning(map(1, 2, .null = NA), "`.null` is deprecated")
# })
test_that(".default replaces absent values", {
x <- list(
list(a = 1, b = 2, c = 3),
list(a = 1, c = 2),
NULL
)
expect_equal(map_dbl(x, 3, .default = NA), c(3, NA, NA))
expect_equal(map_dbl(x, "b", .default = NA), c(2, NA, NA))
})
test_that(".default replaces elements with length 0", {
x <- list(
list(a = 1),
list(a = NULL),
list(a = numeric())
)
expect_equal(map_dbl(x, "a", .default = NA), c(1, NA, NA))
})
test_that("Additional arguments are ignored", {
expect_equal(as_mapper(function() NULL, foo = "bar", foobar), function() NULL)
})
test_that("can supply length > 1 vectors", {
expect_identical(as_mapper(1:2)(list(list("a", "b"))), "b")
expect_identical(as_mapper(c("a", "b"))(list(a = list("a", b = "b"))), "b")
})
# primitive functions --------------------------------------------------
test_that("primitive functions are wrapped", {
expect_identical(as_mapper(`-`)(.y = 10, .x = 5), -5)
expect_identical(as_mapper(`c`)(1, 3, 5), c(1, 3, 5))
})
test_that("syntactic primitives are wrapped", {
expect_identical(as_mapper(`[[`)(mtcars, "cyl"), mtcars$cyl)
expect_identical(as_mapper(`$`)(mtcars, cyl), mtcars$cyl)
})
# lists ------------------------------------------------------------------
test_that("lists are wrapped", {
mapper_list <- as_mapper(list("mpg", 5))(mtcars)
base_list <- mtcars[["mpg"]][[5]]
expect_identical(mapper_list, base_list)
})
test_that("raw and complex types aren't supported for indexing", {
expect_error(as_mapper(1)(raw(2)))
expect_error(as_mapper(1)(complex(2)))
})
purrr/tests/testthat/test-head-tail.R 0000644 0001762 0000144 00000000640 13124217327 017360 0 ustar ligges users context("head-tail")
y <- 1:100
test_that("head_while works", {
expect_length(head_while(y, function(x) x <= 15), 15)
})
test_that("tail_while works", {
expect_length(tail_while(y, function(x) x >= 86), 15)
})
test_that("original vector returned if predicate satisfied by all elements", {
expect_identical(head_while(y, function(x) x <= 100), y)
expect_identical(tail_while(y, function(x) x >= 0), y)
})
purrr/tests/testthat/test-list-modify-update.R 0000644 0001762 0000144 00000004322 13137651733 021260 0 ustar ligges users context("list_modify")
# list_modify -------------------------------------------------------------
test_that("named lists have values replaced by name", {
expect_equal(list_modify(list(a = 1), b = 2), list(a = 1, b = 2))
expect_equal(list_modify(list(a = 1), a = 2), list(a = 2))
expect_equal(list_modify(list(a = 1, b = 2), b = NULL), list(a = 1))
})
test_that("unnamed lists are replaced by position", {
expect_equal(list_modify(list(3), 1, 2), list(1, 2))
expect_equal(list_modify(list(1, 2, 3), 4), list(4, 2, 3))
expect_equal(list_modify(list(1, 2, 3), NULL, NULL), list(3))
})
test_that("error if one named and the other is not", {
expect_error(
list_modify(list(a = 1), 2),
"must be either both named or both unnamed"
)
})
test_that("lists are replaced recursively", {
expect_equal(
list_modify(
list(a = list(x = 1)),
a = list(x = 2)
),
list(a = list(x = 2))
)
expect_equal(
list_modify(
list(a = list(x = 1)),
a = list(y = 2)
),
list(a = list(x = 1, y = 2))
)
})
# list_merge --------------------------------------------------------------
test_that("list_merge concatenates values from two lists", {
l1 <- list(x = 1:10, y = 4, z = list(a = 1, b = 2))
l2 <- list(x = 11, z = list(a = 2:5, c = 3))
l <- list_merge(l1, !!! l2)
expect_equal(l$x, c(l1$x, l2$x))
expect_equal(l$y, c(l1$y, l2$y))
expect_equal(l$z$a, c(l1$z$a, l2$z$a))
expect_equal(l$z$b, c(l1$z$b, l2$z$b))
expect_equal(l$z$c, c(l1$z$c, l2$z$c))
})
test_that("list_merge concatenates without needing names", {
l1 <- list(1:10, 4, list(1, 2))
l2 <- list(11, 5, list(2:5, 3))
expect_length(list_merge(l1, !!! l2), 3)
})
test_that("list_merge returns the non-empty list", {
expect_equal(list_merge(list(3)), list(3))
expect_equal(list_merge(list(), 2), set_names(list(2), ""))
})
# update_list ------------------------------------------------------------
test_that("can modify element called x", {
expect_equal(update_list(list(), x = 1), list(x = 1))
})
test_that("quosures and formulas are evaluated", {
expect_identical(update_list(list(x = 1), y = quo(x + 1)), list(x = 1, y = 2))
expect_identical(update_list(list(x = 1), y = ~x + 1), list(x = 1, y = 2))
})
purrr/tests/testthat/test-along.R 0000644 0001762 0000144 00000000367 13124217327 016636 0 ustar ligges users context("along")
test_that("list_along works", {
x <- 1:5
expect_identical(list_along(x), vector("list", 5))
})
test_that("rep_along works", {
expect_equal(
rep_along(c("c", "b", "a"), 1:3),
rep_along(c("d", "f", "e"), 1:3)
)
})
purrr/tests/testthat/test-predicates.R 0000644 0001762 0000144 00000000715 13124217327 017656 0 ustar ligges users context("predicates")
test_that("predicate-based functionals work with logical vectors", {
expect_equal(keep(as.list(1:3), c(TRUE, FALSE, TRUE)), list(1, 3))
expect_equal(discard(as.list(1:3), c(TRUE, FALSE, TRUE)), list(2))
expect_equal(
modify_if(as.list(1:3), c(TRUE, FALSE, TRUE), as.character),
list("1", 2, "3")
)
expect_equal(
lmap_if(as.list(1:3), c(TRUE, FALSE, TRUE), ~list(as.character(.x[[1]]))),
list("1", 2, "3")
)
})
purrr/tests/testthat/test-cross.R 0000644 0001762 0000144 00000001301 13124217327 016654 0 ustar ligges users context("cross")
test_that("long format corresponds to expand.grid output", {
x <- list(a = 1:3, b = 4:9)
out1 <- cross_df(x)
out2 <- expand.grid(x, KEEP.OUT.ATTRS = FALSE) %>% dplyr::as_data_frame()
expect_equal(out1, out2)
})
test_that("filtering works", {
filter <- function(x, y) x >= y
out <- cross2(1:3, 1:3, .filter = filter)
expect_equal(out, list(list(1, 2), list(1, 3), list(2, 3)))
})
test_that("filtering fails when filter function doesn't return a logical", {
filter <- function(x, y, z) x + y + z
expect_error(cross3(1:3, 1:3, 1:3, .filter = filter))
})
test_that("works with empty input", {
expect_equal(cross(list()), list())
expect_equal(cross(NULL), NULL)
})
purrr/tests/testthat/test-composition.R 0000644 0001762 0000144 00000001467 13124217327 020103 0 ustar ligges users context("composition")
test_that("lift_dl and lift_ld are inverses of each other", {
expect_identical(
sum %>%
lift_dl(.unnamed = TRUE) %>%
invoke(list(3, NA, 4, na.rm = TRUE)),
sum %>%
lift_dl() %>%
lift_ld() %>%
invoke(3, NA, 4, na.rm = TRUE)
)
})
test_that("lift_dv is from ... to c(...)", {
expect_equal(lift_dv(range, .unnamed = TRUE)(1:10), c(1, 10))
})
test_that("lift_vd is from c(...) to ...", {
expect_equal(lift_vd(mean)(1, 2), 1.5)
})
test_that("lift_vl is from c(...) to list(...)", {
expect_equal(lift_vl(mean)(list(1, 2)), 1.5)
})
test_that("lift_lv is from list(...) to c(...)", {
glue <- function(l) {
if (!is.list(l)) stop("not a list")
l %>% invoke(paste, .)
}
expect_identical(lift_lv(glue)(letters), paste(letters, collapse = " "))
})
purrr/tests/testthat/test-compose.R 0000644 0001762 0000144 00000000420 13124217327 017171 0 ustar ligges users context("compose")
test_that("composed functions are applied right to left", {
expect_identical(!is.null(4), compose(`!`, is.null)(4))
set.seed(1)
x <- sample(1:4, 100, replace = TRUE)
expect_identical(unname(sort(table(x))), compose(unname, sort, table)(x))
})
purrr/tests/testthat/test-partial.R 0000644 0001762 0000144 00000002057 13124217327 017170 0 ustar ligges users context("partial")
test_that("dots are correctly placed in the signature", {
dots_last_actual <- call("runif", n = call("rpois", 1, 5), quote(...))
dots_last_alleged <- partial(runif, n = rpois(1, 5)) %>% body()
expect_identical(dots_last_actual, dots_last_alleged)
# Also tests that argument names are not eaten when .dots_first = TRUE
dots_first_actual <- call("runif", quote(...), n = call("rpois", 1, 5))
dots_first_alleged <- partial(runif, n = rpois(1, 5), .first = FALSE) %>%
body()
expect_identical(dots_first_actual, dots_first_alleged)
})
test_that("partial() works with no partialised arguments", {
actual <- call("runif", quote(...))
alleged1 <- partial(runif, .first = TRUE) %>% body()
alleged2 <- partial(runif, .first = FALSE) %>% body()
expect_identical(actual, alleged1)
expect_identical(actual, alleged2)
})
test_that("lazy evaluation means arguments aren't repeatedly evaluated", {
f <- partial(runif, n = rpois(1, 5), .lazy = FALSE)
.n <- 100
v <- map_int(rerun(.n, f()), length)
expect_true(table(v) == .n)
})
purrr/tests/testthat/test-map_n.R 0000644 0001762 0000144 00000003657 13124217327 016635 0 ustar ligges users context("pmap")
test_that("input must be a list of vectors", {
expect_error(pmap(environment(), identity), "not a list")
expect_error(pmap(list(environment()), identity), "not a vector")
})
test_that("elements must be same length", {
expect_error(pmap(list(1:2, 1:3), identity), "has length 2")
})
test_that("handles any length 0 input", {
expect_equal(pmap(list(list(), list(), list()), ~ 1), list())
expect_equal(pmap(list(NULL, NULL, NULL), ~ 1), list())
expect_equal(pmap(list(list(), list(), 1:10), ~ 1), list())
expect_equal(pmap(list(NULL, NULL, 1:10), ~ 1), list())
})
test_that("length 1 elemetns are recycled", {
out <- pmap(list(1:2, 1), c)
expect_equal(out, list(c(1, 1), c(2, 1)))
})
test_that(".f called with named arguments", {
out <- pmap(list(x = 1, 2, y = 3), list)[[1]]
expect_equal(names(out), c("x", "", "y"))
})
test_that("names are preserved", {
out <- pmap(list(c(x = 1, y = 2), 3:4), list)
expect_equal(names(out), c("x", "y"))
})
test_that("... are passed on", {
out <- pmap(list(x = 1:2), list, n = 1)
expect_equal(out, list(
list(x = 1, n = 1),
list(x = 2, n = 1)
))
})
test_that("outputs are suffixes have correct type", {
x <- 1:3
expect_is(pmap_lgl(list(x), is.numeric), "logical")
expect_is(pmap_int(list(x), length), "integer")
expect_is(pmap_dbl(list(x), mean), "numeric")
expect_is(pmap_chr(list(x), paste), "character")
expect_is(pmap_dfr(list(x), as.data.frame), "data.frame")
expect_is(pmap_dfc(list(x), as.data.frame), "data.frame")
})
test_that("pmap on data frames performs rowwise operations", {
mtcars2 <- mtcars[c("mpg", "cyl")]
expect_length(pmap(mtcars2, paste), nrow(mtcars))
expect_is(pmap_lgl(mtcars2, function(mpg, cyl) mpg > cyl), "logical")
expect_is(pmap_int(mtcars2, function(mpg, cyl) as.integer(cyl)), "integer")
expect_is(pmap_dbl(mtcars2, function(mpg, cyl) mpg + cyl), "numeric")
expect_is(pmap_chr(mtcars2, paste), "character")
})
purrr/tests/testthat/test-invoke.R 0000644 0001762 0000144 00000003000 13124217327 017014 0 ustar ligges users context("invoke")
# invoke ------------------------------------------------------------------
test_that("invoke() evaluates expressions in the right environment", {
x <- letters
f <- toupper
expect_equal(invoke("f", quote(x)), toupper(letters))
})
test_that("invoke() follows promises to find the evaluation env", {
x <- letters
f <- toupper
f1 <- function(y) {
f2 <- function(z) purrr::invoke(z, quote(x))
f2(y)
}
expect_equal(f1("f"), toupper(letters))
})
# invoke_map --------------------------------------------------------------
test_that("invoke_map() works with bare function", {
data <- list(1:2, 3:4)
expected <- list("1 2", "3 4")
expect_equal(invoke_map(paste, data), expected)
expect_equal(invoke_map("paste", data), expected)
expect_equal(invoke_map_chr(paste, data), unlist(expected))
expect_identical(invoke_map_dbl(`+`, data), c(3, 7))
expect_identical(invoke_map_int(`+`, data), c(3L, 7L))
expect_identical(invoke_map_lgl(`&&`, data), c(TRUE, TRUE))
ops <- set_names(c(`+`, `-`), c("a", "b"))
expect_identical(invoke_map_dfr(ops, data), invoke_map_dfc(ops, data))
})
test_that("invoke_map() evaluates expressions in the right environment", {
shadowed_object <- letters
shadowed_fun <- toupper
expect_equal(
invoke_map("shadowed_fun", list(quote(shadowed_object))),
list(toupper(letters))
)
})
test_that("invoke_maps doesn't rely on c() returning list", {
day <- as.Date("2016-09-01")
expect_equal(invoke_map(identity, list(day)), list(day))
})
purrr/tests/testthat/test-recycle_args.R 0000644 0001762 0000144 00000001234 13124217327 020172 0 ustar ligges users context("recycle_args")
test_that("rejects uneven lengths", {
args <- list(1, c(1:2), NULL)
expect_error(purrr:::recycle_args(args), "lengths == 1L \\| lengths == n")
})
test_that("recycles single values and preserves longer ones", {
args <- list(1, 1:12, month.name, "a")
recycled <- purrr:::recycle_args(args)
expect_equal(recycled[[1]], rep(1, 12))
expect_equal(recycled[[2]], 1:12)
expect_equal(recycled[[3]], month.name)
expect_equal(recycled[[4]], rep("a", 12))
})
test_that("will not recycle non-vectors", {
args <- list(1:12, identity)
expect_error(
purrr:::recycle_args(args),
"replicate an object of type 'closure'"
)
})
purrr/tests/testthat/test-reduce.R 0000644 0001762 0000144 00000003455 13124217327 017006 0 ustar ligges users context("reduce")
test_that("empty input returns init or error", {
expect_error(reduce(list()), "no `.init` supplied")
expect_equal(reduce(list(), `+`, .init = 0), 0)
})
test_that("first/value value used as first value", {
x <- c(1, 1)
expect_equal(reduce(x, `+`), 2)
expect_equal(reduce(x, `+`, .init = 1), 3)
expect_equal(reduce_right(x, `+`), 2)
expect_equal(reduce_right(x, `+`, .init = 1), 3)
})
test_that("length 1 argument reduced with init", {
expect_equal(reduce(1, `+`, .init = 1), 2)
expect_equal(reduce_right(1, `+`, .init = 1), 2)
})
test_that("reduce_right equivalent to reversing input", {
x <- list(c(2, 1), c(4, 3), c(6, 5))
expect_equal(reduce_right(x, c), c(6, 5, 4, 3, 2, 1))
expect_equal(reduce_right(x, c, .init = 7), c(7, 6, 5, 4, 3, 2, 1))
})
# accumulate --------------------------------------------------------------
test_that("accumulate passes arguments to function", {
tt <- c("a", "b", "c")
expect_equal(accumulate(tt, paste, sep = "."), c("a", "a.b", "a.b.c"))
expect_equal(accumulate_right(tt, paste, sep = "."), c("c.b.a", "c.b", "c"))
})
# reduce2 -----------------------------------------------------------------
test_that("basic application works", {
paste2 <- function(x, y, sep) paste(x, y, sep = sep)
x <- c("a", "b", "c")
expect_equal(reduce2(x, c("-", "."), paste2), "a-b.c")
expect_equal(reduce2(x, c(".", "-", "."), paste2, .init = "x"), "x.a-b.c")
})
test_that("reduce2_right works if lengths match", {
x <- list(c(0, 1), c(2, 3), c(4, 5))
y <- list(c(6, 7), c(8, 9))
expect_equal(reduce2_right(x, paste, y), c("4 2 8 0 6", "5 3 9 1 7"))
expect_error(reduce2_right(y, paste, x))
})
test_that("reduce returns original input if it was length one", {
x <- list(c(0, 1), c(2, 3), c(4, 5))
expect_equal(reduce(x[1], paste), x[[1]])
})
purrr/tests/testthat/test-coerce.R 0000644 0001762 0000144 00000004444 13124217327 016776 0 ustar ligges users context("coerce")
test_that("missing values converted to new type", {
expect_equal(coerce_int(NA), NA_integer_)
expect_equal(coerce_dbl(NA), NA_real_)
expect_equal(coerce_chr(NA), NA_character_)
expect_equal(coerce_dbl(NA_integer_), NA_real_)
expect_equal(coerce_chr(NA_integer_), NA_character_)
expect_equal(coerce_chr(NA_real_), NA_character_)
})
test_that("can't coerce downwards", {
expect_error(coerce_chr(list(1)), "Can't coerce")
expect_error(coerce_dbl(list(1)), "Can't coerce")
expect_error(coerce_int(list(1)), "Can't coerce")
expect_error(coerce_lgl(list(1)), "Can't coerce")
expect_error(coerce_dbl("a"), "Can't coerce")
expect_error(coerce_int("a"), "Can't coerce")
expect_error(coerce_lgl("a"), "Can't coerce")
expect_error(coerce_int(1), "Can't coerce")
expect_error(coerce_lgl(1), "Can't coerce")
expect_error(coerce_lgl(1L), "Can't coerce")
})
test_that("coercing to same type returns input", {
expect_equal(coerce_lgl(c(TRUE, FALSE)), c(TRUE, FALSE))
expect_equal(coerce_dbl(c(1, 2)), c(1, 2))
expect_equal(coerce_int(c(1L, 2L)), c(1L, 2L))
expect_equal(coerce_chr(c("a", "b")), c("a", "b"))
})
test_that("types automatically coerced upwards", {
expect_identical(coerce_int(c(FALSE, TRUE)), c(0L, 1L))
expect_identical(coerce_dbl(c(FALSE, TRUE)), c(0, 1))
expect_identical(coerce_dbl(c(1L, 2L)), c(1, 2))
expect_identical(coerce_chr(c(FALSE, TRUE)), c("FALSE", "TRUE"))
expect_identical(coerce_chr(c(1L, 2L)), c("1", "2"))
expect_identical(coerce_chr(c(1.5, 2.5)), c("1.500000", "2.500000"))
})
test_that("coercing to character values correctly", {
expect_equal(coerce_chr(c(FALSE, TRUE)), c("FALSE", "TRUE"))
expect_equal(coerce_chr(c(1L, 2L)), c("1", "2"))
expect_equal(coerce_chr(c(1.5, 2.5)), c("1.500000", "2.500000"))
expect_equal(coerce_chr(c("a", "b")), c("a", "b"))
x <- c(NA, NaN, Inf, -Inf)
expect_equal(coerce(x, "character"), as.character(x))
})
test_that("can't coerce to expressions", {
expect_error(coerce(list(1), "expression"))
})
test_that("as_vector can be type-specifc", {
expect_identical(as_vector(as.list(letters), "character"), letters)
})
test_that("as_vector cannot coerce lists with zero-length elements", {
x <- list(a = 1, b = c(list(), 3))
expect_error(as_vector(x))
expect_identical(x, simplify(x))
})
purrr/tests/testthat/test-arrays.R 0000644 0001762 0000144 00000000764 13124217327 017040 0 ustar ligges users context("arrays")
x <- array(1:12, c(2, 2, 3))
test_that("array_branch creates a flat list when no margin specified", {
expect_length(array_branch(x), 12)
})
test_that("array_branch wraps array in list when margin has length 0", {
expect_identical(array_branch(x, numeric(0)), list(x))
})
test_that("length depends on whether list is flattened or not", {
m1 <- c(3, 1)
m2 <- 3
expect_length(array_branch(x, m1), prod(dim(x)[m1]))
expect_length(array_tree(x, m1), prod(dim(x)[m2]))
})
purrr/tests/testthat/test-when.R 0000644 0001762 0000144 00000002013 13124217327 016465 0 ustar ligges users context("when")
test_that("when chooses the correct action", {
x <-
1:5 %>%
when(
sum(.) <= 50 ~ sum(.),
sum(.) <= 100 ~ sum(.) / 2,
~ 0
)
expect_equal(x, 15)
y <-
1:10 %>%
when(
sum(.) <= 50 ~ sum(.),
sum(.) <= 100 ~ sum(.) / 2,
~ 0
)
expect_equal(y, sum(1:10) / 2)
z <-
1:100 %>%
when(
sum(.) <= 50 ~ sum(.),
sum(.) <= 100 ~ sum(.) / 2,
~ 0
)
expect_equal(z, 0)
})
test_that("named arguments work with when", {
x <-
1:10 %>%
when(
sum(.) <= x ~ sum(.) * x,
sum(.) <= 2 * x ~ sum(.) * x / 2,
~ 0,
x = 60
)
expect_equal(x, sum(1:10) * 60)
})
test_that("default values work without a formula", {
x <-
iris %>%
subset(Sepal.Length > 10) %>%
when(
nrow(.) > 0 ~ .,
head(iris, 10)
)
expect_equivalent(x, head(iris, 10))
})
test_that("error when named arguments have no matching conditions", {
expect_error(1:5 %>% when(a = sum(.) < 5 ~ 3))
})
purrr/tests/testthat/test-imap.R 0000644 0001762 0000144 00000001261 13124217327 016456 0 ustar ligges users context("imap")
x <- 1:3 %>% set_names()
test_that("imap is special case of map2", {
expect_identical(imap(x, paste), map2(x, names(x), paste))
})
test_that("imap always returns a list", {
expect_is(imap(x, paste), "list")
})
test_that("atomic vector imap works", {
expect_true(all(imap_lgl(x, `==`)))
expect_length(imap_chr(x, paste), 3)
expect_equal(imap_int(x, ~ .x + as.integer(.y)), x * 2)
expect_equal(imap_dbl(x, ~ .x + as.numeric(.y)), x * 2)
})
test_that("data frame imap works", {
expect_identical(imap_dfc(x, paste), imap_dfr(x, paste))
})
test_that("iwalk returns invisibly", {
expect_output(iwalk(mtcars, ~ cat(.y, ": ", median(.x), "\n", sep = "")))
})
purrr/tests/testthat/test-find-position.R 0000644 0001762 0000144 00000001727 13137651733 020330 0 ustar ligges users context("find-position")
y <- 4:10
test_that("detect functions work", {
is_odd <- function(x) x %% 2 == 1
expect_equal(detect(y, is_odd), 5)
expect_equal(detect_index(y, is_odd), 2)
expect_equal(detect(y, is_odd, .right = TRUE), 9)
expect_equal(detect_index(y, is_odd, .right = TRUE), 6)
})
test_that("detect returns NULL when match not found", {
expect_null(detect(y, function(x) x > 11))
})
test_that("detect_index returns 0 when match not found", {
expect_equal(detect_index(y, function(x) x > 11), 0)
})
test_that("has_element checks whether a list contains an object", {
expect_true(has_element(list(1, 2), 1))
expect_false(has_element(list(1, 2), 3))
})
test_that("detect functions still work with `.p`", {
is_even <- function(x) x %% 2 == 0
expect_warning(regex = "renamed to `.f`",
expect_identical(detect(1:3, .p = is_even), 2L)
)
expect_warning(regex = "renamed to `.f`",
expect_identical(detect_index(1:3, .p = is_even), 2L)
)
})
purrr/tests/testthat/test-depth.R 0000644 0001762 0000144 00000001257 13137651733 016650 0 ustar ligges users context("depth")
test_that("depth of NULL is 0", {
expect_equal(vec_depth(NULL), 0L)
})
test_that("depth of atomic vector is 1", {
expect_equal(vec_depth(1:10), 1)
expect_equal(vec_depth(letters), 1)
expect_equal(vec_depth(c(TRUE, FALSE)), 1)
})
test_that("depth of empty list is 1", {
expect_equal(vec_depth(list()), 1)
})
test_that("depth of nested is depth of deepest element + 1", {
x <- list(
NULL,
list(),
list(list())
)
depths <- map_int(x, vec_depth)
expect_equal(depths, c(0, 1, 2))
expect_equal(vec_depth(x), max(depths) + 1)
})
test_that("depth throws an error if input is not a vector", {
expect_error(vec_depth(as.formula(y ~ x)))
})
purrr/tests/testthat/test-prepend.R 0000644 0001762 0000144 00000000405 13124217327 017164 0 ustar ligges users context("prepend")
test_that("prepend is clearer version of merging with c()", {
x <- 1:3
expect_identical(
x %>% prepend(4),
x %>% c(4, .)
)
expect_identical(
x %>% prepend(4, before = 3),
x %>% {
c(.[1:2], 4, .[3])
}
)
})
purrr/tests/testthat/test-lmap.R 0000644 0001762 0000144 00000000351 13124217327 016460 0 ustar ligges users context("lmap")
test_that("lmap output is list if input is list", {
expect_is(lmap(as.list(mtcars), as.list), "list")
})
test_that("lmap output is tibble if input is data frame", {
expect_is(lmap(mtcars, as.list), "tbl_df")
})
purrr/tests/testthat/test-simplify.R 0000644 0001762 0000144 00000001735 12602231320 017357 0 ustar ligges users context("simplify")
test_that("can_simplify() understands vector molds", {
x <- as.list(1:3)
x2 <- c(x, list(1:3))
expect_true(can_simplify(x, integer(1)))
expect_false(can_simplify(x, character(1)))
expect_false(can_simplify(x2, integer(1)))
x3 <- list(1:2, 3:4, 5:6)
expect_true(can_simplify(x3, integer(2)))
expect_false(can_simplify(x, integer(2)))
})
test_that("can_simplify() understands types as strings", {
x <- as.list(1:3)
expect_true(can_simplify(x, "integer"))
expect_false(can_simplify(x, "character"))
})
test_that("integer is coercible to double", {
x <- list(1L, 2L)
expect_true(can_simplify(x, "numeric"))
expect_true(can_simplify(x, numeric(1)))
expect_true(can_simplify(x, "double"))
expect_true(can_simplify(x, double(1)))
})
test_that("numeric is an alias for double", {
expect_true(can_simplify(list(1, 2), "numeric"))
})
test_that("double is not coercible to integer", {
expect_false(can_simplify(list(1, 2), "integer"))
})
purrr/tests/testthat/test-rerun.R 0000644 0001762 0000144 00000000732 13124217327 016665 0 ustar ligges users context("rerun")
test_that("single unnamed arg doesn't get extra list", {
expect_equal(rerun(2, 1), list(1, 1))
})
test_that("single named arg gets extra list", {
expect_equal(rerun(2, a = 1), list(list(a = 1), list(a = 1)))
})
test_that("every run is different", {
x <- rerun(2, runif(1))
expect_true(x[[1]] != x[[2]])
})
test_that("rerun uses scope of expression", {
f <- function(n) {
rerun(1, x = seq_len(n))
}
expect_equal(f(10)[[1]]$x, 1:10)
})
purrr/tests/testthat/test-transpose.R 0000644 0001762 0000144 00000005634 13102346452 017554 0 ustar ligges users context("transpose")
test_that("input must be a list", {
expect_error(transpose(1:3), "is not a list")
})
test_that("elements of input must be vectors", {
expect_error(transpose(list(environment())), "is not a vector")
expect_error(transpose(list(list(), environment())), "is not a vector")
})
test_that("empty list returns empty list", {
expect_equal(transpose(list()), list())
})
test_that("transpose switches order of first & second idnex", {
x <- list(list(1, 3), list(2, 4))
expect_equal(transpose(x), list(list(1, 2), list(3, 4)))
})
test_that("inside names become outside names", {
x <- list(list(x = 1), list(x = 2))
expect_equal(transpose(x), list(x = list(1, 2)))
})
test_that("outside names become inside names", {
x <- list(x = list(1, 3), y = list(2, 4))
expect_equal(transpose(x), list(list(x = 1, y = 2), list(x = 3, y = 4)))
})
test_that("warns if element too short", {
x <- list(list(1, 2), list(1))
expect_warning(out <- transpose(x), "Element 2 has length 1")
expect_equal(out, list(list(1, 1), list(2, NULL)))
})
test_that("warns if element too long", {
x <- list(list(1, 2), list(1, 2, 3))
expect_warning(out <- transpose(x), "Element 2 has length 3")
expect_equal(out, list(list(1, 1), list(2, 2)))
})
test_that("can transpose list of lists of atomic vectors", {
x <- list(list(TRUE, 1L, 1, "1"))
expect_equal(transpose(x), list(list(TRUE), list(1L), list(1), list("1")))
})
test_that("can transpose lists of atomic vectors", {
expect_equal(transpose(list(TRUE, FALSE)), list(list(TRUE, FALSE)))
expect_equal(transpose(list(1L, 2L)), list(list(1L, 2L)))
expect_equal(transpose(list(1, 2)), list(list(1, 2)))
expect_equal(transpose(list("a", "b")), list(list("a", "b")))
})
test_that("can't transpose expressions", {
expect_error(transpose(list(expression(a))), "Unsupported type")
})
# Named based matching ----------------------------------------------------
test_that("can override default names", {
x <- list(
list(x = 1),
list(y = 2, x = 1)
)
tx <- transpose(x, c("x", "y"))
expect_equal(tx, list(
x = list(1, 1),
y = list(NULL, 2)
))
})
test_that("if present, names are used", {
x <- list(
list(x = 1, y = 2),
list(y = 2, x = 1)
)
tx <- transpose(x)
expect_equal(tx$x, list(1, 1))
expect_equal(tx$y, list(2, 2))
})
test_that("if missing elements, filled with NULL", {
x <- list(
list(x = 1, y = 2),
list(x = 1)
)
tx <- transpose(x)
expect_equal(tx$y, list(2, NULL))
})
# Position based matching -------------------------------------------------
test_that("warning if too short", {
x <- list(
list(1, 2),
list(1)
)
expect_warning(tx <- transpose(x), "has length 1 not 2")
expect_equal(tx, list(list(1, 1), list(2, NULL)))
})
test_that("warning if too long", {
x <- list(
list(1),
list(1, 2)
)
expect_warning(tx <- transpose(x), "has length 2 not 1")
expect_equal(tx, list(list(1, 1)))
})
purrr/tests/testthat/test-every-some.R 0000644 0001762 0000144 00000000707 13124217327 017627 0 ustar ligges users context("every-some")
test_that("return NA if present", {
expect_equal(some(1:10, ~ NA), NA)
expect_equal(every(1:10, ~ NA), NA)
})
test_that("every returns TRUE if all elements are TRUE", {
x <- list(0, 1, TRUE)
expect_false(every(x, isTRUE))
expect_true(every(x[3], isTRUE))
})
test_that("some returns FALSE if all elements are FALSE", {
x <- list(1, 0, FALSE)
expect_false(some(x, isTRUE))
expect_true(some(x[1], negate(isTRUE)))
})
purrr/tests/testthat/test-map2.R 0000644 0001762 0000144 00000002340 13124217327 016366 0 ustar ligges users context("map2")
test_that("map2 inputs must be same length", {
expect_error(map2(1:3, 2:3, function(...) NULL), "different lengths")
})
test_that("map2 can't simplify if elements longer than length 1", {
expect_error(
map2_int(1:4, 5:8, range),
"Result 1 is not a length 1 atomic vector"
)
})
test_that("fails on non-vectors", {
expect_error(map2(environment(), "a", identity), "not a vector")
expect_error(map2("a", environment(), identity), "not a vector")
})
test_that("map2 vectorised inputs of length 1", {
expect_equal(map2(1:2, 1, `+`), list(2, 3))
expect_equal(map2(1, 1:2, `+`), list(2, 3))
})
test_that("any 0 length input gives 0 length output", {
expect_equal(map2(list(), list(), ~ 1), list())
expect_equal(map2(1:10, list(), ~ 1), list())
expect_equal(map2(list(), 1:10, ~ 1), list())
expect_equal(map2(NULL, NULL, ~ 1), list())
expect_equal(map2(1:10, NULL, ~ 1), list())
expect_equal(map2(NULL, 1:10, ~ 1), list())
})
test_that("map2 takes only names from x", {
x1 <- 1:3
x2 <- set_names(x1)
expect_equal(names(map2(x1, x2, `+`)), NULL)
expect_equal(names(map2(x2, x1, `+`)), names(x2))
})
test_that("map2 always returns a list", {
expect_is(map2(mtcars, 0, ~mtcars), "list")
})
purrr/tests/testthat/test-negate.R 0000644 0001762 0000144 00000000442 13102346452 016771 0 ustar ligges users context("negate")
test_that("negate works with both functions and vectors", {
true <- function(...) TRUE
expect_equal(negate(true)(), FALSE)
expect_equal(negate("x")(list(x = TRUE)), FALSE)
expect_equal(negate(is.null)(TRUE), TRUE)
expect_equal(negate(is.null)(NULL), FALSE)
})
purrr/tests/testthat/test-modify.R 0000644 0001762 0000144 00000003326 13124217327 017023 0 ustar ligges users context("modify")
test_that("modify returns same type as input", {
df1 <- data.frame(x = 1:3, y = 4:6)
expect_equal(modify(df1, length), data.frame(x = rep(3, 3), y = rep(3, 3)))
})
test_that("modify_if/modify_at return same type as input", {
df1 <- data.frame(x = "a", y = 2, stringsAsFactors = FALSE)
exp <- data.frame(x = "A", y = 2, stringsAsFactors = FALSE)
df2a <- modify_if(df1, is.character, toupper)
expect_equal(df2a, exp)
df2b <- modify_at(df1, "x", toupper)
expect_equal(df2b, exp)
})
test_that("modify_at requires a named object", {
df1 <- data.frame(x = "a", y = 2, stringsAsFactors = FALSE)
expect_error(modify_at(unname(df1), "x", toupper))
})
test_that("modify_at operates on character and numeric indexing", {
df1 <- data.frame(x = "a", y = 2, stringsAsFactors = FALSE)
expect_error(modify_at(df1, TRUE, toupper))
})
# modify_depth ------------------------------------------------------------
test_that("modify_depth modifies values at specified depth", {
x1 <- list(list(list(1)))
expect_equal(modify_depth(x1, 0, length), list(1))
expect_equal(modify_depth(x1, 1, length), list(1))
expect_equal(modify_depth(x1, 2, length), list(list(1)))
expect_equal(modify_depth(x1, 3, length), list(list(list(1))))
expect_equal(modify_depth(x1, -1, length), list(list(list(1))))
expect_error(modify_depth(x1, 4, length), "List not deep enough")
expect_error(modify_depth(x1, -5, length), "Invalid `depth`")
})
test_that(".ragged = TRUE operates on leaves", {
x1 <- list(
list(1),
list(list(2))
)
x2 <- list(
list(2),
list(list(3))
)
expect_equal(modify_depth(x1, 3, ~ . + 1, .ragged = TRUE), x2)
expect_equal(modify_depth(x1, -1, ~ . + 1, .ragged = TRUE), x2)
})
purrr/tests/testthat/test-flatten.R 0000644 0001762 0000144 00000004353 13124217327 017172 0 ustar ligges users context("flatten")
test_that("input must be a list", {
expect_error(flatten(1), "must be a list")
})
test_that("contents of list must be supported types", {
expect_error(flatten(list(quote(a))), "not a vector")
expect_error(flatten(list(expression(a))), "Unsupported type")
})
test_that("each second level element becomes first level element", {
expect_equal(flatten(list(1:2)), list(1, 2))
expect_equal(flatten(list(1, 2)), list(1, 2))
})
test_that("can flatten all atomic vectors", {
expect_equal(flatten(list(F)), list(F))
expect_equal(flatten(list(1L)), list(1L))
expect_equal(flatten(list(1)), list(1))
expect_equal(flatten(list("a")), list("a"))
})
test_that("NULLs are silently dropped", {
expect_equal(flatten(list(NULL, NULL)), list())
expect_equal(flatten(list(NULL, 1)), list(1))
expect_equal(flatten(list(1, NULL)), list(1))
})
test_that("names are preserved", {
expect_equal(flatten(list(list(x = 1), list(y = 1))), list(x = 1, y = 1))
expect_equal(flatten(list(list(a = 1, b = 2), 3)), list(a = 1, b = 2, 3))
})
test_that("names of 'scalar' elements are preserved", {
out <- flatten(list(a = list(1), b = list(2)))
expect_equal(out, list(a = 1, b = 2))
out <- flatten(list(a = list(1), b = 2:3))
expect_equal(out, list(a = 1, 2, 3))
out <- flatten(list(list(a = 1, b = 2), c = 3))
expect_equal(out, list(a = 1, b = 2, c = 3))
})
test_that("child names beat parent names", {
out <- flatten(list(a = list(x = 1), b = list(y = 2)))
expect_equal(out, list(x = 1, y = 2))
})
# atomic flatten ----------------------------------------------------------
test_that("must be a list", {
expect_error(flatten_lgl(1), "must be a list")
})
test_that("can flatten all atomic vectors", {
expect_equal(flatten_lgl(list(F)), F)
expect_equal(flatten_int(list(1L)), 1L)
expect_equal(flatten_dbl(list(1)), 1)
expect_equal(flatten_chr(list("a")), "a")
})
test_that("preserves inner names", {
expect_equal(
flatten_dbl(list(c(a = 1), c(b = 2))),
c(a = 1, b = 2)
)
})
# data frame flatten ------------------------------------------------------
test_that("can flatten to a data frame with named lists", {
expect_is(flatten_dfr(list(c(a = 1), c(b = 2))), "data.frame")
expect_error(flatten_dfc(list(1)))
})
purrr/tests/testthat/test-map.R 0000644 0001762 0000144 00000004210 13171452210 016274 0 ustar ligges users context("map")
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_identical(out, quote(.f(.x[[i]], ...)))
})
test_that("fails on non-vectors", {
expect_error(map(environment(), identity), "not a vector")
expect_error(map(quote(a), identity), "not a vector")
})
test_that("0 length input gives 0 length output", {
out1 <- map(list(), identity)
expect_equal(out1, list())
out2 <- map(NULL, identity)
expect_equal(out2, list())
})
test_that("map() always returns a list", {
expect_is(map(mtcars, mean), "list")
})
test_that("types automatically coerced upwards", {
expect_identical(map_int(c(FALSE, TRUE), identity), c(0L, 1L))
expect_identical(map_dbl(c(FALSE, TRUE), identity), c(0, 1))
expect_identical(map_dbl(c(1L, 2L), identity), c(1, 2))
expect_identical(map_chr(c(FALSE, TRUE), identity), c("FALSE", "TRUE"))
expect_identical(map_chr(c(1L, 2L), identity), c("1", "2"))
expect_identical(map_chr(c(1.5, 2.5), identity), c("1.500000", "2.500000"))
})
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("row and column binding work", {
mtcar_mod <- mtcars %>%
split(.$cyl) %>%
map(~ lm(mpg ~ wt, data = .x))
f_coef <- function(x) as.data.frame(t(as.matrix(coef(x))))
expect_length(mtcar_mod %>% map_dfr(f_coef), 2)
expect_length(mtcar_mod %>% map_dfc(f_coef), 6)
})
test_that("walk is used for side-effects", {
expect_output(walk(1:3, str))
})
test_that("map_if() and map_at() always return a list", {
df <- tibble::tibble(x = 1, y = "a")
expect_identical(map_if(df, is.character, ~"out"), list(x = 1, y = "out"))
expect_identical(map_at(df, 1, ~"out"), list(x = "out", y = "a"))
})
purrr/src/ 0000755 0001762 0000144 00000000000 13171650762 012223 5 ustar ligges users purrr/src/coerce.c 0000644 0001762 0000144 00000005021 13171650762 013625 0 ustar ligges users #define R_NO_REMAP
#include 
======================================================
[](http://cran.r-project.org/package=purrr) [](https://travis-ci.org/tidyverse/purrr) [](https://codecov.io/github/tidyverse/purrr?branch=master)
Overview
--------
purrr enhances R's functional programming (FP) toolkit by providing a complete and consistent set of tools for working with functions and vectors. If you've never heard of FP before, the best place to start is the family of `map()` functions which allow you to replace many for loops with code that is both more succinct and easier to read. The best place to learn about the `map()` functions is the [iteration chapter](http://r4ds.had.co.nz/iteration.html) in R for data science.
Installation
------------
``` r
# The easiest way to get purrr is to install the whole tidyverse:
install.packages("tidyverse")
# Alternatively, install just purrr:
install.packages("purrr")
# Or the the development version from GitHub:
# install.packages("devtools")
devtools::install_github("tidyverse/purrr")
```
Usage
-----
The following example uses purrr to solve a fairly realistic problem: split a data frame into pieces, fit a model to each piece, compute the summary, then extract the R2.
``` r
library(purrr)
mtcars %>%
split(.$cyl) %>% # from base R
map(~ lm(mpg ~ wt, data = .)) %>%
map(summary) %>%
map_dbl("r.squared")
#> 4 6 8
#> 0.5086326 0.4645102 0.4229655
```
This example illustrates some of the advantages of purrr functions over the equivalents in base R:
- The first argument is always the data, so purrr works naturally with the pipe.
- All purrr functions are type-stable. They always return the advertised output type (`map()` returns lists; `map_dbl()` returns double vectors), or they throw an errror.
- All `map()` functions either accept function, formulas (used for succinctly generating anonymous functions), a character vector (used to extract components by name), or a numeric vector (used to extract by position).
purrr/MD5 0000644 0001762 0000144 00000015176 13171733547 011761 0 ustar ligges users 059324d1413bf11790eebfcc85afa281 *DESCRIPTION
d32239bcb673463ab874e80d47fae504 *LICENSE
b8b691d3ec56c2995d0eed7679ea7311 *NAMESPACE
461cec5f26550acd7a7153013ca2d401 *NEWS.md
d7434232639ef496b59a8863d526f4d5 *R/along.R
48b5ad68f9c3a686e0e5d78499feeec7 *R/arrays.R
dfc2fc05065d029dfbf897c83b347bd2 *R/as_mapper.R
f0ec1ea254e478033f6d34fb33405499 *R/coerce.R
78c61636c1cf9295234fd97e97662b5c *R/coercion.R
7cad8d9769011f8e8becd44c0c046905 *R/compose.R
60109119d2926aa5eb8d0b25995b7103 *R/composition.R
5a1819f7c6a77d026fd8a8dd85af818d *R/cross.R
42de484120cddf450bfaefe35ea0a2be *R/depth.R
fb21301f998ee034966f53c6a46453ad *R/every-some.R
4de7e21a61ef6ef0fa1a00c2522d2547 *R/find-position.R
2dd0023bfec19b388810951407f922c9 *R/flatten.R
aa1335a2e02edc206e9388d0f002125f *R/head-tail.R
8fcc2f91aed2123309302e0acad47189 *R/imap.R
72aad2226d57cf651c1fc9e25af870bd *R/invoke.R
4fc05f9f9e735ec87fb0f64bcaecde91 *R/keep.R
bebdbf11ecf1702b245387b214e1e46c *R/list-modify.R
36e036bfe9a070a893b9dda9f0cf1d09 *R/lmap.R
fc88d69357fe258dd5cdfebe943c619d *R/map.R
b84099b9b82c8ba315f0d8599bb3c4c1 *R/map2-pmap.R
e420126f44f750c89a79894bef58d9fe *R/modify.R
a848e46817874cd07d6f725c7fd112f2 *R/negate.R
ee7ea8075ca7b0f200e8cdbb6947f303 *R/output.R
46e6971d5cab3972e96f537c953d1ccb *R/partial.R
29a5243a6ac22ef61660fa10619167aa *R/predicates.R
b35704dde8e2ca4e17c830d75a1c44fd *R/prepend.R
ab9be6571c4276e9e8260d553248d8b1 *R/purrr.R
e19e96be648daac4265a5da6bd4cdc2b *R/reduce.R
8e41a48c6995da83d85d3407bde4477d *R/rerun.R
421ca7ab2db6ed008fba8b5558674827 *R/set_names.R
35b5580292c6c4227b218128bdd7da85 *R/splice.R
f6afdc22a2adf80cede2a04ec0536488 *R/transpose.R
b5ac331a5179d8aeae4b9e70cf003177 *R/utils.R
3011f46c733271400987666dc871373d *R/when.R
d00538240fc18c7c44547f5fb7ab04ad *README.md
ba009ec33d50810392dbb70cf5b9b5dc *build/vignette.rds
d0a12786bea51ec8b9d57563e6edacd8 *inst/doc/other-langs.Rmd
bf6d0d378ac18f2b89f70758cd62aedc *inst/doc/other-langs.html
a1af9c3fdda713bc8e76b3049e14ec9c *man/accumulate.Rd
31bf146d7265441ae4e72caa8c366f6c *man/along.Rd
a5fb7427a5582b7f26fb4628b0285fb3 *man/array-coercion.Rd
7bf23b591562d3cdb2dd0015350c2a08 *man/as_mapper.Rd
e7f26ac9b0e6831a8e74e8bb6c4c0849 *man/as_vector.Rd
ebc8d00b74c57e535a75097d5b3efb73 *man/compose.Rd
1079d4e27459673cef82d40c1c3ff770 *man/cross.Rd
768621965a402f6899719bed8b04dfa0 *man/detect.Rd
ed53201c56c68c61eaa8cba9836027dc *man/every.Rd
1d60cfe447b30937913953382e194602 *man/figures/logo.png
f936d540f0f4c19df702b72e57b1db0f *man/flatten.Rd
2d83b8c056befed23e23c5fa0a7e2901 *man/get-attr.Rd
45f2c89c9029e869a44213e3ecfdb393 *man/has_element.Rd
99e9c4dc80463cc0440f53cd30950239 *man/head_while.Rd
72c05631b758873c13c62dd9fffc9ea4 *man/imap.Rd
8d8d59bf99551df5138fdc384f0764bb *man/invoke.Rd
f4654f144511be7d26d7e88f01c5c5c4 *man/is_numeric.Rd
ed663b2e2ea63c371e2aae84526b8bbf *man/keep.Rd
aaf7edad66c589562b6542de0ab1fa14 *man/lift.Rd
91c2686573f852772455c3173a1d0730 *man/list_modify.Rd
7cf636dd7f4135242360f83bc6bcb2de *man/lmap.Rd
b59015aef9c5662cdc8664a444e67fd2 *man/map.Rd
3730114285585c293188cf3472480a42 *man/map2.Rd
a5a848f017dc57f6a32984a0be5688c9 *man/modify.Rd
c6f50cc4df88e89d974ae859659ac48a *man/negate.Rd
41960071b98ae08db2626bf0176474ad *man/null-default.Rd
fff26baafa6d12a021a1eccc418b98d1 *man/partial.Rd
a64a7ea44fcaa33c2d3ad0f7909cbc3e *man/pipe.Rd
6afcb054faa852df21065f001191d6b8 *man/pluck.Rd
c2e38b7a30f26c4ea0435141446254e4 *man/prepend.Rd
1d2d8fea562ac7cf11eca1c642a81a6b *man/purrr-package.Rd
f34d8370301c799a28aa8307b6394911 *man/rbernoulli.Rd
2df5a87d08db6c4b73447fa625ea444d *man/rdunif.Rd
a899f7774548591e1c94c14c593b42cc *man/reduce.Rd
50df6a47659d7e3831a580ff7b008b27 *man/reexports.Rd
028392c9b567bf0e18039256b65d54df *man/rerun.Rd
ed9a095395b1cf9025495309eb307ede *man/safely.Rd
1833c1e1d1e45f2a8fa6843672c92a8e *man/set_names.Rd
d198d9d3ffebb0bdca5968a34b70ccf4 *man/splice.Rd
987b0b3f1704943ddbad57e9e2c21e8d *man/transpose.Rd
5cf4da2f617677a3ab17aea0e6dcfcfd *man/vec_depth.Rd
476045071aee1d250fccf59f5bab87f9 *man/when.Rd
ff2850c9a8f09363bbcb7439f1a55e70 *src/backports.c
3a1ddd472e6b17c3679467cbd3409b10 *src/backports.h
74a87782ba250e74b5d1830e8864fb84 *src/coerce.c
6c50acdeb1bbbf26649665739256d211 *src/coerce.h
badf005339bec33e87c784155c10f8a3 *src/extract.c
9106493550bd308acceb970096f8a587 *src/flatten.c
829d93cfd9ef1890b0c06c402f5cb8ce *src/init.c
a516fbb25d2cce016910df6950e1ff4a *src/map.c
daa7efc01a8489ded96d8c0863e69b0f *src/map.h
7a43db39af0dbbbe838dd5204ee7e29a *src/transpose.c
8e9d16c5c6aedcc157783b13df5b9db0 *tests/testthat.R
ef7812928b1473706a682fd6948e9f98 *tests/testthat/test-along.R
dcbf48a2fbdba7f91e3880f7a0064701 *tests/testthat/test-arrays.R
f27cabfbbf69b64d662b72644ea39538 *tests/testthat/test-as-mapper.R
59bad9250777fd79da0f44408d7191d2 *tests/testthat/test-coerce.R
297f88674faf22665a960389c8fda450 *tests/testthat/test-compose.R
b3708b23403b14b7c15db43e810029e8 *tests/testthat/test-composition.R
ca3d5a991b34b91ec6cff68a6884cad1 *tests/testthat/test-cross.R
c548d3237286977e949b2b665b8a5792 *tests/testthat/test-depth.R
a22e930c9691c0655ba9c5fe94866adc *tests/testthat/test-every-some.R
14532ea09ed8dfca0d19e65a4f1d7c41 *tests/testthat/test-find-position.R
6857d64342f75696d507790e01efef80 *tests/testthat/test-flatten.R
fb8adbe7e936c917da7db33858f2df4a *tests/testthat/test-head-tail.R
d4c61639a083a3ec2dddc8a7cf632343 *tests/testthat/test-imap.R
5ffc01118f1e0f07b9c0d90cfcdce1cb *tests/testthat/test-invoke.R
1aad6ffcce7a01de2c838b1f475bd78d *tests/testthat/test-list-modify-update.R
325bad5b7fa5a5a642da9ce50753e437 *tests/testthat/test-lmap.R
c70e2e34a59f3a5986b1f2ba2a0128a3 *tests/testthat/test-map.R
2b67c975d77b2e433f0ad8ea693e0e47 *tests/testthat/test-map2.R
8c865f413f11c6a265d15e1f842df9b4 *tests/testthat/test-map_n.R
93bd710e49b0ae1af8dd27d021ddc39d *tests/testthat/test-modify.R
ce1638acb8d41d5bfe2fc29877484b8a *tests/testthat/test-negate.R
192dfcaa7553057ad63e307c8a474e5b *tests/testthat/test-output.R
d772931501f353938cd4f19fef56df05 *tests/testthat/test-partial.R
a3d9e4801e73a775b96e6e3c433285e5 *tests/testthat/test-pluck.R
ea532e7f3b213aff3ad4f66c6a23b7b4 *tests/testthat/test-predicates.R
b91718777144b4a6ad6d8ca71585a67c *tests/testthat/test-prepend.R
98068929576937ae3a307a5daa19a9fb *tests/testthat/test-recycle_args.R
273e7c7e8c27c6d25e8dae194f435de6 *tests/testthat/test-reduce.R
e34255b41581de0f6faf55eadd8cfbdb *tests/testthat/test-rerun.R
0eb43c0afc550daeead9401117b73f03 *tests/testthat/test-simplify.R
3f87bdf05305f94b2b5012ecdaabbb30 *tests/testthat/test-splice.R
0d12dc2b093f55b36f46c31a4c69dacb *tests/testthat/test-transpose.R
6069a05aa8cef11b1ca0a42d6067e7cb *tests/testthat/test-utils.R
7125b68b593f2e86140faabd4e8586ee *tests/testthat/test-when.R
d0a12786bea51ec8b9d57563e6edacd8 *vignettes/other-langs.Rmd
purrr/build/ 0000755 0001762 0000144 00000000000 13171650761 012532 5 ustar ligges users purrr/build/vignette.rds 0000644 0001762 0000144 00000000341 13171650761 015067 0 ustar ligges users mP0 ?Ix )/x%!cxIv}k= 3.1)
Imports: magrittr (>= 1.5), rlang (>= 0.1), tibble
Suggests: covr, dplyr (>= 0.4.3), knitr, rmarkdown, testthat
VignetteBuilder: knitr
LazyData: true
RoxygenNote: 6.0.1
NeedsCompilation: yes
Packaged: 2017-10-18 13:06:58 UTC; hadley
Author: Lionel Henry [aut, cre],
Hadley Wickham [aut],
RStudio [cph, fnd]
Maintainer: Lionel Henry