Retain atomic class for bare atomic inputs on collection

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

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)
 }

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)) {

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]]))
+})

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,22 +24,41 @@ 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", {
   c(x, ..) %<-% 1:3
 
   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", {

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", {

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))
 })