POC: Ensure vec_ptype() strips non-essential attributes

NAMESPACE

@@ -227,6 +227,7 @@ S3method(vec_cast,difftime)
 S3method(vec_cast,double)
 S3method(vec_cast,double.exclude)
 S3method(vec_cast,double.omit)
+S3method(vec_cast,double.ts)
 S3method(vec_cast,exclude.double)
 S3method(vec_cast,exclude.exclude)
 S3method(vec_cast,exclude.integer)
@@ -236,6 +237,7 @@ S3method(vec_cast,factor.factor)
 S3method(vec_cast,integer)
 S3method(vec_cast,integer.exclude)
 S3method(vec_cast,integer.omit)
+S3method(vec_cast,integer.ts)
 S3method(vec_cast,integer64)
 S3method(vec_cast,list)
 S3method(vec_cast,list.vctrs_list_of)
@@ -248,6 +250,7 @@ S3method(vec_cast,ordered.character)
 S3method(vec_cast,ordered.ordered)
 S3method(vec_cast,raw)
 S3method(vec_cast,table.table)
+S3method(vec_cast,ts.ts)
 S3method(vec_cast,vctrs_list_of)
 S3method(vec_cast,vctrs_list_of.list)
 S3method(vec_cast,vctrs_rcrd)
@@ -327,6 +330,7 @@ S3method(vec_proxy_order,array)
 S3method(vec_proxy_order,default)
 S3method(vec_proxy_order,list)
 S3method(vec_proxy_order,raw)
+S3method(vec_ptype,ts)
 S3method(vec_ptype2,AsIs)
 S3method(vec_ptype2,Date)
 S3method(vec_ptype2,POSIXct)
@@ -366,6 +370,7 @@ S3method(vec_ptype2,ordered.factor)
 S3method(vec_ptype2,ordered.ordered)
 S3method(vec_ptype2,raw)
 S3method(vec_ptype2,table.table)
+S3method(vec_ptype2,ts.ts)
 S3method(vec_ptype2,vctrs_list_of)
 S3method(vec_ptype2,vctrs_list_of.list)
 S3method(vec_ptype2.AsIs,AsIs)

R/proxy.R

