1 #include "vctrs.h"
2 #include "type-data-frame.h"
3 #include "dim.h"
4 #include "utils.h"
5 #include "equal.h"
6
7 // Initialised at load time
8 SEXP syms_vec_proxy = NULL;
9 SEXP syms_vec_proxy_equal = NULL;
10 SEXP syms_vec_proxy_equal_array = NULL;
11 SEXP syms_vec_proxy_compare = NULL;
12 SEXP syms_vec_proxy_compare_array = NULL;
13 SEXP syms_vec_proxy_order = NULL;
14 SEXP syms_vec_proxy_order_array = NULL;
15
16 SEXP fns_vec_proxy_equal_array = NULL;
17 SEXP fns_vec_proxy_compare_array = NULL;
18 SEXP fns_vec_proxy_order_array = NULL;
19
20 static SEXP vec_proxy_unwrap(SEXP x);
21
22 SEXP vec_proxy_method(SEXP x);
23 SEXP vec_proxy_invoke(SEXP x, SEXP method);
24
25 // [[ register(); include("vctrs.h") ]]
vec_proxy(SEXP x)26 SEXP vec_proxy(SEXP x) {
27 int nprot = 0;
28 struct vctrs_type_info info = vec_type_info(x);
29 PROTECT_TYPE_INFO(&info, &nprot);
30
31 SEXP out;
32 if (info.type == vctrs_type_s3) {
33 out = vec_proxy_invoke(x, info.proxy_method);
34 } else {
35 out = x;
36 }
37
38 UNPROTECT(nprot);
39 return out;
40 }
41
42 static inline SEXP vec_proxy_equal_method(SEXP x);
43 static inline SEXP vec_proxy_equal_invoke(SEXP x, SEXP method);
44
45 // [[ register(); include("vctrs.h") ]]
vec_proxy_equal(SEXP x)46 SEXP vec_proxy_equal(SEXP x) {
47 SEXP method = PROTECT(vec_proxy_equal_method(x));
48 SEXP out = vec_proxy_equal_invoke(x, method);
49 UNPROTECT(1);
50 return out;
51 }
52
53 static inline SEXP vec_proxy_compare_method(SEXP x);
54 static inline SEXP vec_proxy_compare_invoke(SEXP x, SEXP method);
55
56 // [[ register(); include("vctrs.h") ]]
vec_proxy_compare(SEXP x)57 SEXP vec_proxy_compare(SEXP x) {
58 SEXP method = PROTECT(vec_proxy_compare_method(x));
59 SEXP out = vec_proxy_compare_invoke(x, method);
60 UNPROTECT(1);
61 return out;
62 }
63
64 static inline SEXP vec_proxy_order_method(SEXP x);
65 static inline SEXP vec_proxy_order_invoke(SEXP x, SEXP method);
66
67 // [[ register(); include("vctrs.h") ]]
vec_proxy_order(SEXP x)68 SEXP vec_proxy_order(SEXP x) {
69 SEXP method = PROTECT(vec_proxy_order_method(x));
70 SEXP out = vec_proxy_order_invoke(x, method);
71 UNPROTECT(1);
72 return out;
73 }
74
75 static SEXP df_proxy(SEXP x, enum vctrs_proxy_kind kind);
76
77 /*
78 * Specialized internal variant of `vec_proxy_equal()` that returns an
79 * alternative proxy for non data frame input that has a data frame proxy.
80 * These are special cased under the heuristic that the entire row has to be
81 * missing to be considered "incomplete". The easiest way to generate a
82 * completeness proxy following this heuristic is to generate a logical vector
83 * marked with `NA` where that row is completely missing.
84 */
85 // [[ register() ]]
vec_proxy_complete(SEXP x)86 SEXP vec_proxy_complete(SEXP x) {
87 if (is_data_frame(x)) {
88 return df_proxy(x, VCTRS_PROXY_KIND_complete);
89 }
90
91 SEXP proxy = PROTECT(vec_proxy_equal(x));
92
93 // Arrays have stopgap data frame proxies,
94 // but their completeness rules match normal data frames
95 if (has_dim(x)) {
96 UNPROTECT(1);
97 return proxy;
98 }
99
100 if (!is_data_frame(proxy)) {
101 UNPROTECT(1);
102 return proxy;
103 }
104
105 SEXP out = PROTECT(vec_equal_na(proxy));
106 int* p_out = LOGICAL(out);
107
108 r_ssize size = r_length(out);
109
110 for (r_ssize i = 0; i < size; ++i) {
111 if (p_out[i]) {
112 p_out[i] = NA_LOGICAL;
113 }
114 }
115
116 UNPROTECT(2);
117 return out;
118 }
119
120
vec_proxy_method(SEXP x)121 SEXP vec_proxy_method(SEXP x) {
122 return s3_find_method("vec_proxy", x, vctrs_method_table);
123 }
124
125 // This should be faster than normal dispatch but also means that
126 // proxy methods can't call `NextMethod()`. This could be changed if
127 // it turns out a problem.
vec_proxy_invoke(SEXP x,SEXP method)128 SEXP vec_proxy_invoke(SEXP x, SEXP method) {
129 if (method == R_NilValue) {
130 return x;
131 } else {
132 return vctrs_dispatch1(syms_vec_proxy, method, syms_x, x);
133 }
134 }
135
136 static inline
vec_proxy_method_impl(SEXP x,const char * generic,SEXP fn_proxy_array)137 SEXP vec_proxy_method_impl(SEXP x, const char* generic, SEXP fn_proxy_array) {
138 SEXP cls = PROTECT(s3_get_class(x));
139 SEXP method = s3_class_find_method(generic, cls, vctrs_method_table);
140
141 if (method != R_NilValue) {
142 UNPROTECT(1);
143 return method;
144 }
145
146 /* FIXME: Stopgap check for bare arrays */
147 /* which equality functions don't handle well */
148 if (vec_dim_n(x) > 1) {
149 UNPROTECT(1);
150 return fn_proxy_array;
151 }
152
153 UNPROTECT(1);
154 return R_NilValue;
155 }
156
157 static inline
vec_proxy_equal_method(SEXP x)158 SEXP vec_proxy_equal_method(SEXP x) {
159 return vec_proxy_method_impl(x, "vec_proxy_equal", fns_vec_proxy_equal_array);
160 }
161 static inline
vec_proxy_compare_method(SEXP x)162 SEXP vec_proxy_compare_method(SEXP x) {
163 return vec_proxy_method_impl(x, "vec_proxy_compare", fns_vec_proxy_compare_array);
164 }
165 static inline
vec_proxy_order_method(SEXP x)166 SEXP vec_proxy_order_method(SEXP x) {
167 return vec_proxy_method_impl(x, "vec_proxy_order", fns_vec_proxy_order_array);
168 }
169
170 static inline
vec_proxy_invoke_impl(SEXP x,SEXP method,SEXP vec_proxy_sym,SEXP (* vec_proxy_fn)(SEXP))171 SEXP vec_proxy_invoke_impl(SEXP x,
172 SEXP method,
173 SEXP vec_proxy_sym,
174 SEXP (*vec_proxy_fn)(SEXP)) {
175 if (method != R_NilValue) {
176 return vctrs_dispatch1(vec_proxy_sym, method, syms_x, x);
177 }
178
179 /* Fallback on S3 objects with no proxy */
180 if (vec_typeof(x) == vctrs_type_s3) {
181 return vec_proxy_fn(x);
182 } else {
183 return x;
184 }
185 }
186
187 static inline
vec_proxy_equal_invoke(SEXP x,SEXP method)188 SEXP vec_proxy_equal_invoke(SEXP x, SEXP method) {
189 return vec_proxy_invoke_impl(x, method, syms_vec_proxy_equal, vec_proxy);
190 }
191 static inline
vec_proxy_compare_invoke(SEXP x,SEXP method)192 SEXP vec_proxy_compare_invoke(SEXP x, SEXP method) {
193 return vec_proxy_invoke_impl(x, method, syms_vec_proxy_compare, &vec_proxy_equal);
194 }
195 static inline
vec_proxy_order_invoke(SEXP x,SEXP method)196 SEXP vec_proxy_order_invoke(SEXP x, SEXP method) {
197 return vec_proxy_invoke_impl(x, method, syms_vec_proxy_order, &vec_proxy_compare);
198 }
199
200
201 #define DF_PROXY(PROXY) do { \
202 R_len_t n_cols = Rf_length(x); \
203 \
204 for (R_len_t i = 0; i < n_cols; ++i) { \
205 SEXP col = VECTOR_ELT(x, i); \
206 SET_VECTOR_ELT(x, i, PROXY(col)); \
207 } \
208 } while (0)
209
210 static
df_proxy(SEXP x,enum vctrs_proxy_kind kind)211 SEXP df_proxy(SEXP x, enum vctrs_proxy_kind kind) {
212 x = PROTECT(r_clone_referenced(x));
213
214 switch (kind) {
215 case VCTRS_PROXY_KIND_default: DF_PROXY(vec_proxy); break;
216 case VCTRS_PROXY_KIND_equal: DF_PROXY(vec_proxy_equal); break;
217 case VCTRS_PROXY_KIND_compare: DF_PROXY(vec_proxy_compare); break;
218 case VCTRS_PROXY_KIND_order: DF_PROXY(vec_proxy_order); break;
219 case VCTRS_PROXY_KIND_complete: DF_PROXY(vec_proxy_complete); break;
220 }
221
222 x = PROTECT(df_flatten(x));
223 x = vec_proxy_unwrap(x);
224
225 UNPROTECT(2);
226 return x;
227 }
228
229 #undef DF_PROXY
230
231 // [[ register() ]]
vctrs_df_proxy(SEXP x,SEXP kind)232 SEXP vctrs_df_proxy(SEXP x, SEXP kind) {
233 if (!r_is_number(kind)) {
234 stop_internal("vctrs_df_proxy", "`kind` must be a single integer.");
235 }
236
237 enum vctrs_proxy_kind c_kind = r_int_get(kind, 0);
238
239 return df_proxy(x, c_kind);
240 }
241
242
243 static
vec_proxy_unwrap(SEXP x)244 SEXP vec_proxy_unwrap(SEXP x) {
245 if (TYPEOF(x) == VECSXP && XLENGTH(x) == 1 && is_data_frame(x)) {
246 x = vec_proxy_unwrap(VECTOR_ELT(x, 0));
247 }
248 return x;
249 }
250
251
252 // [[ register() ]]
vctrs_unset_s4(SEXP x)253 SEXP vctrs_unset_s4(SEXP x) {
254 x = r_clone_referenced(x);
255 r_unmark_s4(x);
256 return x;
257 }
258
259
vctrs_init_data(SEXP ns)260 void vctrs_init_data(SEXP ns) {
261 syms_vec_proxy = Rf_install("vec_proxy");
262
263 syms_vec_proxy_equal = Rf_install("vec_proxy_equal");
264 syms_vec_proxy_equal_array = Rf_install("vec_proxy_equal.array");
265
266 syms_vec_proxy_compare = Rf_install("vec_proxy_compare");
267 syms_vec_proxy_compare_array = Rf_install("vec_proxy_compare.array");
268
269 syms_vec_proxy_order = Rf_install("vec_proxy_order");
270 syms_vec_proxy_order_array = Rf_install("vec_proxy_order.array");
271
272 fns_vec_proxy_equal_array = r_env_get(ns, syms_vec_proxy_equal_array);
273 fns_vec_proxy_compare_array = r_env_get(ns, syms_vec_proxy_compare_array);
274 fns_vec_proxy_order_array = r_env_get(ns, syms_vec_proxy_order_array);
275 }
276