maybe integrate the finalizer

Author: paleolimbot

r/R/vctr.R

@@ -41,26 +41,24 @@ as_nanoarrow_vctr <- function(x, ..., schema = NULL) {
 
 #' @rdname as_nanoarrow_vctr
 #' @export
-nanoarrow_vctr <- function(schema = NULL) {
+nanoarrow_vctr <- function(schema = NULL, subclass = character()) {
   if (is.null(schema)) {
-    new_nanoarrow_vctr(list(), NULL)
+    new_nanoarrow_vctr(list(), NULL, subclass)
   } else {
-    new_nanoarrow_vctr(list(), as_nanoarrow_schema(schema))
+    new_nanoarrow_vctr(list(), as_nanoarrow_schema(schema), subclass)
   }
 }
 
-new_nanoarrow_vctr <- function(chunks, schema, indices = NULL) {
+new_nanoarrow_vctr <- function(chunks, schema, subclass = character()) {
   offsets <- .Call(nanoarrow_c_vctr_chunk_offsets, chunks)
-  if (is.null(indices)) {
-    indices <- seq_len(offsets[length(offsets)])
-  }
+  indices <- seq_len(offsets[length(offsets)])
 
   structure(
     indices,
     schema = schema,
     chunks = chunks,
     offsets = offsets,
-    class = "nanoarrow_vctr"
+    class = union(subclass, "nanoarrow_vctr")
   )
 }
 
@@ -248,12 +246,12 @@ as.data.frame.nanoarrow_vctr <- function(x, ..., optional = FALSE) {
 print.nanoarrow_vctr <- function(x, ...) {
   schema <- attr(x, "schema", exact = TRUE)
   if (is.null(schema)) {
-    cat("<nanoarrow_vctr <any>>\n")
+    cat(sprintf("<%s <any>>\n", class(x)[1]))
     return(invisible(x))
   }
 
   formatted <- nanoarrow_schema_formatted(schema, recursive = FALSE)
-  cat(sprintf("<nanoarrow_vctr %s[%d]>\n", formatted, length(x)))
+  cat(sprintf("<%s %s[%d]>\n", class(x)[1], formatted, length(x)))
 
   n_values <- min(length(x), 20)
   more_values <- length(x) - n_values
@@ -274,12 +272,12 @@ print.nanoarrow_vctr <- function(x, ...) {
 str.nanoarrow_vctr <- function(object, ...) {
   schema <- attr(object, "schema", exact = TRUE)
   if (is.null(schema)) {
-    cat("<nanoarrow_vctr <any>>\n")
+    cat(sprintf("<%s <any>>\n", class(object)[1]))
     return(invisible(object))
   }
 
   formatted <- nanoarrow_schema_formatted(schema, recursive = FALSE)
-  cat(sprintf("<nanoarrow_vctr %s[%d]>\n", formatted, length(object)))
+  cat(sprintf("<%s %s[%d]>\n", class(object)[1], formatted, length(object)))
 
   # Prints out the C data interface dump of each chunk with the chunk
   # index above.

r/src/convert.c

@@ -437,17 +437,25 @@ int nanoarrow_converter_finalize(SEXP converter_xptr) {
 SEXP nanoarrow_converter_release_result(SEXP converter_xptr) {
   struct RConverter* converter = (struct RConverter*)R_ExternalPtrAddr(converter_xptr);
   SEXP converter_shelter = R_ExternalPtrProtected(converter_xptr);
+
   // PROTECT()ing here because we are about to release the object from the
   // shelter of the converter and return it
   SEXP result = PROTECT(VECTOR_ELT(converter_shelter, 4));
   SET_VECTOR_ELT(converter_shelter, 4, R_NilValue);
+
+  // Perform any finalization on the vector before it is returned to R
+  SEXP final_result =
+      PROTECT(nanoarrow_materialize_finalize_result(converter_xptr, result));
+
+  // Reset the converter state
   converter->dst.vec_sexp = R_NilValue;
   converter->dst.offset = 0;
   converter->dst.length = 0;
   converter->size = 0;
   converter->capacity = 0;
-  UNPROTECT(1);
-  return result;
+
+  UNPROTECT(2);
+  return final_result;
 }
 
 void nanoarrow_converter_stop(SEXP converter_xptr) {

r/src/materialize.c

@@ -299,6 +299,47 @@ static void copy_vec_into(SEXP x, SEXP dst, R_xlen_t offset, R_xlen_t len) {
   }
 }
 
+SEXP nanoarrow_materialize_finalize_result(SEXP converter_xptr, SEXP result) {
+  if (Rf_inherits(result, "nanoarrow_vctr")) {
+    // Get the schema for this converter. Technically this will overwrite
+    // a schema that was provided explicitly; however, we currently do not
+    // handle that case.
+    SEXP converter_shelter = R_ExternalPtrProtected(converter_xptr);
+    SEXP schema_xptr = VECTOR_ELT(converter_shelter, 1);
+
+    // We no longer need to keep track of chunks_tail
+    SEXP chunks_tail_sym = PROTECT(Rf_install("chunks_tail"));
+    Rf_setAttrib(result, chunks_tail_sym, R_NilValue);
+
+    // We also want to pass on the class of the ptype we recieved
+    SEXP subclass_sexp = Rf_getAttrib(result, R_ClassSymbol);
+
+    // We no longer need the first element of the pairlist, which was
+    // intentionally set to R_NilValue.
+    SEXP chunks_sym = PROTECT(Rf_install("chunks"));
+    SEXP chunks_pairlist0 = Rf_getAttrib(result, chunks_sym);
+
+    // If there were zero chunks, there will be no "first" node
+    SEXP chunks_list;
+    if (CDR(chunks_pairlist0) == R_NilValue) {
+      chunks_list = PROTECT(Rf_allocVector(VECSXP, 0));
+    } else {
+      chunks_list = PROTECT(Rf_PairToVectorList(CDR(chunks_pairlist0)));
+    }
+
+    // Set up the call to new_nanoarrow_vctr
+    SEXP new_nanoarrow_vctr_sym = PROTECT(Rf_install("new_nanoarrow_vctr"));
+    SEXP new_nanoarrow_vctr_call = PROTECT(
+        Rf_lang4(new_nanoarrow_vctr_sym, chunks_list, schema_xptr, subclass_sexp));
+    SEXP final_result = PROTECT(Rf_eval(new_nanoarrow_vctr_call, nanoarrow_ns_pkg));
+
+    UNPROTECT(8);
+    return final_result;
+  } else {
+    return result;
+  }
+}
+
 static int nanoarrow_materialize_nanoarrow_vctr(struct RConverter* converter,
                                                 SEXP converter_xptr) {
   // This is a case where the callee needs ownership, which we can do via a

r/src/materialize.h

@@ -42,4 +42,8 @@ int nanoarrow_materialize(struct RConverter* converter, SEXP converter_xptr);
 SEXP nanoarrow_alloc_type(enum VectorType vector_type, R_xlen_t len);
 SEXP nanoarrow_materialize_realloc(SEXP ptype, R_xlen_t len);
 
+// Finalize an object before returning to R. Currently only used for
+// nanoarrow_vctr conversion.
+SEXP nanoarrow_materialize_finalize_result(SEXP converter_xptr, SEXP result);
+
 #endif