@@ -202,20 +202,9 @@ vec_restore_recurse <- function(x, to, ...) {
 vec_data <- function(x) {
   obj_check_vector(x)
   x <- vec_proxy(x)
-
-  if (is.data.frame(x)) {
-    return(new_data_frame(x, row.names = .row_names_info(x, 0L)))
-  }
-
-  if (has_dim(x)) {
-    x <- vec_set_attributes(x, list(dim = dim(x), dimnames = dimnames(x)))
-  } else {
-    x <- vec_set_attributes(x, list(names = names(x)))
-  }
-
-  # Unset S4 bit in vector-like S4 objects
-  as_not_s4(x)
+  proxy_data(x)
 }
-as_not_s4 <- function(x) {
-  .Call(ffi_as_not_s4, x)
+
+proxy_data <- function(x) {
+  .Call(ffi_proxy_data, x)
 }

R/shape.R

@@ -7,9 +7,13 @@ new_shape <- function(type, shape = integer()) {
   structure(type, dim = c(0L, shape))
 }
 
-vec_shaped_ptype <- function(ptype, x, y, ..., x_arg = "", y_arg = "") {
+vec_shaped_ptype <- function(ptype, x) {
+  .Call(ffi_vec_shaped_ptype, ptype, x)
+}
+
+vec_shaped_ptype2 <- function(ptype, x, y, ..., x_arg = "", y_arg = "") {
   check_dots_empty0(...)
-  .Call(ffi_vec_shaped_ptype, ptype, x, y, environment())
+  .Call(ffi_vec_shaped_ptype2, ptype, x, y, environment())
 }
 
 vec_shape2 <- function(x, y, ..., x_arg = "", y_arg = "") {

R/type-table.R

@@ -29,7 +29,7 @@ vec_ptype_abbr.table <- function(x, ...) {
 #' @export
 vec_ptype2.table.table <- function(x, y, ..., x_arg = "", y_arg = "") {
   ptype <- vec_ptype2(unstructure(x), unstructure(y))
-  vec_shaped_ptype(new_table(ptype), x, y, x_arg = x_arg, y_arg = y_arg)
+  vec_shaped_ptype2(new_table(ptype), x, y, x_arg = x_arg, y_arg = y_arg)
 }
 
 #' @export

R/type-ts.R

@@ -0,0 +1,53 @@
+#' `ts` S3 class
+#'
+#' These functions help the base `ts` class fit into the vctrs type system
+#' by providing coercion and casting functions.
+#'
+#' The `ts` class is a bit strange for vctrs:
+#'
+#' - It allows for arbitrary storage types.
+#' - It has a data dependent `tsp` attribute.
+#' - The `ts()` function prevents you from creating a size 0 version of a `ts`
+#'   object, presumably because you can't make the `tsp` attribute without some
+#'   data.
+#' - The `stats::[.ts` method drops off all attributes.
+#' - The `c()` default method drops off all attributes.
+#'
+#' Because of all of this, we aggressively drive coercion towards the underlying
+#' atomic type, which mostly matches the `[` and `c()` methods.
+#'
+#' @keywords internal
+#' @name vctrs-ts
+NULL
+
+#' @export
+vec_ptype.ts <- function(x, ...) {
+  vec_ptype(proxy_data(x))
+}
+
+#' @export
+vec_ptype2.ts.ts <- function(x, y, ..., x_arg = "", y_arg = "") {
+  vec_ptype2(proxy_data(x), proxy_data(y))
+}
+
+#' @export
+vec_cast.ts.ts <- function(x, to, ...) {
+  abort("Can't cast directly from <ts> to <ts>.")
+}
+
+# Needed because `vec_ptype2()` returns underlying storage
+#' @export
+vec_cast.integer.ts <- function(x, to, ...) {
+  ts_cast_atomic(x, to)
+}
+
+# Needed because `vec_ptype2()` returns underlying storage
+#' @export
+vec_cast.double.ts <- function(x, to, ...) {
+  ts_cast_atomic(x, to)
+}
+
+ts_cast_atomic <- function(x, to) {
+  x <- proxy_data(x)
+  vec_cast(x, to)
+}

src/decl/proxy-data-decl.h

@@ -0,0 +1,8 @@
+static inline
+r_obj* df_proxy_data(r_obj* x);
+
+static inline
+r_obj* array_proxy_data(r_obj* x);
+
+static inline
+r_obj* atomic_proxy_data(r_obj* x);

src/decl/ptype-decl.h

@@ -2,18 +2,13 @@ static
 SEXP syms_vec_ptype;
 
 static inline
-r_obj* vec_ptype_slice(r_obj* x, r_obj* empty);
+r_obj* df_ptype(r_obj* x, bool tibble);
 
-static
-r_obj* df_ptype(r_obj* x, bool bare);
-
-static
+static inline
 r_obj* col_ptype(r_obj* x);
 
 static
-r_obj* s3_ptype(r_obj* x,
-                struct vctrs_arg* x_arg,
-                struct r_lazy call);
+r_obj* s3_ptype(r_obj* x, struct vctrs_arg* p_x_arg, struct r_lazy call);
 
 static inline
 r_obj* vec_ptype_method(r_obj* x);

src/init.c

@@ -88,7 +88,6 @@ 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_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*);
@@ -108,7 +107,8 @@ extern r_obj* ffi_vec_rep(r_obj*, r_obj*, r_obj*);
 extern r_obj* ffi_vec_rep_each(r_obj*, r_obj*, r_obj*);
 extern SEXP vctrs_maybe_shared_col(SEXP, SEXP);
 extern SEXP vctrs_new_df_unshared_col(void);
-extern r_obj* ffi_vec_shaped_ptype(r_obj*, r_obj*, r_obj*, r_obj*);
+extern r_obj* ffi_vec_shaped_ptype(r_obj*, r_obj*);
+extern r_obj* ffi_vec_shaped_ptype2(r_obj*, r_obj*, r_obj*, r_obj*);
 extern r_obj* ffi_vec_shape2(r_obj*, r_obj*, r_obj*);
 extern SEXP vctrs_new_date(SEXP);
 extern SEXP vctrs_date_validate(SEXP);
@@ -173,6 +173,7 @@ extern r_obj* ffi_vec_replace_values(r_obj*, r_obj*, r_obj*, r_obj*, r_obj*, r_o
 extern r_obj* ffi_vec_if_else(r_obj*, r_obj*, r_obj*, r_obj*, r_obj*, r_obj*);
 extern r_obj* ffi_vec_pany(r_obj*, r_obj*, r_obj*, r_obj*);
 extern r_obj* ffi_vec_pall(r_obj*, r_obj*, r_obj*, r_obj*);
+extern r_obj* ffi_proxy_data(r_obj*);
 
 
 // Maturing
@@ -287,7 +288,6 @@ 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_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},
@@ -311,7 +311,8 @@ static const R_CallMethodDef CallEntries[] = {
   {"ffi_vec_rep_each",                          (DL_FUNC) &ffi_vec_rep_each, 3},
   {"vctrs_maybe_shared_col",                    (DL_FUNC) &vctrs_maybe_shared_col, 2},
   {"vctrs_new_df_unshared_col",                 (DL_FUNC) &vctrs_new_df_unshared_col, 0},
-  {"ffi_vec_shaped_ptype",                      (DL_FUNC) &ffi_vec_shaped_ptype, 4},
+  {"ffi_vec_shaped_ptype",                      (DL_FUNC) &ffi_vec_shaped_ptype, 2},
+  {"ffi_vec_shaped_ptype2",                     (DL_FUNC) &ffi_vec_shaped_ptype2, 4},
   {"ffi_vec_shape2",                            (DL_FUNC) &ffi_vec_shape2, 3},
   {"vctrs_new_date",                            (DL_FUNC) &vctrs_new_date, 1},
   {"vctrs_date_validate",                       (DL_FUNC) &vctrs_date_validate, 1},
@@ -376,6 +377,7 @@ static const R_CallMethodDef CallEntries[] = {
   {"ffi_vec_if_else",                           (DL_FUNC) &ffi_vec_if_else, 6},
   {"ffi_vec_pany",                              (DL_FUNC) &ffi_vec_pany, 4},
   {"ffi_vec_pall",                              (DL_FUNC) &ffi_vec_pall, 4},
+  {"ffi_proxy_data",                            (DL_FUNC) &ffi_proxy_data, 1},
   {"ffi_exp_vec_cast",                          (DL_FUNC) &exp_vec_cast, 2},
   {NULL, NULL, 0}
 };

src/proxy-data.c

@@ -0,0 +1,82 @@
+#include "proxy-data.h"
+#include "dim.h"
+#include "type-data-frame.h"
+#include "utils.h"
+
+#include "decl/proxy-data-decl.h"
+
+r_obj* ffi_proxy_data(r_obj* x) {
+  return proxy_data(x);
+}
+
+r_obj* proxy_data(r_obj* x) {
+  if (is_data_frame(x)) {
+    return df_proxy_data(x);
+  } else if (has_dim(x)) {
+    return array_proxy_data(x);
+  } else {
+    return atomic_proxy_data(x);
+  }
+}
+
+static inline
+r_obj* df_proxy_data(r_obj* x) {
+  // We do need to protect these, as we are about to clear `x`
+  r_obj* names = KEEP(r_names(x));
+  r_obj* row_names = KEEP(df_rownames(x));
+  const enum rownames_type row_names_type = rownames_type(row_names);
+  const r_ssize size = rownames_size(row_names, row_names_type);
+
+  // TODO!: At least add documentation on how this always ALTREP clones,
+  // and some golden tests about it for `proxy_data()` itself.
+  //
+  // Presumably we are modifying `x` in place, which WE created
+  // at the C level but ALSO need it to remain unmodified for
+  // some future use of our own.
+
+  // This clones `x` as required, and creates a cheap ALTREP shallow duplicate
+  // of `x` with its own attribute pairlist
+  r_obj* out = KEEP(vec_set_attributes(x, r_null));
+
+  r_attrib_poke_names(out, names);
+  r_init_data_frame(out, size);
+
+  if (row_names_type == ROWNAMES_TYPE_identifiers) {
+    r_attrib_poke(out, r_syms.row_names, row_names);
+  }
+
+  FREE(3);
+  return out;
+}
+
+static inline
+r_obj* array_proxy_data(r_obj* x) {
+  // We do need to protect these, as we are about to clear `x`
+  r_obj* dim = KEEP(r_dim(x));
+  r_obj* dim_names = KEEP(r_dim_names(x));
+
+  // This clones `x` as required, and creates a cheap ALTREP shallow duplicate
+  // of `x` with its own attribute pairlist
+  r_obj* out = KEEP(vec_set_attributes(x, r_null));
+
+  r_attrib_poke_dim(out, dim);
+  r_attrib_poke_dim_names(out, dim_names);
+
+  FREE(3);
+  return out;
+}
+
+static inline
+r_obj* atomic_proxy_data(r_obj* x) {
+  // We do need to protect this, as we are about to clear `x`
+  r_obj* names = KEEP(r_names(x));
+
+  // This clones `x` as required, and creates a cheap ALTREP shallow duplicate
+  // of `x` with its own attribute pairlist
+  r_obj* out = KEEP(vec_set_attributes(x, r_null));
+
+  r_attrib_poke_names(out, names);
+
+  FREE(2);
+  return out;
+}

src/proxy-data.h

@@ -0,0 +1,17 @@
+#ifndef VCTRS_PROXY_DATA_H
+#define VCTRS_PROXY_DATA_H
+
+#include "vctrs-core.h"
+
+/// Returns the "core" data that underlies a proxy
+///
+/// Should only be called on the result of a call to `vec_proxy()`. Can be used
+/// to ensure that all extraneous attributes and classes have been stripped from
+/// a proxy object, which may help avoid inflooping in some cases.
+///
+/// - For atomics, clears all attributes but `names`.
+/// - For arrays, clears all attributes but `dim` and `dimnames`.
+/// - For data frames, clears all attributes but `names`, `row.names`, and a `"data.frame"` class.
+r_obj* proxy_data(r_obj* x);
+
+#endif

src/proxy.c

@@ -247,11 +247,6 @@ r_obj* vec_proxy_unwrap(r_obj* x) {
 }
 
 
-r_obj* ffi_as_not_s4(r_obj* x) {
-  return r_as_not_s4(x);
-}
-
-
 void vctrs_init_data(r_obj* ns) {
   syms_vec_proxy = r_sym("vec_proxy");