diff --git a/NEWS.md b/NEWS.md index cc0e80d..688dbfe 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,13 @@ # zeallot (development version) +## Breaking changes + +* For bare atomic inputs, the collector now retains the original input class rather than collecting elements into a vectorizable list. (#67) + +## Bug fixes + +* The collector no longer flattens the first collected element of a list, instead retaining the original structure and name. (#65) + # zeallot 0.2.0 ## Breaking changes diff --git a/R/operator.R b/R/operator.R index e316254..3b92e60 100644 --- a/R/operator.R +++ b/R/operator.R @@ -128,7 +128,11 @@ pairs <- unpack(substitute(x), value) - list_assign(pairs, parent.frame()) + list_assign( + pairs, + parent.frame(), + is.atomic(value) && !is.object(value) + ) invisible(value) } @@ -140,7 +144,11 @@ pairs <- unpack(substitute(x), value) - list_assign(pairs, parent.frame()) + list_assign( + pairs, + parent.frame(), + is.atomic(value) && !is.object(value) + ) invisible(value) } diff --git a/R/utils.R b/R/utils.R index 253aa53..0b61271 100644 --- a/R/utils.R +++ b/R/utils.R @@ -49,18 +49,21 @@ prepend <- function(x, y) { } list_compress <- function(x, len) { - stopifnot( - is.list(x) - ) + stopifnot(is.list(x), len >= 1L) + + x_len <- length(x) - if (length(x) <= len) { + if (x_len <= len) { return(x) } - list_compress(c(list(c(x[[1]], x[2])), x[c(-1, -2)]), len) + c( + list(head(x, x_len - len + 1L)), + tail(x, len - 1L) + ) } -list_assign <- function(x, envir = parent.frame()) { +list_assign <- function(x, envir = parent.frame(), simplify = FALSE) { if (is_empty_list(x)) { return() } @@ -69,9 +72,13 @@ list_assign <- function(x, envir = parent.frame()) { name <- pair[[1]] value <- pair[[2]] + if (is.list(value) && simplify) { + value <- unlist(value) + } + eval(call("<-", name, bquote(quote(.(value)))), envir = envir) - list_assign(cdr(x), envir) + list_assign(cdr(x), envir, simplify) } attempt_assign <- function(expr, call = sys.call(-1)) { diff --git a/tests/testthat/test-bare-atomic-simplify.R b/tests/testthat/test-bare-atomic-simplify.R new file mode 100644 index 0000000..2bfa36f --- /dev/null +++ b/tests/testthat/test-bare-atomic-simplify.R @@ -0,0 +1,49 @@ +test_that("collecting from bare atomics simplifies", { + v <- c(a = 1, b = 2, c = 3, d = 4) + + c(x, ..y) %<-% v + + expect_identical(x, v[[1]]) + expect_identical(y, v[2:4]) + expect_identical(names(y), names(v)[2:4]) + + c(..x, y) %<-% v + + expect_identical(x, v[1:3]) + expect_identical(names(x), names(v)[1:3]) + expect_identical(y, v[[4]]) + + c(x, ..y, z) %<-% v + + expect_identical(x, v[[1]]) + expect_identical(z, v[[4]]) + expect_identical(y, v[2:3]) + expect_identical(names(y), names(v)[2:3]) +}) + +test_that("collecting from S3 atomics returns list", { + v <- structure( + 1:4, + class = "test_atomic", + names = letters[1:4] + ) + + c(x, ..y) %<-% v + + expect_identical(x, v[[1]]) + expect_null(attributes(x)) + expect_identical(y, list(b = v[[2]], c = v[[3]], d = v[[4]])) + expect_identical(names(y), letters[2:4]) + + c(..x, y) %<-% v + + expect_identical(x, list(a = v[[1]], b = v[[2]], c = v[[3]])) + expect_identical(names(x), letters[1:3]) + expect_identical(y, v[[4]]) + + c(x, ..y, z) %<-% v + + expect_identical(x, v[[1]]) + expect_identical(z, v[[4]]) + expect_identical(y, list(b = v[[2]], c = v[[3]])) +}) diff --git a/tests/testthat/test-collectors.R b/tests/testthat/test-collectors.R index 4ba1850..f62fecd 100644 --- a/tests/testthat/test-collectors.R +++ b/tests/testthat/test-collectors.R @@ -3,10 +3,19 @@ test_that("collect start", { expect_equal(y, 5) + c(.., y) %<-% list(x = 1:3, y = 4:6, z = 7:9) + + expect_equal(y, 7:9) + c(..x, y) %<-% 1:5 - expect_equal(x, list(1, 2, 3, 4)) + expect_equal(x, c(1, 2, 3, 4)) expect_equal(y, 5) + + c(..x, y) %<-% list(x = 1:3, y = 4:6, z = 7:9) + + expect_equal(x, list(x = 1:3, y = 4:6)) + expect_equal(y, 7:9) }) test_that("collect middle", { @@ -15,11 +24,21 @@ test_that("collect middle", { expect_equal(x, 1) expect_equal(z, 5) + c(x, ..y, z) %<-% list(x = 1:3, y = 4:6, z = 7:9) + expect_equal(x, 1:3) + expect_equal(y, 4:6) + expect_equal(z, 7:9) + c(x, ..y, z) %<-% 5:1 expect_equal(x, 5) - expect_equal(y, list(4, 3, 2)) + expect_equal(y, c(4, 3, 2)) expect_equal(z, 1) + + c(x, ..y, z) %<-% list(x = 1:3, y = 4:6, z = 7:9, a = 10:12) + expect_equal(x, 1:3) + expect_equal(y, list(y = 4:6, z = 7:9)) + expect_equal(z, 10:12) }) test_that("collect end", { @@ -27,10 +46,19 @@ test_that("collect end", { expect_equal(x, 1) + c(x, ..) %<-% list(x = 1:3, y = 4:6, z = 7:9) + + expect_equal(x, 1:3) + c(x, ..y) %<-% 1:3 expect_equal(x, 1) - expect_equal(y, list(2, 3)) + expect_equal(y, c(2, 3)) + + c(x, ..y) %<-% list(x = 1:3, y = 4:6, z = 7:9) + + expect_equal(x, 1:3) + expect_equal(y, list(y = 4:6, z = 7:9)) }) test_that("defaults to NULL", { diff --git a/tests/testthat/test-destructure.R b/tests/testthat/test-destructure.R index 5a30d1b..bdf5035 100644 --- a/tests/testthat/test-destructure.R +++ b/tests/testthat/test-destructure.R @@ -4,6 +4,10 @@ test_that("included data.frame implementation", { expect_equal(mpg, mtcars$mpg) expect_equal(cyl, mtcars$cyl) expect_equal(carb, mtcars$carb) + + c(mpg, cyl, ..x) %<-% mtcars + + expect_equal(x, as.list(mtcars[3:ncol(mtcars)])) }) test_that("included summary implementation", { diff --git a/tests/testthat/test-pipe.R b/tests/testthat/test-pipe.R index 2cf1a29..5d38452 100644 --- a/tests/testthat/test-pipe.R +++ b/tests/testthat/test-pipe.R @@ -4,5 +4,5 @@ test_that("native pipe", { c(x, ..y) expect_equal(x, TRUE) - expect_equal(y, list(FALSE, FALSE, FALSE, FALSE)) + expect_equal(y, c(FALSE, FALSE, FALSE, FALSE)) })