apacheGH-42220: [R] handle vctrs_rcrd extension type in metadata clea…

…ning

r/R/extension.R

@@ -429,7 +429,8 @@ VctrsExtensionType <- R6Class("VctrsExtensionType",
  paste0(capture.output(print(self$ptype())), collapse = "\n")
  },
  deserialize_instance = function() {
- private$.ptype <- safe_r_metadata(safe_unserialize(self$extension_metadata()))
+ private$.ptype <- safe_unserialize(self$extension_metadata())
+ attributes(private$.ptype) <- safe_r_metadata(attributes(private$.ptype))
  },
  ExtensionEquals = function(other) {
  inherits(other, "VctrsExtensionType") && identical(self$ptype(), other$ptype())
@@ -510,11 +511,13 @@ vctrs_extension_array <- function(x, ptype = vctrs::vec_ptype(x),
 vctrs_extension_type <- function(x,
  storage_type = infer_type(vctrs::vec_data(x))) {
  ptype <- vctrs::vec_ptype(x)
+ # Make sure there are no unsupported objects buried in there
+ attributes(ptype) <- safe_r_metadata(attributes(ptype))
 
  new_extension_type(
  storage_type = storage_type,
  extension_name = "arrow.r.vctrs",
- extension_metadata = serialize(ptype, NULL),
+ extension_metadata = serialize(ptype, NULL, ascii = TRUE),
  type_class = VctrsExtensionType
  )
 }

r/tests/testthat/test-extension.R

@@ -343,3 +343,11 @@ test_that("Dataset/arrow_dplyr_query can roundtrip extension types", {
 
  expect_identical(unclass(roundtripped$extension), roundtripped$letter)
 })
+
+test_that("Handling vctrs_rcrd type", {
+ df <- data.frame(
+ x = vctrs::new_rcrd(fields = list(special = 1:3), class = "special")
+ )
+ tab <- arrow_table(df)
+ expect_identical(as.data.frame(tab), df)
+})