Implement reconstruct in C++

tidyverse · Sep 9, 2023 · 82e8d12 · 82e8d12
1 parent 7374271
commit 82e8d12
Show file tree

Hide file tree

Showing 4 changed files with 68 additions and 6 deletions.
diff --git a/R/generics.R b/R/generics.R
@@ -202,12 +202,7 @@ dplyr_reconstruct_dispatch <- function(data, template) {
 
 #' @export
 dplyr_reconstruct.data.frame <- function(data, template) {
-  attrs <- attributes(template)
-  attrs$names <- names(data)
-  attrs$row.names <- .row_names_info(data, type = 0L)
-
-  attributes(data) <- attrs
-  data
+  .Call(dplyr_reconstruct_impl, data, template)
 }
 
 #' @export

diff --git a/src/dplyr.h b/src/dplyr.h
@@ -120,6 +120,8 @@ void add_mask_binding(SEXP name, SEXP env_mask_bindings, SEXP env_chops);
 
 SEXP dplyr_extract_chunks(SEXP df_list, SEXP df_ptype);
 
+SEXP dplyr_reconstruct_impl(SEXP data, SEXP template_);
+
 #define DPLYR_MASK_INIT()                                                                                            \
   SEXP rows = PROTECT(Rf_findVarInFrame(env_private, dplyr::symbols::rows));                                         \
   const SEXP* v_rows = VECTOR_PTR_RO(rows);                                                                          \

diff --git a/src/init.cpp b/src/init.cpp
@@ -121,6 +121,8 @@ static const R_CallMethodDef CallEntries[] = {
 
   {"dplyr_extract_chunks", (DL_FUNC)& dplyr_extract_chunks, 2},
 
+  {"dplyr_reconstruct_impl", (DL_FUNC)& dplyr_reconstruct_impl, 2},
+
   {NULL, NULL, 0}
 };
 

diff --git a/src/reconstruct.cpp b/src/reconstruct.cpp
@@ -0,0 +1,63 @@
+#include "dplyr.h"
+
+// mostly installAttrib from attrib.c
+void set_attrib(SEXP s, SEXP name, SEXP val) {
+    SEXP last_attrib = R_NilValue;
+    for (SEXP attrib = ATTRIB(s); attrib != R_NilValue; attrib = CDR(attrib)) {
+        last_attrib = attrib;
+    }
+    SEXP new_attrib = PROTECT(Rf_cons(val, R_NilValue));
+    SET_TAG(new_attrib, name);
+    if (ATTRIB(s) == R_NilValue) {
+        SET_ATTRIB(s, new_attrib);
+    } else  {
+        SETCDR(last_attrib, new_attrib);
+    }
+    UNPROTECT(1);
+}
+
+SEXP dplyr_reconstruct_impl(SEXP result, SEXP template_) {
+    if (result == R_NilValue || result == R_NilValue) {
+        Rf_error("Need non-NULL parameters");
+    }
+
+    // get existing names and row names, circumventing R's logic
+    SEXP names = R_NilValue;
+    SEXP row_names = R_NilValue;
+
+    for (SEXP attr = ATTRIB(result); attr != R_NilValue; attr = CDR(attr)) {
+        SEXP tag = TAG(attr);
+        if (tag == R_NamesSymbol) {
+            names = CAR(attr);
+        } else if (tag == R_RowNamesSymbol) {
+            row_names = CAR(attr);
+        }
+    }
+
+    // clear all attributes on target
+    SET_ATTRIB(result, R_NilValue);
+
+    // add attributes from template that are *not* names or row.names
+    for (SEXP attr = ATTRIB(template_); attr != R_NilValue; attr = CDR(attr)) {
+        SEXP tag = TAG(attr);
+        if (tag == R_NamesSymbol) {
+            set_attrib(result, tag, names);
+            names = R_NilValue;
+        } else if (tag == R_RowNamesSymbol) {
+            set_attrib(result, tag, row_names);
+            row_names = R_NilValue;
+        } else {
+            set_attrib(result, tag, CAR(attr));
+        }
+    }
+
+    // restore names and row names if not done yet
+    if (names != R_NilValue) {
+        set_attrib(result, R_NamesSymbol, names);
+    }
+    if (row_names != R_NilValue) {
+        set_attrib(result, R_RowNamesSymbol, row_names);
+    }
+
+    return result;
+}