perf(r): reuse single-chunk nanoarrow vectors

r/NAMESPACE

@@ -39,6 +39,7 @@ S3method(as_nanoarrow_array,list)
 S3method(as_nanoarrow_array,matrix)
 S3method(as_nanoarrow_array,nanoarrow_array)
 S3method(as_nanoarrow_array,nanoarrow_buffer)
+S3method(as_nanoarrow_array,nanoarrow_vctr)
 S3method(as_nanoarrow_array,python.builtin.object)
 S3method(as_nanoarrow_array,vctrs_unspecified)
 S3method(as_nanoarrow_array_extension,default)

r/R/vctr.R

@@ -154,6 +154,54 @@ as_nanoarrow_schema.nanoarrow_vctr <- function(x, ...) {
   attr(x, "schema", exact = TRUE)
 }
 
+#' @export
+as_nanoarrow_array.nanoarrow_vctr <- function(x, ..., schema = NULL) {
+  x_schema <- attr(x, "schema", exact = TRUE)
+  update_schema <- FALSE
+  if (!is.null(schema)) {
+    # A field name is not part of an array's physical type. In particular,
+    # data.frame conversion supplies the column name on its child schema even
+    # though the schema stored by the vctr usually has an empty name.
+    if (!nanoarrow_schema_identical(schema, x_schema)) {
+      schema_proxy <- nanoarrow_schema_proxy(schema, recursive = TRUE)
+      x_schema_proxy <- nanoarrow_schema_proxy(x_schema, recursive = TRUE)
+      schema_proxy$name <- NULL
+      x_schema_proxy$name <- NULL
+      if (!identical(schema_proxy, x_schema_proxy)) {
+        return(NextMethod())
+      }
+
+      update_schema <- TRUE
+    }
+  }
+
+  # A full-slice, single-chunk vctr is already represented by exactly the
+  # ArrowArray requested by the caller. Reuse it instead of dispatching to a
+  # potentially expensive extension conversion.
+  slice <- vctr_as_slice(x)
+  chunks <- attr(x, "chunks", exact = TRUE)
+  offsets <- attr(x, "offsets", exact = TRUE)
+  if (
+    length(chunks) == 1 &&
+      !is.null(slice) &&
+      slice[1] == 1 &&
+      slice[2] == max(offsets)
+  ) {
+    if (!update_schema) {
+      return(chunks[[1]])
+    }
+
+    # Export a shallow copy so that attaching the requested field name does
+    # not modify the schema associated with the vctr's source chunk.
+    out <- nanoarrow_allocate_array()
+    nanoarrow_pointer_export(chunks[[1]], out)
+    nanoarrow_array_set_schema(out, schema, validate = FALSE)
+    return(out)
+  }
+
+  NextMethod()
+}
+
 #' @export
 as_nanoarrow_array_stream.nanoarrow_vctr <- function(x, ..., schema = NULL) {
   as_nanoarrow_array_stream.nanoarrow_vctr(x, ..., schema = schema)

r/tests/testthat/test-vctr.R

@@ -80,6 +80,24 @@ test_that("nanoarrow_vctr works in a data.frame()", {
   expect_error(as.data.frame(vctr), "cannot coerce object")
 })
 
+test_that("single-chunk nanoarrow_vctr converts to an array without copying", {
+  vctr <- as_nanoarrow_vctr(as_nanoarrow_array(c("one", "two")))
+  chunk <- attr(vctr, "chunks", exact = TRUE)[[1]]
+
+  expect_identical(as_nanoarrow_array(vctr), chunk)
+  expect_identical(as_nanoarrow_array(vctr, schema = na_string()), chunk)
+
+  named_schema <- na_string()
+  named_schema$name <- "x"
+  named_array <- as_nanoarrow_array(vctr, schema = named_schema)
+  expect_false(identical(named_array, chunk))
+  expect_identical(infer_nanoarrow_schema(named_array)$name, "x")
+
+  array <- as_nanoarrow_array(data.frame(x = vctr))
+  expect_identical(as.data.frame(array), data.frame(x = c("one", "two")))
+  expect_identical(infer_nanoarrow_schema(chunk)$name, "")
+})
+
 test_that("format() works for nanoarrow_vctr", {
   empty_vctr <- nanoarrow_vctr(na_string())
   expect_identical(format(empty_vctr), character())