Matrix r5059
Loading...
Searching...
No Matches
attrib.c
Go to the documentation of this file.
1#include "Mdefines.h"
2
3/* .... Dim ......................................................... */
4
5SEXP R_Dim_prod(SEXP dim)
6{
7 SEXP ans;
8 int m = INTEGER(dim)[0], n = INTEGER(dim)[1];
9 int_fast64_t mn = (int_fast64_t) m * n;
10 if (mn <= INT_MAX) {
11 ans = Rf_allocVector(INTSXP, 1);
12 INTEGER(ans)[0] = (int) mn;
13 } else {
14 int_fast64_t mn_ = (int_fast64_t) (double) mn;
15 if (mn_ > mn)
16 mn_ = (int_fast64_t) nextafter((double) mn, 0.0);
17 ans = Rf_allocVector(REALSXP, 1);
18 REAL(ans)[0] = (double) mn_;
19 if (mn_ != mn) {
20 SEXP off;
21 PROTECT(ans);
22 PROTECT(off = Rf_allocVector(REALSXP, 1));
23 REAL(off)[0] = (double) (mn - mn_);
24 Rf_setAttrib(ans, Matrix_offSym, off);
25#if 0
26 Rf_warning(_("true length %llu truncated to %llu"),
27 mn, mn_);
28#endif
29 UNPROTECT(2);
30 }
31 }
32 return ans;
33}
34
35
36/* .... Dimnames .................................................... */
37
39{
40 return
41 VECTOR_ELT(dn, 0) == R_NilValue &&
42 VECTOR_ELT(dn, 1) == R_NilValue &&
43 Rf_getAttrib(dn, R_NamesSymbol) == R_NilValue;
44}
45
47{
48 SEXP rn, cn, ndn;
49 const char *nrn, *ncn;
50 int n;
51
52 return
53 !(((rn = VECTOR_ELT(dn, 0)) != R_NilValue &&
54 (cn = VECTOR_ELT(dn, 1)) != R_NilValue &&
55 rn != cn &&
56 ((n = LENGTH(rn)) != LENGTH(cn) ||
57 !equalString(rn, cn, n))) ||
58 (((ndn = Rf_getAttrib(dn, R_NamesSymbol)) != R_NilValue &&
59 *(nrn = CHAR(STRING_ELT(ndn, 0))) != '\0' &&
60 *(ncn = CHAR(STRING_ELT(ndn, 1))) != '\0' &&
61 strcmp(nrn, ncn) != 0)));
62}
63
65{
66 return Rf_ScalarLogical(DimNames_is_symmetric(dn));
67}
68
69void symDN(SEXP dest, SEXP src, int J /* -1|0|1 */)
70{
71 J = (J < 0) ? -1 : (J != 0);
72 SEXP s;
73 if (J < 0) {
74 if ((s = VECTOR_ELT(src, J = 1)) != R_NilValue ||
75 (s = VECTOR_ELT(src, J = 0)) != R_NilValue) {
76 SET_VECTOR_ELT(dest, 0, s);
77 SET_VECTOR_ELT(dest, 1, s);
78 } else
79 J = 1;
80 } else {
81 if ((s = VECTOR_ELT(src, J)) != R_NilValue) {
82 SET_VECTOR_ELT(dest, 0, s);
83 SET_VECTOR_ELT(dest, 1, s);
84 }
85 }
86 PROTECT(s = Rf_getAttrib(src, R_NamesSymbol));
87 if (s != R_NilValue) {
88 SEXP destnms = PROTECT(Rf_allocVector(STRSXP, 2));
89 if (CHAR(s = STRING_ELT(s, J))[0] != '\0') {
90 SET_STRING_ELT(destnms, 0, s);
91 SET_STRING_ELT(destnms, 1, s);
92 }
93 Rf_setAttrib(dest, R_NamesSymbol, destnms);
94 UNPROTECT(1);
95 }
96 UNPROTECT(1);
97 return;
98}
99
100SEXP R_symDN(SEXP dn)
101{
102 if (DimNames_is_trivial(dn))
103 return dn;
104 SEXP value = PROTECT(Rf_allocVector(VECSXP, 2));
105 symDN(value, dn, -1);
106 UNPROTECT(1);
107 return value;
108}
109
110void cpyDN(SEXP dest, SEXP src, int J /* 0|1 */)
111{
112 J = J != 0;
113 SEXP s;
114 if ((s = VECTOR_ELT(src, 0)) != R_NilValue)
115 SET_VECTOR_ELT(dest, J, s);
116 if ((s = VECTOR_ELT(src, 1)) != R_NilValue)
117 SET_VECTOR_ELT(dest, !J, s);
118 PROTECT(s = Rf_getAttrib(src, R_NamesSymbol));
119 if (s != R_NilValue) {
120 SEXP srcnms = s, destnms = PROTECT(Rf_allocVector(STRSXP, 2));
121 if (CHAR(s = STRING_ELT(srcnms, 0))[0] != '\0')
122 SET_STRING_ELT(destnms, J, s);
123 if (CHAR(s = STRING_ELT(srcnms, 1))[0] != '\0')
124 SET_STRING_ELT(destnms, !J, s);
125 Rf_setAttrib(dest, R_NamesSymbol, destnms);
126 UNPROTECT(1);
127 }
128 UNPROTECT(1);
129 return;
130}
131
132SEXP (DIMNAMES)(SEXP obj, int mode)
133{
134 SEXP dn = GET_SLOT(obj, Matrix_DimNamesSym);
135 if (mode != 0) {
136 PROTECT(dn);
137 if (!DimNames_is_trivial(dn)) {
138 SEXP value = PROTECT(Rf_allocVector(VECSXP, 2));
139 if (mode < 0)
140 symDN(value, dn, mode);
141 else
142 cpyDN(value, dn, mode);
143 UNPROTECT(1);
144 dn = value;
145 }
146 UNPROTECT(1);
147 }
148 return dn;
149}
150
151void (SET_DIMNAMES)(SEXP obj, int mode, SEXP value)
152{
153 PROTECT(value);
154 if (!DimNames_is_trivial(value)) {
155 SEXP dn = PROTECT(GET_SLOT(obj, Matrix_DimNamesSym));
156 if (mode < 0)
157 symDN(dn, value, mode);
158 else
159 cpyDN(dn, value, mode);
160 UNPROTECT(1);
161 }
162 UNPROTECT(1);
163 return;
164}
165
166
167/* .... factors ..................................................... */
168
169static
170R_xlen_t strmatch(const char *s, SEXP nms)
171{
172 if (TYPEOF(nms) == STRSXP) {
173 for (R_xlen_t i = 0, n = XLENGTH(nms); i < n; ++i)
174 if (strcmp(s, CHAR(STRING_ELT(nms, i))) == 0)
175 return i;
176 }
177 return (R_xlen_t) -1;
178}
179
180SEXP get_factor(SEXP obj, const char *nm)
181{
182 SEXP factors = PROTECT(GET_SLOT(obj, Matrix_factorsSym)),
183 nms = PROTECT(Rf_getAttrib(factors, R_NamesSymbol)),
184 val = R_NilValue;
185 R_xlen_t i = strmatch(nm, nms);
186 if (i >= 0)
187 val = VECTOR_ELT(factors, i);
188 UNPROTECT(2);
189 return val;
190}
191
192void set_factor(SEXP obj, const char *nm, SEXP val)
193{
194 PROTECT(obj);
195 PROTECT(val);
196 SEXP factors = PROTECT(GET_SLOT(obj, Matrix_factorsSym)),
197 nms = PROTECT(Rf_getAttrib(factors, R_NamesSymbol));
198 R_xlen_t i = strmatch(nm, nms);
199 if (i >= 0) {
200 SET_VECTOR_ELT(factors, i, val);
201 UNPROTECT(4);
202 return;
203 }
204 R_xlen_t n = XLENGTH(factors);
205 SEXP factors1 = PROTECT(Rf_allocVector(VECSXP, n + 1)),
206 nms1 = PROTECT(Rf_allocVector(STRSXP, n + 1));
207 for (i = 0; i < n; ++i) {
208 SET_VECTOR_ELT(factors1, i, VECTOR_ELT(factors, i));
209 if (nms != R_NilValue)
210 SET_STRING_ELT( nms1, i, STRING_ELT( nms, i));
211 }
212 SET_VECTOR_ELT(factors1, n, val);
213 SET_STRING_ELT( nms1, n, Rf_mkChar(nm));
214 Rf_setAttrib(factors1, R_NamesSymbol, nms1);
215 SET_SLOT(obj, Matrix_factorsSym, factors1);
216 UNPROTECT(6);
217 return;
218}
219
220SEXP R_set_factor(SEXP s_obj, SEXP s_nm, SEXP s_val, SEXP s_warn)
221{
222 if (TYPEOF(s_nm) != STRSXP || LENGTH(s_nm) < 1 ||
223 (s_nm = STRING_ELT(s_nm, 0)) == NA_STRING)
224 Rf_error(_("invalid factor name"));
225 else if (TYPEOF(Rf_getAttrib(s_obj, Matrix_factorsSym)) == VECSXP)
226 set_factor(s_obj, CHAR(s_nm), s_val);
227 else if (Rf_asLogical(s_warn))
228 Rf_warning(_("attempt to set factor on %s without '%s' slot"),
229 "Matrix", "factors");
230 return s_val;
231}
#define _(String)
Definition Mdefines.h:66
#define SET_DIMNAMES(x, mode, value)
Definition Mdefines.h:98
#define DIMNAMES(x, mode)
Definition Mdefines.h:96
#define GET_SLOT(x, name)
Definition Mdefines.h:72
int equalString(SEXP, SEXP, R_xlen_t)
Definition utils.c:28
#define SET_SLOT(x, name, value)
Definition Mdefines.h:73
#define TYPEOF(s)
Definition Mdefines.h:123
SEXP R_symDN(SEXP dn)
Definition attrib.c:100
int DimNames_is_symmetric(SEXP dn)
Definition attrib.c:46
SEXP R_DimNames_is_symmetric(SEXP dn)
Definition attrib.c:64
int DimNames_is_trivial(SEXP dn)
Definition attrib.c:38
void symDN(SEXP dest, SEXP src, int J)
Definition attrib.c:69
SEXP R_set_factor(SEXP s_obj, SEXP s_nm, SEXP s_val, SEXP s_warn)
Definition attrib.c:220
SEXP get_factor(SEXP obj, const char *nm)
Definition attrib.c:180
void set_factor(SEXP obj, const char *nm, SEXP val)
Definition attrib.c:192
static R_xlen_t strmatch(const char *s, SEXP nms)
Definition attrib.c:170
SEXP R_Dim_prod(SEXP dim)
Definition attrib.c:5
void cpyDN(SEXP dest, SEXP src, int J)
Definition attrib.c:110
SEXP Matrix_factorsSym
Definition init.c:606
SEXP Matrix_DimNamesSym
Definition init.c:597
SEXP Matrix_offSym
Definition init.c:620