apache · paleolimbot · Apr 6, 2022 · Apr 6, 2022 · Apr 6, 2022 · Apr 6, 2022
diff --git a/r/DESCRIPTION b/r/DESCRIPTION
@@ -116,7 +116,7 @@ Collate:
     'filesystem.R'
     'flight.R'
     'install-arrow.R'
-    'ipc_stream.R'
+    'ipc-stream.R'
     'json.R'
     'memory-pool.R'
     'message.R'

diff --git a/r/NAMESPACE b/r/NAMESPACE
@@ -38,6 +38,45 @@ S3method(as.list,ArrowTabular)
 S3method(as.list,Schema)
 S3method(as.raw,Buffer)
 S3method(as.vector,ArrowDatum)
+S3method(as_arrow_array,Array)
+S3method(as_arrow_array,ChunkedArray)
+S3method(as_arrow_array,Scalar)
+S3method(as_arrow_array,data.frame)
+S3method(as_arrow_array,default)
+S3method(as_arrow_array,pyarrow.lib.Array)
+S3method(as_arrow_table,RecordBatch)
+S3method(as_arrow_table,Table)
+S3method(as_arrow_table,data.frame)
+S3method(as_arrow_table,default)
+S3method(as_arrow_table,pyarrow.lib.RecordBatch)
+S3method(as_arrow_table,pyarrow.lib.Table)
+S3method(as_chunked_array,Array)
+S3method(as_chunked_array,ChunkedArray)
+S3method(as_chunked_array,default)
+S3method(as_chunked_array,pyarrow.lib.ChunkedArray)
+S3method(as_data_type,DataType)
+S3method(as_data_type,Field)
+S3method(as_data_type,Schema)
+S3method(as_data_type,pyarrow.lib.DataType)
+S3method(as_data_type,pyarrow.lib.Field)
+S3method(as_record_batch,RecordBatch)
+S3method(as_record_batch,Table)
+S3method(as_record_batch,data.frame)
+S3method(as_record_batch,pyarrow.lib.RecordBatch)
+S3method(as_record_batch,pyarrow.lib.Table)
+S3method(as_record_batch_reader,Dataset)
+S3method(as_record_batch_reader,RecordBatch)
+S3method(as_record_batch_reader,RecordBatchReader)
+S3method(as_record_batch_reader,Scanner)
+S3method(as_record_batch_reader,Table)
+S3method(as_record_batch_reader,arrow_dplyr_query)
+S3method(as_record_batch_reader,data.frame)
+S3method(as_record_batch_reader,pyarrow.lib.RecordBatch)
+S3method(as_record_batch_reader,pyarrow.lib.RecordBatchReader)
+S3method(as_record_batch_reader,pyarrow.lib.Table)
+S3method(as_schema,Schema)
+S3method(as_schema,StructType)
+S3method(as_schema,pyarrow.lib.Schema)
 S3method(c,Array)
 S3method(c,ChunkedArray)
 S3method(c,Dataset)
@@ -55,6 +94,9 @@ S3method(head,Dataset)
 S3method(head,RecordBatchReader)
 S3method(head,Scanner)
 S3method(head,arrow_dplyr_query)
+S3method(infer_type,ArrowDatum)
+S3method(infer_type,Expression)
+S3method(infer_type,default)
 S3method(is.finite,ArrowDatum)
 S3method(is.infinite,ArrowDatum)
 S3method(is.na,ArrowDatum)
@@ -104,9 +146,6 @@ S3method(tail,Dataset)
 S3method(tail,RecordBatchReader)
 S3method(tail,Scanner)
 S3method(tail,arrow_dplyr_query)
-S3method(type,ArrowDatum)
-S3method(type,Expression)
-S3method(type,default)
 S3method(unique,ArrowDatum)
 S3method(vec_ptype_abbr,arrow_fixed_size_binary)
 S3method(vec_ptype_abbr,arrow_fixed_size_list)
@@ -214,6 +253,13 @@ export(arrow_with_engine)
 export(arrow_with_json)
 export(arrow_with_parquet)
 export(arrow_with_s3)
+export(as_arrow_array)
+export(as_arrow_table)
+export(as_chunked_array)
+export(as_data_type)
+export(as_record_batch)
+export(as_record_batch_reader)
+export(as_schema)
 export(binary)
 export(bool)
 export(boolean)
@@ -253,6 +299,7 @@ export(float32)
 export(float64)
 export(halffloat)
 export(hive_partition)
+export(infer_type)
 export(install_arrow)
 export(install_pyarrow)
 export(int16)

diff --git a/r/R/array.R b/r/R/array.R
@@ -85,7 +85,7 @@
 #'
 #' @rdname array
 #' @name array
-#' @examplesIf arrow_available()
+#' @examples
 #' my_array <- Array$create(1:10)
 #' my_array$type
 #' my_array$cast(int8())
