Implement vec_chop2()

NAMESPACE

@@ -49,6 +49,7 @@ S3method("length<-",vctrs_rcrd)
 S3method("length<-",vctrs_vctr)
 S3method("levels<-",vctrs_sclr)
 S3method("levels<-",vctrs_vctr)
+S3method("names<-",vctrs_rcrd)
 S3method("names<-",vctrs_sclr)
 S3method("names<-",vctrs_vctr)
 S3method("|",vctrs_vctr)

R/slice-chop.R

@@ -105,3 +105,7 @@ vec_chop_seq <- function(x, starts, sizes, increasings = TRUE) {
   args <- vec_recycle_common(starts, sizes, increasings)
   .Call(vctrs_chop_seq, x, args[[1]], args[[2]], args[[3]])
 }
+
+vec_chop2 <- function(x) {
+  .External(vctrs_chop2, x)
+}

R/type-rcrd.R

@@ -70,6 +70,13 @@ length.vctrs_rcrd <- function(x) {
 names.vctrs_rcrd <- function(x) {
   NULL
 }
+#' @export
+`names<-.vctrs_rcrd` <- function(x, value) {
+  if (!is_null(value)) {
+    abort("Can't set names of record vectors.")
+  }
+  x
+}
 
 #' @export
 format.vctrs_rcrd <- function(x, ...) {

R/type-vctr.R

@@ -298,13 +298,7 @@ as.character.vctrs_vctr <- function(x, ...) {
 
 #' @export
 as.list.vctrs_vctr <- function(x, ...) {
-  out <- vec_chop(x)
-
-  if (vec_is_list(x)) {
-    out <- lapply(out, `[[`, 1)
-  }
-
-  out
+  vec_chop2(x)
 }
 
 #' @export

src/init.c

@@ -278,6 +278,7 @@ extern SEXP vctrs_rbind(SEXP, SEXP, SEXP, SEXP);
 extern SEXP vctrs_cbind(SEXP, SEXP, SEXP, SEXP);
 extern SEXP vctrs_c(SEXP, SEXP, SEXP, SEXP);
 extern SEXP vctrs_new_data_frame(SEXP);
+extern SEXP vctrs_chop2(SEXP);
 
 static const R_ExternalMethodDef ExtEntries[] = {
   {"vctrs_type_common",                (DL_FUNC) &vctrs_type_common, 1},
@@ -290,6 +291,7 @@ static const R_ExternalMethodDef ExtEntries[] = {
   {"vctrs_cbind",                      (DL_FUNC) &vctrs_cbind, 3},
   {"vctrs_c",                          (DL_FUNC) &vctrs_c, 3},
   {"vctrs_new_data_frame",             (DL_FUNC) &vctrs_new_data_frame, -1},
+  {"vctrs_chop2",                      (DL_FUNC) &vctrs_chop2, 1},
   {NULL, NULL, 0}
 };
 

src/slice-chop.c

@@ -414,3 +414,41 @@ SEXP vec_as_indices(SEXP indices, R_len_t n, SEXP names) {
   UNPROTECT(1);
   return indices;
 }
+
+// -----------------------------------------------------------------------------
+
+// [[ register(external = TRUE) ]]
+SEXP vctrs_chop2(SEXP args) {
+  return vec_chop2(CADR(args));
+}
+
+// [[ include("slice.h") ]]
+SEXP vec_chop2(SEXP x) {
+  if (r_is_bare_list(x)) {
+    return x;
+  }
+
+  SEXP out;
+
+  if (vec_is_list(x)) {
+    // Lists necessarily have list storage and so don't require any
+    // genericity for extracting elements
+    out = PROTECT(r_clone_referenced(x));
+    SET_ATTRIB(out, R_NilValue);
+    SET_OBJECT(out, 0);
+
+    UNPROTECT(1);
+  } else {
+    // Zap inner names of atomic vectors. They become outer names.
+    out = PROTECT(vec_set_names(x, R_NilValue));
+    out = vec_chop(out, R_NilValue);
+    UNPROTECT(1);
+  }
+  PROTECT(out);
+
+  SEXP names = PROTECT(vec_names(x));
+  out = vec_set_names(out, names);
+
+  UNPROTECT(2);
+  return out;
+}

src/slice.h

@@ -11,5 +11,7 @@ SEXP vec_slice_fallback(SEXP x, SEXP subscript);
 
 bool vec_is_restored(SEXP x, SEXP to);
 
+SEXP vec_chop2(SEXP x);
+
 
 #endif

src/utils.c

@@ -1623,6 +1623,24 @@ void stop_internal(const char* fn, const char* fmt, ...) {
 #undef FMT_BUFSIZE
 
 
+bool r_is_bare_list(SEXP x) {
+  if (TYPEOF(x) != VECSXP) {
+    return false;
+  }
+
+  SEXP attrib = r_attrib(x);
+
+  while (attrib != r_null) {
+    if (r_node_tag(attrib) != r_syms_names) {
+      return false;
+    }
+    attrib = r_node_cdr(attrib);
+  }
+
+  return true;
+}
+
+
 bool vctrs_debug_verbose = false;
 
 SEXP vctrs_ns_env = NULL;

src/utils.h

@@ -494,6 +494,8 @@ r_ssize r_ssize_add(r_ssize x, r_ssize y) {
 
 SEXP chr_c(SEXP x, SEXP y);
 
+bool r_is_bare_list(SEXP x);
+
 
 extern SEXP vctrs_ns_env;
 extern SEXP vctrs_shared_empty_str;

tests/testthat/helper-s3.R

@@ -139,7 +139,7 @@ foobar_df_ptype2 <- function(x, y, ...) {
 foobar_df_cast <- function(x, y, ...) {
   foobar(df_cast(x, y, ...))
 }
-local_foobar_df_methods <- function(expr, frame = caller_env()) {
+local_foobar_df_methods <- function(frame = caller_env()) {
   local_methods(
     .frame = frame,
     vec_ptype2.vctrs_foobar.vctrs_foobar = foobar_df_ptype2,
@@ -154,3 +154,35 @@ with_foobar_df_methods <- function(expr) {
   local_foobar_df_methods()
   expr
 }
+
+# List that caches the size of its elements in a record field
+new_list_rcrd <- function(x, sizes = NULL) {
+  stopifnot(
+    vec_is_list(x),
+    is_null(sizes) || is_integer(sizes, n = length(x))
+  )
+
+  x <- vec_data(x)
+
+  if (is_null(sizes)) {
+    sizes <- list_sizes(x)
+  } else {
+    missing <- is.na(sizes)
+    sizes[missing] <- list_sizes(x[missing])
+  }
+
+  structure(x, sizes = sizes, class = c("vctrs_list_rcrd", "list"))
+}
+local_list_rcrd_methods <- function(frame = caller_env()) {
+  local_methods(
+    .frame = frame,
+    vec_proxy.vctrs_list_rcrd = function(x, ...) data_frame(data = unclass(x), sizes = attr(x, "sizes")),
+    vec_restore.vctrs_list_rcrd = function(x, to, ...) new_list_rcrd(x$data, x$sizes),
+    vec_ptype2.vctrs_list_rcrd.vctrs_list_rcrd = function(x, y, ...) x,
+    vec_ptype2.vctrs_list_rcrd.list = function(x, y, ...) x,
+    vec_ptype2.list.vctrs_list_rcrd = function(x, y, ...) y,
+    vec_cast.vctrs_list_rcrd.vctrs_list_rcrd = function(x, to, ...) x,
+    vec_cast.list.vctrs_list_rcrd = function(x, to, ...) vec_data(x),
+    vec_cast.vctrs_list_rcrd.list = function(x, to, ...) new_list_rcrd(x, sizes = vec_init(int(), length(x)))
+  )
+}

tests/testthat/performance/test-slice-chop.txt

@@ -0,0 +1,51 @@
+> local_list_rcrd_methods()
+> n <- 100
+> # Atomic vector
+> vec <- rep(c(a = 1L, b = 2L), n)
+> with_memory_prof(vec_chop2(vec))
+[1] 2.44KB
+
+> # S3 atomic vector
+> vec_s3 <- new_vctr(vec)
+> with_memory_prof(vec_chop2(vec_s3))
+[1] 1.61KB
+
+> # Record vector
+> vec_rcrd <- rep(new_rcrd(list(a = 1:2, b = 3:4)), n)
+> with_memory_prof(vec_chop2(vec_rcrd))
+[1] 4.83KB
+
+> # Data frame
+> df <- vec_rep(data.frame(x = 1, y = 2), n)
+> with_memory_prof(vec_chop2(df))
+[1] 2.48KB
+
+> # S3 data frame
+> tib <- vec_rep(tibble(x = 1, y = 2), n)
+> with_memory_prof(vec_chop2(tib))
+[1] 2.48KB
+
+
+List
+====
+
+> list <- rep(list(a = c(foo = 1:2), b = c(bar = 1:3)), n)
+> with_memory_prof(vec_chop2(list))
+[1] 0B
+
+
+S3 list
+=======
+
+> vctr <- new_vctr(list)
+> with_memory_prof(vec_chop2(vctr))
+[1] 1.61KB
+
+
+S3 record list
+==============
+
+> list_rcrd <- new_list_rcrd(list)
+> with_memory_prof(vec_chop2(list_rcrd))
+[1] 1.61KB
+

tests/testthat/test-slice-chop.R

@@ -229,6 +229,81 @@ test_that("can chop S3 objects using the fallback method with compact seqs", {
   expect_equal(vec_chop_seq(x, 2L, 2L), list(vec_slice(x, 3:4)))
 })
 
+
+# vec_chop2 ---------------------------------------------------------------
+
+test_that("vec_chop2() transforms inner names to outer names", {
+  x <- c(a = 1, b = 2)
+  expect_identical(
+    vec_chop2(x),
+    list(a = 1, b = 2)
+  )
+
+  x <- data.frame(x = 1:2, row.names = c("foo", "bar"))
+  exp <- list(
+    foo = data.frame(x = 1L),
+    bar = data.frame(x = 2L)
+  )
+  expect_identical(vec_chop2(x), exp)
+
+  x <- matrix(1:4, 2)
+  row.names(x) <- c("foo", "bar")
+
+  # Fails because of #1221
+  # exp <- list(
+  #   foo = matrix(c(1L, 3L), 1),
+  #   bar = matrix(c(2L, 4L), 1)
+  # )
+  # expect_identical(vec_chop2(x), exp)
+
+  out <- vec_chop2(x)
+  expect_null(row.names(out[[1]]))
+  expect_null(row.names(out[[2]]))
+})
+
+test_that("vec_chop2() preserves names of lists", {
+  x <- list(a = 1, b = 2)
+  expect_identical(vec_chop2(x), x)
+
+  s3 <- new_vctr(x)
+  out <- vec_chop2(s3)
+  expect_identical(out, x)
+  expect_false(is.object(out))
+})
+
+test_that("vec_chop2() works with generic atomic vectors", {
+  x <- set_names(new_vctr(1:2), letters[1:2])
+  exp <- list(
+    a = new_vctr(1L),
+    b = new_vctr(2L)
+  )
+  expect_identical(vec_chop2(x), exp)
+
+  # TODO: Test with names once rcrd vectors support them
+  x <- new_rcrd(list(x = 1:2, y = 3:4))
+  exp <- list(
+    new_rcrd(list(x = 1L, y = 3L)),
+    new_rcrd(list(x = 2L, y = 4L))
+  )
+
+  expect_identical(vec_chop(x), exp) # FIXME: Only because rcrd is unnamed
+  expect_identical(vec_chop2(x), exp)
+})
+
+test_that("vec_chop2() works with generic lists", {
+  x <- list(a = c(foo = 1:2), b = c(bar = 1:3))
+
+  expect_identical(vec_chop2(new_vctr(x)), x)
+
+  local_list_rcrd_methods()
+  expect_identical(vec_chop2(new_list_rcrd(x)), x)
+})
+
+test_that("vec_chop2() zaps attributes", {
+  expect_identical(vec_chop2(structure(list(), foo = TRUE)), list())
+})
+
+
 # vec_unchop --------------------------------------------------------------
 
 test_that("`x` must be a list", {
@@ -774,6 +849,9 @@ test_that("vec_unchop() fails if foreign classes are not homogeneous and there i
   )
 })
 
+
+# Golden tests ------------------------------------------------------------
+
 test_that("vec_unchop() has informative error messages", {
   verify_output(test_path("error", "test-unchop.txt"), {
     "# vec_unchop() errors on unsupported location values"
@@ -814,3 +892,42 @@ test_that("vec_unchop() has informative error messages", {
       )
   })
 })
+
+test_that("chop functions have expected memory footprint", {
+  verify_output(test_path("performance", "test-slice-chop.txt"), {
+    local_list_rcrd_methods()
+    n <- 1e2
+
+    "Atomic vector"
+    vec <- rep(c(a = 1L, b = 2L), n)
+    with_memory_prof(vec_chop2(vec))
+
+    "S3 atomic vector"
+    vec_s3 <- new_vctr(vec)
+    with_memory_prof(vec_chop2(vec_s3))
+
+    "Record vector"
+    vec_rcrd <- rep(new_rcrd(list(a = 1:2, b = 3:4)), n)
+    with_memory_prof(vec_chop2(vec_rcrd))
+
+    "Data frame"
+    df <- vec_rep(data.frame(x = 1, y = 2), n)
+    with_memory_prof(vec_chop2(df))
+
+    "S3 data frame"
+    tib <- vec_rep(tibble(x = 1, y = 2), n)
+    with_memory_prof(vec_chop2(tib))
+
+    "# List"
+    list <- rep(list(a = c(foo = 1:2), b = c(bar = 1:3)), n)
+    with_memory_prof(vec_chop2(list))
+
+    "# S3 list"
+    vctr <- new_vctr(list)
+    with_memory_prof(vec_chop2(vctr))
+
+    "# S3 record list"
+    list_rcrd <- new_list_rcrd(list)
+    with_memory_prof(vec_chop2(list_rcrd))
+  })
+})