Implement vec_map()
#1227
+423
−24
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,6 @@ | ||
|
|
||
| vec_map <- function(.x, .fn, ..., .ptype = list()) { | ||
| .elt <- NULL # Defined in the mapping loop | ||
| .fn <- as_function(.fn) | ||
| .External(vctrs_map, .x, environment(), .ptype) | ||
| } |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,124 @@ | ||
| #include "vctrs.h" | ||
| #include "slice.h" | ||
| #include "utils.h" | ||
|
|
||
| // Defined at load time | ||
| SEXP vec_map_call = NULL; | ||
|
|
||
| static SEXP atomic_map(SEXP x, SEXP env, SEXP ptype); | ||
| static SEXP list_map(SEXP x, SEXP env, SEXP ptype); | ||
|
|
||
|
|
||
| SEXP vctrs_map(SEXP args) { | ||
| args = CDR(args); | ||
| SEXP x = CAR(args); args = CDR(args); | ||
| SEXP env = CAR(args); args = CDR(args); | ||
| SEXP ptype = CAR(args); | ||
|
|
||
| if (ptype == R_NilValue) { | ||
| r_abort("`.ptype` can't be NULL."); | ||
| } | ||
|
|
||
| SEXP orig = x; | ||
| bool list_input = vec_is_list(orig); | ||
| bool list_output = vec_is_list(ptype); | ||
|
|
||
| // Instead of using `[[` or equivalent to access the elements of | ||
| // atomic inputs, we chop them into a list | ||
| if (!list_input) { | ||
| x = vec_chop2(x); | ||
| } | ||
| PROTECT(x); | ||
|
|
||
| SEXP out; | ||
| if (list_output) { | ||
| out = list_map(x, env, ptype); | ||
| } else { | ||
| out = atomic_map(x, env, ptype); | ||
| } | ||
| PROTECT(out); | ||
|
|
||
| SEXP names = PROTECT(vec_names(orig)); | ||
| if (names != R_NilValue) { | ||
| vec_set_names(out, names); | ||
| } | ||
|
|
||
| UNPROTECT(3); | ||
| return out; | ||
| } | ||
|
|
||
| static | ||
| SEXP list_map(SEXP x, SEXP env, SEXP ptype) { | ||
| // When mapping to a list, we update the input list with the results | ||
| // inplace. We first zap the attributes of this list because it's | ||
| // cast to the target prototype later on. | ||
| SEXP out = PROTECT(r_clone_referenced(x)); | ||
| SET_ATTRIB(out, R_NilValue); | ||
| SET_OBJECT(out, 0); | ||
|
|
||
| r_ssize n = r_length(x); | ||
| const SEXP* p_x = VECTOR_PTR_RO(x); | ||
|
|
||
| for (r_ssize i = 0; i < n; ++i) { | ||
| r_env_poke(env, syms_dot_elt, p_x[i]); | ||
| SET_VECTOR_ELT(out, i, r_eval_force(vec_map_call, env)); | ||
| } | ||
|
|
||
| // Genericity is accomplished by casting the complete list of | ||
| // outputs to the target prototype. Should use a ptype identity | ||
| // check before casting. Probably `vec_cast()` should make that | ||
| // check. | ||
| if (OBJECT(ptype)) { | ||
| out = vec_cast(out, ptype, NULL, NULL); | ||
| } | ||
|
|
||
| UNPROTECT(1); | ||
| return out; | ||
| } | ||
|
|
||
| static | ||
| SEXP atomic_map(SEXP x, SEXP env, SEXP ptype) { | ||
| r_ssize n = r_length(x); | ||
|
|
||
| // Genericity is handled in a typical fashion when mapping to an | ||
| // atomic vector. We initialise the target prototype and coerce each | ||
| // element to that target before assigning. | ||
| SEXP out = PROTECT(vec_init(ptype, n)); | ||
|
|
||
| SEXP out_proxy = vec_proxy(out); | ||
| PROTECT_INDEX out_proxy_pi; | ||
| PROTECT_WITH_INDEX(out_proxy, &out_proxy_pi); | ||
|
|
||
| SEXP loc = PROTECT(compact_seq(0, 0, true)); | ||
| int* p_loc = INTEGER(loc); | ||
|
|
||
| const SEXP* p_x = VECTOR_PTR_RO(x); | ||
|
|
||
| for (r_ssize i = 0; i < n; ++i) { | ||
| r_env_poke(env, syms_dot_elt, p_x[i]); | ||
|
|
||
| SEXP elt_out = PROTECT(r_eval_force(vec_map_call, env)); | ||
| if (vec_size(elt_out) != 1) { | ||
| r_abort("Mapped function must return a size 1 vector."); | ||
|
There was a problem hiding this comment. Would be useful to includde index in this error message. |
||
| } | ||
|
|
||
| elt_out = PROTECT(vec_cast(elt_out, ptype, NULL, NULL)); | ||
|
|
||
| init_compact_seq(p_loc, i, 1, true); | ||
| out_proxy = vec_proxy_assign(out_proxy, loc, elt_out); | ||
|
|
||
| UNPROTECT(2); | ||
| REPROTECT(out_proxy, out_proxy_pi); | ||
| } | ||
|
|
||
| out = vec_restore(out_proxy, ptype, R_NilValue, VCTRS_OWNED_true); | ||
|
|
||
| UNPROTECT(3); | ||
| return out; | ||
| } | ||
|
|
||
|
|
||
| void vctrs_init_map(SEXP ns) { | ||
| vec_map_call = r_parse(".fn(.elt, ...)"); | ||
| R_PreserveObject(vec_map_call); | ||
| } | ||
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,185 @@ | ||
|
|
||
| test_that("vec_map() handles S3 vectors", { | ||
| vctr <- new_vctr(1:3) | ||
| rcrd <- new_rcrd(list(x = 1:3, y = 4:6)) | ||
|
|
||
| expect_identical( | ||
| vec_map(vctr, identity), | ||
| vec_chop(vctr) | ||
|
There was a problem hiding this comment. I think it would be better to define the expected output directly rather than in terms of another function, because I don't have enough of |
||
| ) | ||
| expect_identical( | ||
| vec_map(rcrd, identity), | ||
| vec_chop(rcrd) | ||
| ) | ||
|
|
||
| expect_identical( | ||
| vec_map(vctr, identity, .ptype = vctr), | ||
| vctr | ||
| ) | ||
| expect_identical( | ||
| vec_map(rcrd, identity, .ptype = rcrd), | ||
| rcrd | ||
| ) | ||
| }) | ||
|
|
||
| test_that("vec_map() handles S3 lists", { | ||
| local_list_rcrd_methods() | ||
| x <- new_list_rcrd(list(1:2, 3:5, 6:9)) | ||
|
|
||
| exp <- list(1:2, 3:4, 6:7) | ||
| expect_identical( | ||
| vec_map(x, `[`, 1:2), | ||
| exp | ||
| ) | ||
|
|
||
| expect_identical( | ||
| vec_map(x, `[`, 1:2, .ptype = x), | ||
| new_list_rcrd(exp) | ||
| ) | ||
| }) | ||
|
|
||
| test_that("vec_map() requires a non-NULL ptype", { | ||
| expect_error(vec_map(1, identity, .ptype = NULL), "can't be NULL") | ||
| }) | ||
|
|
||
| test_that("functions must return size 1 vector when mapping to atomic", { | ||
| expect_error( | ||
| map(1:2, rep, 2, .ptype = int()), | ||
| "must return a size 1 vector" | ||
| ) | ||
| }) | ||
|
|
||
|
|
||
| # Tests imported from purrr ----------------------------------------------- | ||
|
|
||
| # These tests rely on compat-purrr-vctrs | ||
|
|
||
| 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(.fn(.elt, ...))) | ||
| }) | ||
|
|
||
| test_that("fails on non-vectors", { | ||
| expect_error(map(environment(), identity), class = "vctrs_error_scalar_type") | ||
| expect_error(map(quote(a), identity), class = "vctrs_error_scalar_type") | ||
| }) | ||
|
|
||
| test_that("0 length input gives 0 length output", { | ||
| out1 <- map(list(), identity) | ||
| expect_equal(out1, list()) | ||
|
|
||
| return("Used to work in purrr") | ||
|
|
||
| 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)) | ||
|
|
||
| return("Used to work in purrr") | ||
|
|
||
| expect_identical(map_int(as.raw(0:1), identity), 0:1) | ||
| expect_identical(map_dbl(as.raw(0:1), identity), c(0, 1)) | ||
| expect_identical(map_chr(as.raw(0:255), identity), as.character(as.raw(0:255))) | ||
|
|
||
| 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("map_raw",{ | ||
| expect_equal(map_raw("a", charToRaw), charToRaw("a")) | ||
| }) | ||
|
|
||
| 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("map_if() and map_at() always return a list", { | ||
| skip_if_not_installed("tibble") | ||
| 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")) | ||
| }) | ||
|
|
||
| test_that("map_at() works with tidyselect", { | ||
| skip_if_not_installed("tidyselect") | ||
| x <- list(a = "b", b = "c", aa = "bb") | ||
| one <- map_at(x, quos(a), toupper) | ||
| expect_identical(one$a, "B") | ||
| expect_identical(one$aa, "bb") | ||
| two <- map_at(x, quos(tidyselect::contains("a")), toupper) | ||
| expect_identical(two$a, "B") | ||
| expect_identical(two$aa, "BB") | ||
| }) | ||
|
|
||
| test_that("negative .at omits locations", { | ||
| x <- c(1, 2, 3) | ||
| out <- map_at(x, -1, ~ .x * 2) | ||
| expect_equal(out, list(1, 4, 6)) | ||
| }) | ||
|
|
||
| test_that("map works with calls and pairlists", { | ||
| expect_true(TRUE) | ||
| return("Used to work in purrr") | ||
|
|
||
| out <- map(quote(f(x)), ~ quote(z)) | ||
| expect_equal(out, list(quote(z), quote(z))) | ||
|
|
||
| out <- map(pairlist(1, 2), ~ . + 1) | ||
| expect_equal(out, list(2, 3)) | ||
| }) | ||
|
|
||
| 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_if requires predicate functions", { | ||
| expect_error(map_if(1:3, ~ NA, ~ "foo"), "must return") | ||
| }) | ||
|
|
||
| test_that("`.else` maps false elements", { | ||
| expect_identical(map_if(-1:1, ~ .x > 0, paste, .else = ~ "bar", "suffix"), list("bar", "bar", "1 suffix")) | ||
| }) | ||
|
|
||
| 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())) | ||
| expect_identical(map_raw(named_list, identity), named(raw())) | ||
| }) | ||
Add this suggestion to a batch that can be applied as a single commit.
This suggestion is invalid because no changes were made to the code.
Suggestions cannot be applied while the pull request is closed.
Suggestions cannot be applied while viewing a subset of changes.
Only one suggestion per line can be applied in a batch.
Add this suggestion to a batch that can be applied as a single commit.
Applying suggestions on deleted lines is not supported.
You must change the existing code in this line in order to create a valid suggestion.
Outdated suggestions cannot be applied.
This suggestion has been applied or marked resolved.
Suggestions cannot be applied from pending reviews.
Suggestions cannot be applied on multi-line comments.
Suggestions cannot be applied while the pull request is queued to merge.
Suggestion cannot be applied right now. Please check back later.
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
Why does this change?
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
To avoid an infinite recursion.
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
But why did it work before?
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
Because
map()didn't use vctrs operations and genericity.The purrr compat file has been updated to use the vec_map() to get some internal testing and to make it easy to import unit tests from purrr.
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
oops sorry, the infinite recursion was another problem. It doesn't make sense for ptype-full to be recursed into anyway.
The problem is that
map()now assigns names, and partial factors and data frames don't support that:This is a flaw in the partial types but as usual I'm just working around these types when they cause problems for now.
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
We no longer assign
NULLnames to be a little more efficient. However thisunclass()change is still needed because partial types inherit fromvctrs_sclrwhich have an unsupportednames<-method but still allownames(), sovec_map()sees the internal field names. Making the latter unsupported causes a bunch of other issues. It wouldn't solve the problem at hand anyway because now we'd have a vector type for whichnames()is an error, which is a big genericity flaw. I think we shouldn't worry about these types too much for now.