diff --git a/r/NAMESPACE b/r/NAMESPACE index cb27c9ae1..29101ff95 100644 --- a/r/NAMESPACE +++ b/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) diff --git a/r/R/vctr.R b/r/R/vctr.R index 4d1c443b6..ac051a302 100644 --- a/r/R/vctr.R +++ b/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) diff --git a/r/tests/testthat/test-vctr.R b/r/tests/testthat/test-vctr.R index 95bbd14ff..04ad27f6d 100644 --- a/r/tests/testthat/test-vctr.R +++ b/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())