diff --git a/R/pkg-arrow.R b/R/pkg-arrow.R new file mode 100644 index 0000000..00f01e1 --- /dev/null +++ b/R/pkg-arrow.R @@ -0,0 +1,96 @@ + +GeoArrowType <- list() +GeoArrowType$create <- function(...) { + stop("Package 'arrow' must be installed to use GeoArrowType") +} + + +has_arrow_extension_type <- function() { + inherits(GeoArrowType, "R6ClassGenerator") +} + +register_arrow_extension_type <- function() { + GeoArrowType <<- R6::R6Class( + "GeoArrowType", inherit = arrow::ExtensionType, + public = list( + Deserialize = function() { + private$schema <- narrow::as_narrow_schema(self) + }, + as_vector = function(array) { + wk_handle_wrapper(narrow::as_narrow_array_stream(array), NULL) + }, + ToString = function() { + label <- gsub("^geoarrow\\.", "", self$extension_name()) + + crs <- self$crs + if (is.null(crs) || identical(crs, "")) { + crs <- "" + } else if (nchar(crs) > 30) { + crs <- paste0(substr(crs, 1, 27), "...") + } + + edges <- self$edges + if (is.null(edges)) { + edges <- "" + } else { + edges <- paste0("(", edges, " edges)") + } + + sprintf("%s %s%s", label, crs, edges) + } + ), + active = list( + crs = function() { + recursive_extract_narrow_schema(private$schema, "crs") + }, + edges = function() { + recursive_extract_narrow_schema(private$schema, "edges") + } + ), + private = list( + schema = NULL + ) + ) + + # This shouldn't be needed directly...these objects will get instantiated + # when the Type object gets surfaced to R provided that the extension types + # have been registered. + GeoArrowType$create <- function(schema) { + schema <- narrow::as_narrow_schema(schema) + + # this is a bit of a hack and could probably be done better in narrow + ext <- scalar_chr(schema$metadata[["ARROW:extension:name"]]) + metadata <- schema$metadata[["ARROW:extension:metadata"]] + schema$metadata[c("ARROW:extension:name", "ARROW:extension:metadata")] <- NULL + dummy_array <- narrow::narrow_array(schema, validate = FALSE) + storage_type <- narrow::from_narrow_array( + dummy_array, + # ...because arrow::DataType is not exported + asNamespace("arrow")$DataType + ) + + arrow::new_extension_type( + storage_type = storage_type, + extension_name = ext, + extension_metadata = metadata, + type_class = GeoArrowType + ) + } + + representative_schemas <- list( + geoarrow_schema_wkb(), + geoarrow_schema_wkt(), + geoarrow_schema_point(), + geoarrow_schema_linestring(), + geoarrow_schema_polygon(), + geoarrow_schema_multipoint(), + geoarrow_schema_multilinestring(), + geoarrow_schema_multipolygon() + ) + + for (schema in representative_schemas) { + arrow::reregister_extension_type( + GeoArrowType$create(schema) + ) + } +} diff --git a/R/zzz.R b/R/zzz.R index ec33a7b..d257ac1 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -6,6 +6,10 @@ s3_register("vctrs::vec_proxy", cls, vctr_proxy) s3_register("vctrs::vec_restore", cls, vctr_restore) } + + if (requireNamespace("arrow", quietly = TRUE)) { + try(register_arrow_extension_type()) + } } s3_register <- function(generic, class, method = NULL) {