(arrow-nanoarrow) branch main updated: fix(r): reuse single-chunk nanoarrow vectors in as_nanoarrow_array (#951)

[pa...@apache.org]

This is an automated email from the ASF dual-hosted git repository.

paleolimbot pushed a commit to branch main
in repository https://gitbox.apache.org/repos/asf/arrow-nanoarrow.git


The following commit(s) were added to refs/heads/main by this push:
     new efe42748 fix(r): reuse single-chunk nanoarrow vectors in as_nanoarrow_array (#951)
efe42748 is described below

commit efe42748545c5c886391e1794786828aff09711d
Author: Dewey Dunnington <de...@dunnington.ca>
AuthorDate: Wed Oct 21 12:14:17 2026 -0500

    fix(r): reuse single-chunk nanoarrow vectors in as_nanoarrow_array (#951)
    
    Adds an `as_nanoarrow_array.nanoarrow_vctr()` fast path for full-slice,
    single-chunk vectors. Existing buffers are reused; a shallow array
    wrapper is created only when a data-frame field name must be attached.
    This avoids extension round-trips such as rebuilding GeoArrow geometry
    through WK.
    
    On a 3.23M-row GeoArrow reproduction, data-frame-to-stream conversion
    fell from 3.44 s to 0.32 s. The available R test suite and `R CMD check
    --no-manual` pass.
    
    ```r
    library(nanoarrow)
    x <- as_nanoarrow_vctr(as_nanoarrow_array(c("one", "two")))
    as.data.frame(as_nanoarrow_array(data.frame(x = x)))
    #>     x
    #> 1 one
    #> 2 two
    ```
---
 r/NAMESPACE                    |  1 +
 r/R/schema.R                   | 20 +++++++----
 r/R/vctr.R                     | 68 ++++++++++++++++++++++++++++++++++--
 r/tests/testthat/test-schema.R | 17 +++++++++
 r/tests/testthat/test-vctr.R   | 79 ++++++++++++++++++++++++++++++++++++++++--
 5 files changed, 175 insertions(+), 10 deletions(-)

diff --git a/r/NAMESPACE b/r/NAMESPACE
index 1ce6c21e..05b280fc 100644
--- a/r/NAMESPACE
+++ b/r/NAMESPACE
@@ -40,6 +40,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)
diff --git a/r/R/schema.R b/r/R/schema.R
index 31211f6b..df6f41be 100644
--- a/r/R/schema.R
+++ b/r/R/schema.R
@@ -287,12 +287,20 @@ nanoarrow_schema_modify <- function(x, new_values, validate = TRUE) {
   schema_deep_copy
 }
 
-nanoarrow_schema_identical <- function(x, y) {
-  identical(x, y) ||
-    identical(
-      nanoarrow_schema_proxy(x, recursive = TRUE),
-      nanoarrow_schema_proxy(y, recursive = TRUE)
-    )
+nanoarrow_schema_identical <- function(x, y, ignore_name = FALSE) {
+  if (identical(x, y)) {
+    return(TRUE)
+  }
+
+  x_proxy <- nanoarrow_schema_proxy(x, recursive = TRUE)
+  y_proxy <- nanoarrow_schema_proxy(y, recursive = TRUE)
+
+  if (ignore_name) {
+    x_proxy$name <- NULL
+    y_proxy$name <- NULL
+  }
+
+  identical(x_proxy, y_proxy)
 }
 
 #' @importFrom utils str
diff --git a/r/R/vctr.R b/r/R/vctr.R
index 4d1c443b..1e8f1103 100644
--- a/r/R/vctr.R
+++ b/r/R/vctr.R
@@ -154,6 +154,62 @@ 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.
+    schemas_identical <- nanoarrow_schema_identical(schema, x_schema)
+    if (!schemas_identical) {
+      if (!nanoarrow_schema_identical(schema, x_schema, ignore_name = TRUE)) {
+        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)) {
+    is_full_slice <- isTRUE(slice[1] == 1L) && slice[2] == max(offsets)
+    if (is_full_slice) {
+      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)
+    }
+
+    # An empty slice has no meaningful start index; any zero-length slice of
+    # the source array represents it. Otherwise, convert the 1-based vector
+    # index to an offset relative to the source array.
+    slice_offset <- if (slice[2] == 0L) 0L else slice[1] - 1L
+    if (!is.na(slice_offset)) {
+      out <- vctr_array_slice(chunks[[1]], slice_offset, slice[2])
+      if (update_schema) {
+        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)
@@ -266,7 +322,10 @@ c.nanoarrow_vctr <- function(...) {
 #' @export
 as.data.frame.nanoarrow_vctr <- function(x, ..., optional = FALSE) {
   if (!optional) {
-    stop(sprintf("cannot coerce object of tyoe '%s' to data.frame", class(x)[1]))
+    stop(sprintf(
+      "cannot coerce object of tyoe '%s' to data.frame",
+      class(x)[1]
+    ))
   } else {
     new_data_frame(list(x), nrow = length(x))
   }
@@ -335,9 +394,14 @@ vctr_as_slice <- function(x) {
 vctr_array_slice <- function(x, offset, length) {
   new_offset <- x$offset + offset
   new_length <- length
+  new_null_count <- if (length == 0 || x$null_count == 0) 0 else -1
   nanoarrow_array_modify(
     x,
-    list(offset = new_offset, length = new_length),
+    list(
+      offset = new_offset,
+      length = new_length,
+      null_count = new_null_count
+    ),
     validate = FALSE
   )
 }
diff --git a/r/tests/testthat/test-schema.R b/r/tests/testthat/test-schema.R
index 708b1bed..321ed807 100644
--- a/r/tests/testthat/test-schema.R
+++ b/r/tests/testthat/test-schema.R
@@ -34,6 +34,23 @@ test_that("as_nanoarrow_schema() works for nanoarrow_schema", {
   expect_identical(as_nanoarrow_schema(schema), schema)
 })
 
+test_that("nanoarrow_schema_identical() can ignore the root name", {
+  schema <- na_int32()
+  named_schema <- na_int32()
+  named_schema$name <- "x"
+
+  expect_false(nanoarrow_schema_identical(schema, named_schema))
+  expect_true(
+    nanoarrow_schema_identical(schema, named_schema, ignore_name = TRUE)
+  )
+
+  schema_x <- na_struct(list(x = na_int32()))
+  schema_y <- na_struct(list(y = na_int32()))
+  expect_false(
+    nanoarrow_schema_identical(schema_x, schema_y, ignore_name = TRUE)
+  )
+})
+
 test_that("infer_nanoarrow_schema() errors for unsupported types", {
   expect_error(
     infer_nanoarrow_schema(environment()),
diff --git a/r/tests/testthat/test-vctr.R b/r/tests/testthat/test-vctr.R
index 95bbd14f..82451690 100644
--- a/r/tests/testthat/test-vctr.R
+++ b/r/tests/testthat/test-vctr.R
@@ -28,7 +28,7 @@ test_that("as_nanoarrow_vctr() works for basic input", {
 test_that("print() and str() work on empty nanoarrow_vctr", {
   vctr <- nanoarrow_vctr()
   expect_identical(
-    expect_output(print(vctr),"<nanoarrow_vctr <any>>"),
+    expect_output(print(vctr), "<nanoarrow_vctr <any>>"),
     vctr
   )
 
@@ -80,6 +80,78 @@ 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("single-chunk nanoarrow_vctr slices convert to shallow arrays", {
+  array <- as_nanoarrow_array(c("one", NA, "three"))
+  vctr <- as_nanoarrow_vctr(array)
+
+  sliced <- as_nanoarrow_array(vctr[2:3])
+  expect_identical(sliced$offset, 1L)
+  expect_identical(sliced$length, 2L)
+  expect_identical(sliced$null_count, -1L)
+  expect_identical(as.vector(sliced), c(NA_character_, "three"))
+
+  named_schema <- na_string()
+  named_schema$name <- "x"
+  named_slice <- as_nanoarrow_array(vctr[2:3], schema = named_schema)
+  expect_identical(infer_nanoarrow_schema(named_slice)$name, "x")
+  expect_identical(as.vector(named_slice), c(NA_character_, "three"))
+
+  empty <- as_nanoarrow_array(vctr[integer()])
+  expect_identical(empty$length, 0L)
+  expect_identical(empty$null_count, 0L)
+  expect_identical(as.vector(empty), character())
+
+  expect_identical(array$offset, 0L)
+  expect_identical(array$length, 3L)
+  expect_identical(array$null_count, 1L)
+})
+
+test_that("nanoarrow_vctr array fast path falls through for other cases", {
+  array <- as_nanoarrow_array(c("one", "two"))
+  vctr <- as_nanoarrow_vctr(array)
+  multi_chunk_vctr <- new_nanoarrow_vctr(list(array, array), na_string())
+  fallback <- structure(list(), class = "fallback_array")
+  local_mocked_bindings(
+    as_nanoarrow_array.default = function(...) fallback,
+    .package = "nanoarrow"
+  )
+
+  # Schema differences other than the root name are not identity casts.
+  expect_identical(
+    as_nanoarrow_array(vctr, schema = na_large_string()),
+    fallback
+  )
+
+  metadata_schema <- na_string()
+  metadata_schema$metadata <- list(key = "value")
+  expect_identical(as_nanoarrow_array(vctr, schema = metadata_schema), fallback)
+
+  flags_schema <- na_string()
+  flags_schema$flags <- 0L
+  expect_identical(as_nanoarrow_array(vctr, schema = flags_schema), fallback)
+
+  # Multiple chunks cannot reuse a single complete array.
+  expect_identical(as_nanoarrow_array(multi_chunk_vctr), fallback)
+})
+
 test_that("format() works for nanoarrow_vctr", {
   empty_vctr <- nanoarrow_vctr(na_string())
   expect_identical(format(empty_vctr), character())
@@ -122,7 +194,10 @@ test_that("nanoarrow_vctr to stream generates identical stream for identity slic
 test_that("nanoarrow_vctr to stream works for arbitrary slices", {
   array1 <- as_nanoarrow_array(c("one", "two", "three"))
   array2 <- as_nanoarrow_array(c("four", "five", "six", "seven"))
-  vctr <- new_nanoarrow_vctr(list(array1, array2), infer_nanoarrow_schema(array1))
+  vctr <- new_nanoarrow_vctr(
+    list(array1, array2),
+    infer_nanoarrow_schema(array1)
+  )
 
   chunks16 <- collect_array_stream(
     as_nanoarrow_array_stream(vctr[1:6])