@@ -217,6 +217,135 @@ Array$create <- function(x, type = NULL) {
 Array$import_from_c <- ImportArray
 
 
+#' Convert an object to an Arrow Array
+#'
+#' The `as_arrow_array()` function is identical to `Array$create()` except
+#' that it is an S3 generic, which allows methods to be defined in other
+#' packages to convert objects to [Array]. `Array$create()` is slightly faster
+#' because it tries to convert in C++ before falling back on
+#' `as_arrow_array()`.
+#'
+#' @param x An object to convert to an Arrow Array
+#' @param ... Passed to S3 methods
+#' @param type A [type][data-type] for the final Array. A value of `NULL`
+#'   will default to the type guessed by [infer_type()].
+#'
+#' @return An [Array] with type `type`.
+#' @export
+#'
+#' @examples
+#' as_arrow_array(1:5)
+#'
+as_arrow_array <- function(x, ..., type = NULL) {
+  UseMethod("as_arrow_array")
+}
+
+#' @export
+as_arrow_array.default <- function(x, ..., type = NULL, from_vec_to_array = FALSE) {
+  # If from_vec_to_array is TRUE, this is a call from C++ after
+  # trying the internal C++ conversion and S3 dispatch has failed
+  # failed to find a method for the object. This call happens when creating
+  # Array, ChunkedArray, RecordBatch, and Table objects from data.frame
+  # if the internal C++ conversion (faster and can usually be parallelized)
+  # is not implemented. If the C++ call has reached this default method,
+  # we error. If from_vec_to_array is FALSE, we call vec_to_Array to use the
+  # internal C++ conversion.
+  if (from_vec_to_array) {
+    # Last ditch attempt: if vctrs::vec_is(x), we can use the vctrs
+    # extension type.
+    if (vctrs::vec_is(x) && is.null(type)) {
+      vctrs_extension_array(x)
+    } else if (vctrs::vec_is(x) && inherits(type, "VctrsExtensionType")) {
+      vctrs_extension_array(
+        x,
+        ptype = type$ptype(),
+        storage_type = type$storage_type()
+      )
+    } else {
+      stop_cant_convert_array(x, type)
+    }
+  } else {
+    vec_to_Array(x, type)
+  }
+}
+
+#' @rdname as_arrow_array
+#' @export
+as_arrow_array.Array <- function(x, ..., type = NULL) {
+  if (is.null(type)) {
+    x
+  } else {
+    x$cast(type)
+  }
+}
+
+#' @rdname as_arrow_array
+#' @export
+as_arrow_array.Scalar <- function(x, ..., type = NULL) {
+  as_arrow_array(x$as_array(), ..., type = type)
+}
+
+#' @rdname as_arrow_array
+#' @export
+as_arrow_array.ChunkedArray <- function(x, ..., type = NULL) {
+  concat_arrays(!!! x$chunks, type = type)
+}
+
+# data.frame conversion can happen in C++ when all the columns can be
+# converted in C++ and when `type` is not an ExtensionType; however,
+# when calling as_arrow_array(), this method will get called regardless
+# of whether or not this can or can't happen.
+#' @export
+as_arrow_array.data.frame <- function(x, ..., type = NULL) {
+  type <- type %||% infer_type(x)
+
+  if (inherits(type, "VctrsExtensionType")) {
+    storage <- as_arrow_array(x, type = type$storage_type())
+    new_extension_array(storage, type)
+  } else if (inherits(type, "StructType")) {
+    fields <- type$fields()
+    names <- map_chr(fields, "name")
+    types <- map(fields, "type")
+    arrays <- Map(as_arrow_array, x, types)
+    names(arrays) <- names
+
+    # TODO(ARROW-16266): a hack because there is no StructArray$create() yet
+    batch <- record_batch(!!! arrays)
+    array_ptr <- allocate_arrow_array()
+    schema_ptr <- allocate_arrow_schema()
+    on.exit({
+      delete_arrow_array(array_ptr)
+      delete_arrow_schema(schema_ptr)
+    })
+
+    batch$export_to_c(array_ptr, schema_ptr)
+    Array$import_from_c(array_ptr, schema_ptr)
+  } else {
+    stop_cant_convert_array(x, type)
+  }
+}
+
+stop_cant_convert_array <- function(x, type) {
+  if (is.null(type)) {
+    abort(
+      sprintf(
+        "Can't create Array from object of type %s",
+        paste(class(x), collapse = " / ")
+      ),
+      call = rlang::caller_env()
+    )
+  } else {
+    abort(
+      sprintf(
+        "Can't create Array<%s> from object of type %s",
+        format(type$code()),
+        paste(class(x), collapse = " / ")
+      ),
+      call = rlang::caller_env()
+    )
+  }
+}
+
 #' Concatenate zero or more Arrays
 #'
 #' Concatenates zero or more [Array] objects into a single
@@ -231,7 +360,7 @@ Array$import_from_c <- ImportArray
 #' @return A single [Array]
 #' @export
 #'
-#' @examplesIf arrow_available()
+#' @examples
 #' concat_arrays(Array$create(1:3), Array$create(4:5))
 concat_arrays <- function(..., type = NULL) {
   dots <- lapply(list2(...), Array$create, type = type)

diff --git a/r/R/arrowExports.R b/r/R/arrowExports.R
diff --git a/r/R/chunked-array.R b/r/R/chunked-array.R
@@ -58,7 +58,7 @@
 #' @rdname ChunkedArray
 #' @name ChunkedArray
 #' @seealso [Array]
-#' @examplesIf arrow_available()
+#' @examples
 #' # Pass items into chunked_array as separate objects to create chunks
 #' class_scores <- chunked_array(c(87, 88, 89), c(94, 93, 92), c(71, 72, 73))
 #' class_scores$num_chunks
@@ -170,3 +170,47 @@ c.ChunkedArray <- function(...) {
 #' @rdname ChunkedArray
 #' @export
 chunked_array <- ChunkedArray$create
+
+#' Convert an object to an Arrow ChunkedArray
+#'
+#' Whereas [chunked_array()] constructs a [ChunkedArray] from zero or more
+#' [Array]s or R vectors, `as_chunked_array()` converts a single object to a
+#' [ChunkedArray].
+#'
+#' @param x An object to convert to an Arrow Chunked Array
+#' @inheritParams as_arrow_array
+#'
+#' @return A [ChunkedArray].
+#' @export
+#'
+#' @examples
+#' as_chunked_array(1:5)
+#'
+as_chunked_array <- function(x, ..., type = NULL) {
+  UseMethod("as_chunked_array")
+}
+
+#' @rdname as_chunked_array
+#' @export
+as_chunked_array.ChunkedArray <- function(x, ..., type = NULL) {
+  if (is.null(type)) {
+    x
+  } else {
+    x$cast(type)
+  }
+}
+
+#' @rdname as_chunked_array
+#' @export
+as_chunked_array.Array <- function(x, ..., type = NULL) {
+  if (is.null(type)) {
+    chunked_array(x)
+  } else {
+    chunked_array(x$cast(type))
+  }
+}
+
+#' @export
+as_chunked_array.default <- function(x, ..., type = NULL) {
+  ChunkedArray$create(x)
+}
diff --git a/r/R/dplyr-funcs-datetime.R b/r/R/dplyr-funcs-datetime.R
@@ -179,7 +179,13 @@ register_bindings_datetime <- function() {
   })
   register_binding("tz", function(x) {
     if (!call_binding("is.POSIXct", x)) {
-      abort(paste0("timezone extraction for objects of class `", type(x)$ToString(), "` not supported in Arrow"))
+      abort(
+        paste0(
+          "timezone extraction for objects of class `",
+          infer_type(x)$ToString(),
+          "` not supported in Arrow"
+        )
+      )
     }
 
     x$type()$timezone()

diff --git a/r/R/extension.R b/r/R/extension.R
@@ -180,11 +180,13 @@ ExtensionType <- R6Class("ExtensionType",
       } else if (inherits(extension_array, "ExtensionArray")) {
         extension_array$storage()$as_vector()
       } else {
-        classes <- paste(class(extension_array), collapse = " / ")
         abort(
           c(
             "`extension_array` must be a ChunkedArray or ExtensionArray",
-            i = glue::glue("Got object of type {classes}")
+            i = sprintf(
+              "Got object of type %s",
+              paste(class(extension_array), collapse = " / ")
+            )
           )
         )
       }
@@ -309,7 +311,7 @@ ExtensionType$create <- function(storage_type,
 #'      and `reregister_extension_type()` return `NULL`, invisibly.
 #' @export
 #'
-#' @examplesIf arrow_available()
+#' @examples
 #' # Create the R6 type whose methods control how Array objects are
 #' # converted to R objects, how equality between types is computed,
 #' # and how types are printed.
@@ -509,7 +511,7 @@ VctrsExtensionType <- R6Class("VctrsExtensionType",
 #'     extension name "arrow.r.vctrs".
 #' @export
 #'
-#' @examplesIf arrow_available()
+#' @examples
 #' (array <- vctrs_extension_array(as.POSIXlt("2022-01-02 03:45", tz = "UTC")))
 #' array$type
 #' as.vector(array)
@@ -532,9 +534,9 @@ vctrs_extension_array <- function(x, ptype = vctrs::vec_ptype(x),
 
 #' @rdname vctrs_extension_array
 #' @export
-vctrs_extension_type <- function(ptype,
-                                 storage_type = type(vctrs::vec_data(ptype))) {
-  ptype <- vctrs::vec_ptype(ptype)
+vctrs_extension_type <- function(x,
+                                 storage_type = infer_type(vctrs::vec_data(x))) {
+  ptype <- vctrs::vec_ptype(x)
 
   new_extension_type(
     storage_type = storage_type,

diff --git a/r/R/feather.R b/r/R/feather.R
@@ -100,11 +100,7 @@ write_feather <- function(x,
   compression <- compression_from_name(compression)
 
   x_out <- x
-  if (is.data.frame(x) || inherits(x, "RecordBatch")) {
-    x <- Table$create(x)
-  }
-
-  assert_that(is_writable_table(x))
+  x <- as_writable_table(x)
 
   if (!inherits(sink, "OutputStream")) {
     sink <- make_output_stream(sink)