Use R C API compliant S4 utilities (#2084)

* Use `Rf_isS4()`

* Use R C API compliant S4 utilities

Author: DavisVaughan

R/proxy.R

@@ -213,9 +213,9 @@ vec_data <- function(x) {
     x <- vec_set_attributes(x, list(names = names(x)))
   }
 
-  # Reset S4 bit in vector-like S4 objects
-  unset_s4(x)
+  # Unset S4 bit in vector-like S4 objects
+  as_not_s4(x)
 }
-unset_s4 <- function(x) {
-  .Call(ffi_unset_s4, x)
+as_not_s4 <- function(x) {
+  .Call(ffi_as_not_s4, x)
 }

src/init.c

@@ -88,7 +88,7 @@ extern r_obj* ffi_outer_names(r_obj*, r_obj*, r_obj*);
 extern SEXP vctrs_df_size(SEXP);
 extern r_obj* ffi_as_df_col(r_obj*, r_obj*, r_obj*);
 extern r_obj* ffi_apply_name_spec(r_obj*, r_obj*, r_obj*, r_obj*);
-extern r_obj* ffi_unset_s4(r_obj*);
+extern r_obj* ffi_as_not_s4(r_obj*);
 extern SEXP vctrs_validate_name_repair_arg(SEXP);
 extern SEXP vctrs_validate_minimal_names(SEXP, SEXP);
 extern r_obj* ffi_vec_as_names(r_obj*, r_obj*, r_obj*, r_obj*);
@@ -285,7 +285,7 @@ static const R_CallMethodDef CallEntries[] = {
   {"vctrs_df_size",                             (DL_FUNC) &vctrs_df_size, 1},
   {"ffi_as_df_col",                             (DL_FUNC) &ffi_as_df_col, 3},
   {"ffi_apply_name_spec",                       (DL_FUNC) &ffi_apply_name_spec, 4},
-  {"ffi_unset_s4",                              (DL_FUNC) &ffi_unset_s4, 1},
+  {"ffi_as_not_s4",                             (DL_FUNC) &ffi_as_not_s4, 1},
   {"vctrs_altrep_rle_Make",                     (DL_FUNC) &altrep_rle_Make, 1},
   {"vctrs_altrep_rle_is_materialized",          (DL_FUNC) &altrep_rle_is_materialized, 1},
   {"ffi_altrep_new_lazy_character",             (DL_FUNC) &ffi_altrep_new_lazy_character, 1},

src/list-combine.c

@@ -1573,7 +1573,7 @@ bool vec_implements_base_c(r_obj* x) {
     return false;
   }
 
-  if (IS_S4_OBJECT(x)) {
+  if (r_is_s4(x)) {
     return s4_find_method(x, s4_c_method_table) != r_null;
   } else {
     return s3_find_method("c", x, base_method_table) != r_null;

src/proxy-restore.c

@@ -71,7 +71,7 @@ r_obj* vec_restore_dispatch(r_obj* x, r_obj* to) {
 r_obj* vec_restore_default(r_obj* x, r_obj* to, enum vctrs_ownership ownership) {
   r_obj* attrib = r_attrib(to);
 
-  const bool is_s4 = IS_S4_OBJECT(to);
+  const bool is_s4 = r_is_s4(to);
 
   if (attrib == r_null && !is_s4) {
     return x;
@@ -158,7 +158,7 @@ r_obj* vec_restore_default(r_obj* x, r_obj* to, enum vctrs_ownership ownership)
   }
 
   if (is_s4) {
-    r_mark_s4(x);
+    x = r_as_s4(x);
   }
 
   FREE(n_prot);

src/proxy.c

@@ -247,10 +247,8 @@ r_obj* vec_proxy_unwrap(r_obj* x) {
 }
 
 
-r_obj* ffi_unset_s4(r_obj* x) {
-  x = r_clone_referenced(x);
-  r_unmark_s4(x);
-  return x;
+r_obj* ffi_as_not_s4(r_obj* x) {
+  return r_as_not_s4(x);
 }
 
 

src/utils.c

@@ -590,7 +590,7 @@ static SEXP s4_get_method(const char* cls, SEXP table) {
 
 // For S4 objects, the `table` is specific to the generic
 SEXP s4_find_method(SEXP x, SEXP table) {
-  if (!IS_S4_OBJECT(x)) {
+  if (!r_is_s4(x)) {
     return R_NilValue;
   }
 

src/utils.h

@@ -271,13 +271,29 @@ SEXP r_clone_referenced(SEXP x);
 
 SEXP r_call_n(SEXP fn, SEXP* tags, SEXP* cars);
 
-static inline SEXP r_mark_s4(SEXP x) {
-  SET_S4_OBJECT(x);
-  return(x);
+static inline bool r_is_s4(SEXP x) {
+  return Rf_isS4(x);
 }
-static inline SEXP r_unmark_s4(SEXP x) {
-  UNSET_S4_OBJECT(x);
-  return(x);
+static inline SEXP r_as_s4(SEXP x) {
+  // - Return value must be used, unlike `SET_S4_OBJECT()`
+  // - `Rf_asS4()` calls `shallow_duplicate(x)` if `MAYBE_SHARED(x)`
+  // - `flag = 1` goes through `SET_S4_OBJECT()`
+  // - `complete` is never utilized when `flag = 1`
+  const Rboolean flag = 1;
+  const int complete = 0;
+  return Rf_asS4(x, flag, complete);
+}
+static inline SEXP r_as_not_s4(SEXP x) {
+  // - Return value must be used, unlike `UNSET_S4_OBJECT()`
+  // - `Rf_asS4()` calls `shallow_duplicate(x)` if `MAYBE_SHARED(x)`
+  // - `flag = 0` goes through `UNSET_S4_OBJECT()`
+  // - `complete` is for S4 objects that wrap a "complete" S3 object by placing
+  //   it in the `.Data` slot. If you set `complete = 1`, it will unwrap and
+  //   return that, which we don't want. If `complete = 0`, no additional
+  //   behavior will happen beyond the `UNSET_S4_OBJECT()` call.
+  const Rboolean flag = 0;
+  const int complete = 0;
+  return Rf_asS4(x, flag, complete);
 }
 
 bool r_has_name_at(SEXP names, R_len_t i);

tests/testthat/test-s4.R

@@ -60,16 +60,16 @@ test_that("proxy and data", {
   expect_true(isS4(vec_restore(vec_data(x), x)))
 })
 
-test_that("unset_s4() copies and works", {
+test_that("as_not_s4() copies and works", {
   # Initial condition
   x <- rando()
   expect_true(isS4(x))
 
   # Unsetting has no side effect on x
-  unset_s4(x)
+  as_not_s4(x)
   expect_true(isS4(x))
 
   # Unsetting actually works
-  y <- unset_s4(x)
+  y <- as_not_s4(x)
   expect_false(isS4(y))
 })