1 #include "vctrs.h"
2 #include "utils.h"
3 
4 
5 // Defined below
6 enum vctrs_class_type class_type(SEXP x);
7 static enum vctrs_class_type class_type_impl(SEXP class);
8 static const char* class_type_as_str(enum vctrs_class_type type);
9 
10 
11 // [[ register() ]]
vctrs_class_type(SEXP x)12 SEXP vctrs_class_type(SEXP x) {
13   return Rf_mkString(class_type_as_str(class_type(x)));
14 }
15 
16 
17 // [[ include("utils.h") ]]
class_type(SEXP x)18 enum vctrs_class_type class_type(SEXP x) {
19   if (!OBJECT(x)) {
20     return vctrs_class_none;
21   }
22 
23   SEXP class = PROTECT(Rf_getAttrib(x, R_ClassSymbol));
24 
25   // Avoid corrupt objects where `x` is an OBJECT(), but the class is NULL
26   if (class == R_NilValue) {
27     UNPROTECT(1);
28     return vctrs_class_none;
29   }
30 
31   enum vctrs_class_type type = class_type_impl(class);
32 
33   UNPROTECT(1);
34   return type;
35 }
36 
class_type_impl(SEXP class)37 static enum vctrs_class_type class_type_impl(SEXP class) {
38   int n = Rf_length(class);
39   SEXP const* p = STRING_PTR_RO(class);
40 
41   // First check for bare types for which we know how many strings are
42   // the classes composed of
43   switch (n) {
44   case 1: {
45     SEXP p0 = p[0];
46 
47     if (p0 == strings_data_frame) {
48       return vctrs_class_bare_data_frame;
49     } else if (p0 == strings_factor) {
50       return vctrs_class_bare_factor;
51     } else if (p0 == strings_date) {
52       return vctrs_class_bare_date;
53     }
54 
55     break;
56   }
57   case 2: {
58     SEXP p0 = p[0];
59     SEXP p1 = p[1];
60 
61     if (p0 == strings_ordered &&
62         p1 == strings_factor) {
63       return vctrs_class_bare_ordered;
64     }
65 
66     if (p1 == strings_posixt) {
67       if (p0 == strings_posixct) {
68         return vctrs_class_bare_posixct;
69       } else if (p0 == strings_posixlt) {
70         return vctrs_class_bare_posixlt;
71       }
72     }
73 
74     break;
75   }
76   case 3: {
77     if (p[0] == strings_tbl_df &&
78         p[1] == strings_tbl &&
79         p[2] == strings_data_frame) {
80       return vctrs_class_bare_tibble;
81     }
82 
83     break;
84   }}
85 
86   // Now check for inherited classes
87   p = p + n - 1;
88   SEXP last = *p;
89 
90   if (last == strings_data_frame) {
91     return vctrs_class_data_frame;
92   } else if (last == strings_list) {
93     return vctrs_class_list;
94   }
95 
96   return vctrs_class_unknown;
97 }
98 
class_type_as_str(enum vctrs_class_type type)99 static const char* class_type_as_str(enum vctrs_class_type type) {
100   switch (type) {
101   case vctrs_class_list: return "list";
102   case vctrs_class_data_frame: return "data_frame";
103   case vctrs_class_bare_data_frame: return "bare_data_frame";
104   case vctrs_class_bare_tibble: return "bare_tibble";
105   case vctrs_class_bare_factor: return "bare_factor";
106   case vctrs_class_bare_ordered: return "bare_ordered";
107   case vctrs_class_bare_date: return "bare_date";
108   case vctrs_class_bare_posixct: return "bare_posixct";
109   case vctrs_class_bare_posixlt: return "bare_posixlt";
110   case vctrs_class_unknown: return "unknown";
111   case vctrs_class_none: return "none";
112   }
113   never_reached("class_type_as_str");
114 }
115 
116 
117 // [[ include("vctrs.h") ]]
vec_is_partial(SEXP x)118 bool vec_is_partial(SEXP x) {
119   return x == R_NilValue || (TYPEOF(x) == VECSXP && Rf_inherits(x, "vctrs_partial"));
120 }
121 
122 // [[ register() ]]
vctrs_is_partial(SEXP x)123 SEXP vctrs_is_partial(SEXP x) {
124   return Rf_ScalarLogical(vec_is_partial(x));
125 }
126