Annotation of /pkg/Matrix/src/Mutils.h

Parent Directory | Revision Log

---

Revision 2713 - (view) (download) (as text)

1 :	bates	10	#ifndef MATRIX_MUTILS_H
2 :			#define MATRIX_MUTILS_H
3 :
4 :	mmaechler	2583	#undef Matrix_with_SPQR
5 :	mmaechler	2336
6 :	bates	582	#ifdef __cplusplus
7 :			extern "C" {
8 :			#endif
9 :	maechler	890
10 :	mmaechler	2685	#include <stdint.h> // C99 for int64_t
11 :	bates	2049	#include <ctype.h>
12 :			#include <R.h> /* includes Rconfig.h */
13 :	maechler	2121	#include <Rversion.h>
14 :	maechler	1394	#include <Rdefines.h> /* Rinternals.h + GET_SLOT etc */
15 :	maechler	890
16 :	bates	582	#ifdef ENABLE_NLS
17 :			#include <libintl.h>
18 :			#define _(String) dgettext ("Matrix", String)
19 :			#else
20 :			#define _(String) (String)
21 :	mmaechler	2392	/* Note that this is not yet supported (for Windows, e.g.) in R 2.9.0 : */
22 :			#define dngettext(pkg, String, StringP, N) (N > 1 ? StringP : String)
23 :	bates	582	#endif
24 :	maechler	890
25 :	bates	2045	#ifdef __GNUC__
26 :			# undef alloca
27 :			# define alloca(x) __builtin_alloca((x))
28 :	mmaechler	2298	#elif defined(__sun) || defined(_AIX)
29 :			/* this is necessary (and sufficient) for Solaris 10 and AIX 6: */
30 :	maechler	2061	# include <alloca.h>
31 :	bates	2045	#endif
32 :
33 :	maechler	1960	#define Alloca(n, t) (t *) alloca( (size_t) ( (n) * sizeof(t) ) )
34 :
35 :	maechler	890	SEXP triangularMatrix_validate(SEXP obj);
36 :			SEXP symmetricMatrix_validate(SEXP obj);
37 :	maechler	1164	SEXP dense_nonpacked_validate(SEXP obj);
38 :	maechler	890
39 :	bates	582	/* enum constants from cblas.h and some short forms */
40 :			enum CBLAS_ORDER {CblasRowMajor=101, CblasColMajor=102};
41 :			enum CBLAS_TRANSPOSE {CblasNoTrans=111, CblasTrans=112, CblasConjTrans=113};
42 :			enum CBLAS_UPLO {CblasUpper=121, CblasLower=122};
43 :			enum CBLAS_DIAG {CblasNonUnit=131, CblasUnit=132};
44 :			enum CBLAS_SIDE {CblasLeft=141, CblasRight=142};
45 :	bates	447	#define RMJ CblasRowMajor
46 :			#define CMJ CblasColMajor
47 :			#define NTR CblasNoTrans
48 :			#define TRN CblasTrans
49 :			#define CTR CblasConjTrans
50 :			#define UPP CblasUpper
51 :			#define LOW CblasLower
52 :			#define NUN CblasNonUnit
53 :			#define UNT CblasUnit
54 :			#define LFT CblasLeft
55 :			#define RGT CblasRight
56 :
57 :	bates	10	double get_double_by_name(SEXP obj, char *nm);
58 :			SEXP set_double_by_name(SEXP obj, double val, char *nm);
59 :			SEXP as_det_obj(double val, int log, int sign);
60 :	bates	476	SEXP get_factors(SEXP obj, char *nm);
61 :			SEXP set_factors(SEXP obj, SEXP val, char *nm);
62 :	maechler	2115
63 :			#if 0
64 :	bates	478	SEXP dgCMatrix_set_Dim(SEXP x, int nrow);
65 :	maechler	2115	#endif /* unused */
66 :	maechler	943
67 :	bates	1555	/* int csc_unsorted_columns(int ncol, const int p[], const int i[]); */
68 :			/* void csc_sort_columns(int ncol, const int p[], int i[], double x[]); */
69 :			/* SEXP csc_check_column_sorting(SEXP A); */
70 :	mmaechler	2449
71 :	bates	592	SEXP check_scalar_string(SEXP sP, char *vals, char *nm);
72 :	maechler	2113	Rboolean equal_string_vectors(SEXP s1, SEXP s2);
73 :
74 :	maechler	1747	void d_packed_getDiag(double *dest, SEXP x, int n);
75 :			void l_packed_getDiag( int *dest, SEXP x, int n);
76 :			void tr_d_packed_getDiag(double *dest, SEXP x);
77 :			void tr_l_packed_getDiag( int *dest, SEXP x);
78 :
79 :	bates	862	SEXP Matrix_getElement(SEXP list, char *nm);
80 :	bates	592
81 :	maechler	952	#define PACKED_TO_FULL(TYPE) \
82 :			TYPE *packed_to_full_ ## TYPE(TYPE *dest, const TYPE *src, \
83 :			int n, enum CBLAS_UPLO uplo)
84 :			PACKED_TO_FULL(double);
85 :			PACKED_TO_FULL(int);
86 :			#undef PACKED_TO_FULL
87 :	bates	738
88 :	maechler	952	#define FULL_TO_PACKED(TYPE) \
89 :			TYPE *full_to_packed_ ## TYPE(TYPE *dest, const TYPE *src, int n, \
90 :			enum CBLAS_UPLO uplo, enum CBLAS_DIAG diag)
91 :			FULL_TO_PACKED(double);
92 :			FULL_TO_PACKED(int);
93 :			#undef FULL_TO_PACKED
94 :
95 :
96 :	bates	592	extern /* stored pointers to symbols initialized in R_init_Matrix */
97 :	bates	329	#include "Syms.h"
98 :	bates	10
99 :	bates	432	/* zero an array */
100 :	bates	441	#define AZERO(x, n) {int _I_, _SZ_ = (n); for(_I_ = 0; _I_ < _SZ_; _I_++) (x)[_I_] = 0;}
101 :	bates	432
102 :	bates	597	/* number of elements in one triangle of a square matrix of order n */
103 :			#define PACKED_LENGTH(n) ((n) * ((n) + 1))/2
104 :
105 :	bates	738	/* duplicate the slot with name given by sym from src to dest */
106 :	maechler	2120
107 :	bates	738	#define slot_dup(dest, src, sym) SET_SLOT(dest, sym, duplicate(GET_SLOT(src, sym)))
108 :
109 :	maechler	2120	/* is not yet used: */
110 :	maechler	1736	#define slot_nonNull_dup(dest, src, sym) \
111 :			if(GET_SLOT(src, sym) != R_NilValue) \
112 :			SET_SLOT(dest, sym, duplicate(GET_SLOT(src, sym)))
113 :
114 :	mmaechler	2628	#define slot_dup_if_has(dest, src, sym) \
115 :			if(R_has_slot(src, sym)) \
116 :			SET_SLOT(dest, sym, duplicate(GET_SLOT(src, sym)))
117 :
118 :	maechler	1736	/* TODO: Make this faster for the case where dimnames = list(NULL,NULL)
119 :			* and hence don't have to be set ! */
120 :			#define SET_DimNames(dest, src) slot_dup(dest, src, Matrix_DimNamesSym)
121 :
122 :
123 :	maechler	951	#define uplo_P(_x_) CHAR(STRING_ELT(GET_SLOT(_x_, Matrix_uploSym), 0))
124 :			#define diag_P(_x_) CHAR(STRING_ELT(GET_SLOT(_x_, Matrix_diagSym), 0))
125 :	bates	1461	#define class_P(_x_) CHAR(asChar(getAttrib(_x_, R_ClassSymbol)))
126 :	maechler	951
127 :	mmaechler	2628	// Define this "Cholmod compatible" to some degree
128 :			enum x_slot_kind {x_pattern=-1, x_double=0, x_logical=1, x_integer=2, x_complex=3};
129 :	mmaechler	2684	// n d l i z
130 :	mmaechler	2628
131 :	maechler	1725	/* should also work for "matrix" matrices: */
132 :			#define Real_KIND(_x_) (IS_S4_OBJECT(_x_) ? Real_kind(_x_) : \
133 :	mmaechler	2628	(isReal(_x_) ? x_double : (isLogical(_x_) ? x_logical : -1)))
134 :	maechler	2115	/* This one gives '0' also for integer "matrix" :*/
135 :			#define Real_KIND2(_x_) (IS_S4_OBJECT(_x_) ? Real_kind(_x_) : \
136 :	mmaechler	2628	(isLogical(_x_) ? x_logical : 0))
137 :	maechler	1725
138 :			/* requires 'x' slot: */
139 :	maechler	1548	#define Real_kind(_x_) (isReal(GET_SLOT(_x_, Matrix_xSym)) ? 0 : \
140 :	maechler	1725	(isLogical(GET_SLOT(_x_, Matrix_xSym)) ? 1 : -1))
141 :	maechler	1548
142 :	maechler	2115	#define DECLARE_AND_GET_X_SLOT(__C_TYPE, __SEXP) \
143 :			__C_TYPE *xx = __SEXP(GET_SLOT(x, Matrix_xSym))
144 :	maechler	1548
145 :	maechler	2115
146 :	maechler	890	/**
147 :	bates	597	* Check for valid length of a packed triangular array and return the
148 :			* corresponding number of columns
149 :	maechler	890	*
150 :	bates	597	* @param len length of a packed triangular array
151 :	maechler	890	*
152 :	bates	597	* @return number of columns
153 :			*/
154 :			static R_INLINE
155 :	maechler	890	int packed_ncol(int len)
156 :	bates	597	{
157 :			int disc = 8 * len + 1; /* discriminant */
158 :			int sqrtd = (int) sqrt((double) disc);
159 :
160 :			if (len < 0 || disc != sqrtd * sqrtd)
161 :			error(_("invalid 'len' = %d in packed_ncol"));
162 :			return (sqrtd - 1)/2;
163 :			}
164 :
165 :	maechler	890	/**
166 :	bates	536	* Allocate an SEXP of given type and length, assign it as slot nm in
167 :			* the object, and return the SEXP. The validity of this function
168 :			* depends on SET_SLOT not duplicating val when NAMED(val) == 0. If
169 :			* this behavior changes then ALLOC_SLOT must use SET_SLOT followed by
170 :			* GET_SLOT to ensure that the value returned is indeed the SEXP in
171 :			* the slot.
172 :	maechler	1747	* NOTE: GET_SLOT(x, what) :== R_do_slot (x, what)
173 :			* ---- SET_SLOT(x, what, value) :== R_do_slot_assign(x, what, value)
174 :			* and the R_do_slot* are in src/main/attrib.c
175 :	maechler	890	*
176 :	bates	536	* @param obj object in which to assign the slot
177 :			* @param nm name of the slot, as an R name object
178 :			* @param type type of SEXP to allocate
179 :			* @param length length of SEXP to allocate
180 :	maechler	890	*
181 :	bates	536	* @return SEXP of given type and length assigned as slot nm in obj
182 :			*/
183 :			static R_INLINE
184 :			SEXP ALLOC_SLOT(SEXP obj, SEXP nm, SEXPTYPE type, int length)
185 :			{
186 :			SEXP val = allocVector(type, length);
187 :	bates	441
188 :	bates	536	SET_SLOT(obj, nm, val);
189 :			return val;
190 :			}
191 :
192 :	maechler	890	/**
193 :	bates	679	* Expand compressed pointers in the array mp into a full set of indices
194 :	bates	536	* in the array mj.
195 :	maechler	890	*
196 :	bates	679	* @param ncol number of columns (or rows)
197 :	bates	536	* @param mp column pointer vector of length ncol + 1
198 :	bates	679	* @param mj vector of length mp[ncol] to hold the result
199 :	maechler	890	*
200 :	bates	536	* @return mj
201 :			*/
202 :			static R_INLINE
203 :	bates	679	int* expand_cmprPt(int ncol, const int mp[], int mj[])
204 :	bates	536	{
205 :			int j;
206 :			for (j = 0; j < ncol; j++) {
207 :			int j2 = mp[j+1], jj;
208 :			for (jj = mp[j]; jj < j2; jj++) mj[jj] = j;
209 :			}
210 :			return mj;
211 :			}
212 :
213 :	mmaechler	2175	/**
214 :	dmbates	2260	* Check if slot(obj, "x") contains any NA (or NaN).
215 :	mmaechler	2175	*
216 :	mmaechler	2677	* @param obj a 'Matrix' object with a (double precision) 'x' slot.
217 :	mmaechler	2175	*
218 :	dmbates	2260	* @return Rboolean :== any(is.na(slot(obj, "x") )
219 :	mmaechler	2175	*/
220 :			static R_INLINE
221 :	mmaechler	2453	Rboolean any_NA_in_x(SEXP obj)
222 :	mmaechler	2175	{
223 :			double *x = REAL(GET_SLOT(obj, Matrix_xSym));
224 :			int i, n = LENGTH(GET_SLOT(obj, Matrix_xSym));
225 :			for(i=0; i < n; i++)
226 :			if(ISNAN(x[i])) return TRUE;
227 :			/* else */
228 :			return FALSE;
229 :			}
230 :
231 :
232 :	maechler	1200	void make_d_matrix_triangular(double *x, SEXP from);
233 :			void make_i_matrix_triangular( int *x, SEXP from);
234 :	bates	582
235 :	maechler	1200	void make_d_matrix_symmetric(double *to, SEXP from);
236 :			void make_i_matrix_symmetric( int *to, SEXP from);
237 :
238 :	bates	738	SEXP Matrix_expand_pointers(SEXP pP);
239 :
240 :	maechler	1432	SEXP dup_mMatrix_as_dgeMatrix(SEXP A);
241 :	maechler	1725	SEXP dup_mMatrix_as_geMatrix (SEXP A);
242 :	bates	1395
243 :	maechler	1654	SEXP new_dgeMatrix(int nrow, int ncol);
244 :	mmaechler	2525	SEXP m_encodeInd (SEXP ij, SEXP di, SEXP chk_bnds);
245 :			SEXP m_encodeInd2(SEXP i, SEXP j, SEXP di, SEXP chk_bnds);
246 :	maechler	1654
247 :	mmaechler	2203
248 :	bates	1461	static R_INLINE SEXP
249 :			mMatrix_as_dgeMatrix(SEXP A)
250 :			{
251 :	bates	1463	return strcmp(class_P(A), "dgeMatrix") ? dup_mMatrix_as_dgeMatrix(A) : A;
252 :	bates	1461	}
253 :	bates	1416
254 :	maechler	1725	static R_INLINE SEXP
255 :			mMatrix_as_geMatrix(SEXP A)
256 :			{
257 :			return strcmp(class_P(A) + 1, "geMatrix") ? dup_mMatrix_as_geMatrix(A) : A;
258 :			}
259 :
260 :	mmaechler	2713	// Keep centralized --- *and* in sync with ../inst/include/Matrix.h :
261 :			#define MATRIX_VALID_dense \
262 :			"dmatrix", "dgeMatrix", \
263 :			"lmatrix", "lgeMatrix", \
264 :			"nmatrix", "ngeMatrix", \
265 :			"zmatrix", "zgeMatrix"
266 :
267 :			#define MATRIX_VALID_Csparse \
268 :			"dgCMatrix", "dsCMatrix", "dtCMatrix", \
269 :			"lgCMatrix", "lsCMatrix", "ltCMatrix", \
270 :			"ngCMatrix", "nsCMatrix", "ntCMatrix", \
271 :			"zgCMatrix", "zsCMatrix", "ztCMatrix"
272 :
273 :			#define MATRIX_VALID_Tsparse \
274 :			"dgTMatrix", "dsTMatrix", "dtTMatrix", \
275 :			"lgTMatrix", "lsTMatrix", "ltTMatrix", \
276 :			"ngTMatrix", "nsTMatrix", "ntTMatrix", \
277 :			"zgTMatrix", "zsTMatrix", "ztTMatrix"
278 :
279 :			#define MATRIX_VALID_Rsparse \
280 :			"dgRMatrix", "dsRMatrix", "dtRMatrix", \
281 :			"lgRMatrix", "lsRMatrix", "ltRMatrix", \
282 :			"ngRMatrix", "nsRMatrix", "ntRMatrix", \
283 :			"zgRMatrix", "zsRMatrix", "ztRMatrix"
284 :
285 :			#define MATRIX_VALID_CHMfactor "dCHMsuper", "dCHMsimpl", "nCHMsuper", "nCHMsimpl"
286 :
287 :	bates	1416	/**
288 :			* Return the 0-based index of a string match in a vector of strings
289 :			* terminated by an empty string. Returns -1 for no match.
290 :			*
291 :	bates	2104	* @param class string to match
292 :	bates	1416	* @param valid vector of possible matches terminated by an empty string
293 :			*
294 :			* @return index of match or -1 for no match
295 :			*/
296 :			static R_INLINE int
297 :	mmaechler	2647	Matrix_check_class(char *class, const char **valid)
298 :	bates	1416	{
299 :			int ans;
300 :			for (ans = 0; ; ans++) {
301 :			if (!strlen(valid[ans])) return -1;
302 :			if (!strcmp(class, valid[ans])) return ans;
303 :			}
304 :			}
305 :
306 :	mmaechler	2645	/**
307 :			* These are the ones users should use -- is() versions, also looking
308 :			* at super classes:
309 :			*/
310 :	mmaechler	2646	int Matrix_check_class_etc(SEXP x, const char **valid);
311 :	mmaechler	2645	#if R_VERSION < R_Version(2, 13, 0)
312 :	mmaechler	2646	int Matrix_check_class_and_super(SEXP x, const char **valid, SEXP rho);
313 :	mmaechler	2645	#else
314 :			# define Matrix_check_class_and_super R_check_class_and_super
315 :			#endif
316 :	mmaechler	2203
317 :	mmaechler	2677
318 :			/** Accessing *sparseVectors : fast (and recycling) v[i] for v = ?sparseVector:
319 :			* -> ./sparseVector.c -> ./t_sparseVector.c :
320 :			*/
321 :			// Type_ans sparseVector_sub(int64_t i, int nnz_v, int* v_i, Type_ans* v_x, int len_v):
322 :
323 :			/* Define all of
324 :			* dsparseVector_sub(....)
325 :			* isparseVector_sub(....)
326 :			* lsparseVector_sub(....)
327 :			* nsparseVector_sub(....)
328 :			* zsparseVector_sub(....)
329 :			*/
330 :			#define _dspV_
331 :			#include "t_sparseVector.c"
332 :
333 :			#define _ispV_
334 :			#include "t_sparseVector.c"
335 :
336 :			#define _lspV_
337 :			#include "t_sparseVector.c"
338 :
339 :			#define _nspV_
340 :			#include "t_sparseVector.c"
341 :
342 :			#define _zspV_
343 :			#include "t_sparseVector.c"
344 :
345 :
346 :	bates	582	#ifdef __cplusplus
347 :			}
348 :	bates	572	#endif
349 :	bates	582
350 :			#endif /* MATRIX_MUTILS_H_ */

---

root@r-forge.r-project.org	ViewVC Help
Powered by ViewVC 1.0.0