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

Parent Directory | Revision Log

---

Revision 2583 - (view) (download) (as text)
Original Path: pkg/src/Mutils.h

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 :	bates	2049	#include <ctype.h>
11 :			#include <R.h> /* includes Rconfig.h */
12 :	maechler	2121	#include <Rversion.h>
13 :	maechler	1394	#include <Rdefines.h> /* Rinternals.h + GET_SLOT etc */
14 :	maechler	890
15 :	bates	582	#ifdef ENABLE_NLS
16 :			#include <libintl.h>
17 :			#define _(String) dgettext ("Matrix", String)
18 :			#else
19 :			#define _(String) (String)
20 :	mmaechler	2392	/* Note that this is not yet supported (for Windows, e.g.) in R 2.9.0 : */
21 :			#define dngettext(pkg, String, StringP, N) (N > 1 ? StringP : String)
22 :	bates	582	#endif
23 :	maechler	890
24 :	bates	2045	#ifdef __GNUC__
25 :			# undef alloca
26 :			# define alloca(x) __builtin_alloca((x))
27 :	mmaechler	2298	#elif defined(__sun) || defined(_AIX)
28 :			/* this is necessary (and sufficient) for Solaris 10 and AIX 6: */
29 :	maechler	2061	# include <alloca.h>
30 :	bates	2045	#endif
31 :
32 :	maechler	1960	#define Alloca(n, t) (t *) alloca( (size_t) ( (n) * sizeof(t) ) )
33 :
34 :	maechler	890	SEXP triangularMatrix_validate(SEXP obj);
35 :			SEXP symmetricMatrix_validate(SEXP obj);
36 :	maechler	1164	SEXP dense_nonpacked_validate(SEXP obj);
37 :	maechler	890
38 :	bates	582	/* enum constants from cblas.h and some short forms */
39 :			enum CBLAS_ORDER {CblasRowMajor=101, CblasColMajor=102};
40 :			enum CBLAS_TRANSPOSE {CblasNoTrans=111, CblasTrans=112, CblasConjTrans=113};
41 :			enum CBLAS_UPLO {CblasUpper=121, CblasLower=122};
42 :			enum CBLAS_DIAG {CblasNonUnit=131, CblasUnit=132};
43 :			enum CBLAS_SIDE {CblasLeft=141, CblasRight=142};
44 :	bates	447	#define RMJ CblasRowMajor
45 :			#define CMJ CblasColMajor
46 :			#define NTR CblasNoTrans
47 :			#define TRN CblasTrans
48 :			#define CTR CblasConjTrans
49 :			#define UPP CblasUpper
50 :			#define LOW CblasLower
51 :			#define NUN CblasNonUnit
52 :			#define UNT CblasUnit
53 :			#define LFT CblasLeft
54 :			#define RGT CblasRight
55 :
56 :	maechler	2120	#if !defined(R_VERSION) || R_VERSION < R_Version(2, 7, 0)
57 :	maechler	2117	char La_norm_type(const char *typstr);
58 :	maechler	2120	char La_rcond_type(const char *typstr);
59 :			#endif
60 :
61 :	bates	10	double get_double_by_name(SEXP obj, char *nm);
62 :			SEXP set_double_by_name(SEXP obj, double val, char *nm);
63 :			SEXP as_det_obj(double val, int log, int sign);
64 :	bates	476	SEXP get_factors(SEXP obj, char *nm);
65 :			SEXP set_factors(SEXP obj, SEXP val, char *nm);
66 :	maechler	2115
67 :			#if 0
68 :	bates	478	SEXP dgCMatrix_set_Dim(SEXP x, int nrow);
69 :	maechler	2115	#endif /* unused */
70 :	maechler	943
71 :	bates	1555	/* int csc_unsorted_columns(int ncol, const int p[], const int i[]); */
72 :			/* void csc_sort_columns(int ncol, const int p[], int i[], double x[]); */
73 :			/* SEXP csc_check_column_sorting(SEXP A); */
74 :	mmaechler	2449	#if R_VERSION < R_Version(2, 10, 0)
75 :	mmaechler	2348	SEXP Matrix_make_named(int TYP, const char **names);
76 :	mmaechler	2449	#else
77 :			# define Matrix_make_named Rf_mkNamed
78 :			#endif
79 :
80 :	bates	592	SEXP check_scalar_string(SEXP sP, char *vals, char *nm);
81 :	maechler	2113	Rboolean equal_string_vectors(SEXP s1, SEXP s2);
82 :
83 :	maechler	1747	void d_packed_getDiag(double *dest, SEXP x, int n);
84 :			void l_packed_getDiag( int *dest, SEXP x, int n);
85 :			void tr_d_packed_getDiag(double *dest, SEXP x);
86 :			void tr_l_packed_getDiag( int *dest, SEXP x);
87 :
88 :	bates	862	SEXP Matrix_getElement(SEXP list, char *nm);
89 :	bates	592
90 :	maechler	952	#define PACKED_TO_FULL(TYPE) \
91 :			TYPE *packed_to_full_ ## TYPE(TYPE *dest, const TYPE *src, \
92 :			int n, enum CBLAS_UPLO uplo)
93 :			PACKED_TO_FULL(double);
94 :			PACKED_TO_FULL(int);
95 :			#undef PACKED_TO_FULL
96 :	bates	738
97 :	maechler	952	#define FULL_TO_PACKED(TYPE) \
98 :			TYPE *full_to_packed_ ## TYPE(TYPE *dest, const TYPE *src, int n, \
99 :			enum CBLAS_UPLO uplo, enum CBLAS_DIAG diag)
100 :			FULL_TO_PACKED(double);
101 :			FULL_TO_PACKED(int);
102 :			#undef FULL_TO_PACKED
103 :
104 :
105 :	bates	592	extern /* stored pointers to symbols initialized in R_init_Matrix */
106 :	bates	329	#include "Syms.h"
107 :	bates	10
108 :	bates	432	/* zero an array */
109 :	bates	441	#define AZERO(x, n) {int _I_, _SZ_ = (n); for(_I_ = 0; _I_ < _SZ_; _I_++) (x)[_I_] = 0;}
110 :	bates	432
111 :	bates	597	/* number of elements in one triangle of a square matrix of order n */
112 :			#define PACKED_LENGTH(n) ((n) * ((n) + 1))/2
113 :
114 :	bates	738	/* duplicate the slot with name given by sym from src to dest */
115 :	maechler	2120
116 :	bates	738	#define slot_dup(dest, src, sym) SET_SLOT(dest, sym, duplicate(GET_SLOT(src, sym)))
117 :
118 :	maechler	2120	/* is not yet used: */
119 :	maechler	1736	#define slot_nonNull_dup(dest, src, sym) \
120 :			if(GET_SLOT(src, sym) != R_NilValue) \
121 :			SET_SLOT(dest, sym, duplicate(GET_SLOT(src, sym)))
122 :
123 :			/* TODO: Make this faster for the case where dimnames = list(NULL,NULL)
124 :			* and hence don't have to be set ! */
125 :			#define SET_DimNames(dest, src) slot_dup(dest, src, Matrix_DimNamesSym)
126 :
127 :
128 :	maechler	951	#define uplo_P(_x_) CHAR(STRING_ELT(GET_SLOT(_x_, Matrix_uploSym), 0))
129 :			#define diag_P(_x_) CHAR(STRING_ELT(GET_SLOT(_x_, Matrix_diagSym), 0))
130 :	bates	1461	#define class_P(_x_) CHAR(asChar(getAttrib(_x_, R_ClassSymbol)))
131 :	maechler	951
132 :	maechler	1725	/* should also work for "matrix" matrices: */
133 :			#define Real_KIND(_x_) (IS_S4_OBJECT(_x_) ? Real_kind(_x_) : \
134 :			(isReal(_x_) ? 0 : (isLogical(_x_) ? 1 : -1)))
135 :	maechler	2115	/* This one gives '0' also for integer "matrix" :*/
136 :			#define Real_KIND2(_x_) (IS_S4_OBJECT(_x_) ? Real_kind(_x_) : \
137 :			(isLogical(_x_) ? 1 : 0))
138 :	maechler	1725
139 :			/* requires 'x' slot: */
140 :	maechler	1548	#define Real_kind(_x_) (isReal(GET_SLOT(_x_, Matrix_xSym)) ? 0 : \
141 :	maechler	1725	(isLogical(GET_SLOT(_x_, Matrix_xSym)) ? 1 : -1))
142 :	maechler	1548
143 :	maechler	2115	#define DECLARE_AND_GET_X_SLOT(__C_TYPE, __SEXP) \
144 :			__C_TYPE *xx = __SEXP(GET_SLOT(x, Matrix_xSym))
145 :	maechler	1548
146 :	maechler	2115
147 :	maechler	890	/**
148 :	bates	597	* Check for valid length of a packed triangular array and return the
149 :			* corresponding number of columns
150 :	maechler	890	*
151 :	bates	597	* @param len length of a packed triangular array
152 :	maechler	890	*
153 :	bates	597	* @return number of columns
154 :			*/
155 :			static R_INLINE
156 :	maechler	890	int packed_ncol(int len)
157 :	bates	597	{
158 :			int disc = 8 * len + 1; /* discriminant */
159 :			int sqrtd = (int) sqrt((double) disc);
160 :
161 :			if (len < 0 || disc != sqrtd * sqrtd)
162 :			error(_("invalid 'len' = %d in packed_ncol"));
163 :			return (sqrtd - 1)/2;
164 :			}
165 :
166 :	maechler	890	/**
167 :	bates	536	* Allocate an SEXP of given type and length, assign it as slot nm in
168 :			* the object, and return the SEXP. The validity of this function
169 :			* depends on SET_SLOT not duplicating val when NAMED(val) == 0. If
170 :			* this behavior changes then ALLOC_SLOT must use SET_SLOT followed by
171 :			* GET_SLOT to ensure that the value returned is indeed the SEXP in
172 :			* the slot.
173 :	maechler	1747	* NOTE: GET_SLOT(x, what) :== R_do_slot (x, what)
174 :			* ---- SET_SLOT(x, what, value) :== R_do_slot_assign(x, what, value)
175 :			* and the R_do_slot* are in src/main/attrib.c
176 :	maechler	890	*
177 :	bates	536	* @param obj object in which to assign the slot
178 :			* @param nm name of the slot, as an R name object
179 :			* @param type type of SEXP to allocate
180 :			* @param length length of SEXP to allocate
181 :	maechler	890	*
182 :	bates	536	* @return SEXP of given type and length assigned as slot nm in obj
183 :			*/
184 :			static R_INLINE
185 :			SEXP ALLOC_SLOT(SEXP obj, SEXP nm, SEXPTYPE type, int length)
186 :			{
187 :			SEXP val = allocVector(type, length);
188 :	bates	441
189 :	bates	536	SET_SLOT(obj, nm, val);
190 :			return val;
191 :			}
192 :
193 :	maechler	890	/**
194 :	bates	679	* Expand compressed pointers in the array mp into a full set of indices
195 :	bates	536	* in the array mj.
196 :	maechler	890	*
197 :	bates	679	* @param ncol number of columns (or rows)
198 :	bates	536	* @param mp column pointer vector of length ncol + 1
199 :	bates	679	* @param mj vector of length mp[ncol] to hold the result
200 :	maechler	890	*
201 :	bates	536	* @return mj
202 :			*/
203 :			static R_INLINE
204 :	bates	679	int* expand_cmprPt(int ncol, const int mp[], int mj[])
205 :	bates	536	{
206 :			int j;
207 :			for (j = 0; j < ncol; j++) {
208 :			int j2 = mp[j+1], jj;
209 :			for (jj = mp[j]; jj < j2; jj++) mj[jj] = j;
210 :			}
211 :			return mj;
212 :			}
213 :
214 :	mmaechler	2175	/**
215 :	dmbates	2260	* Check if slot(obj, "x") contains any NA (or NaN).
216 :	mmaechler	2175	*
217 :			* @param obj a 'Matrix' object with an 'x' slot.
218 :			*
219 :	dmbates	2260	* @return Rboolean :== any(is.na(slot(obj, "x") )
220 :	mmaechler	2175	*/
221 :			static R_INLINE
222 :	mmaechler	2453	Rboolean any_NA_in_x(SEXP obj)
223 :	mmaechler	2175	{
224 :			double *x = REAL(GET_SLOT(obj, Matrix_xSym));
225 :			int i, n = LENGTH(GET_SLOT(obj, Matrix_xSym));
226 :			for(i=0; i < n; i++)
227 :			if(ISNAN(x[i])) return TRUE;
228 :			/* else */
229 :			return FALSE;
230 :			}
231 :
232 :
233 :	maechler	1200	void make_d_matrix_triangular(double *x, SEXP from);
234 :			void make_i_matrix_triangular( int *x, SEXP from);
235 :	bates	582
236 :	maechler	1200	void make_d_matrix_symmetric(double *to, SEXP from);
237 :			void make_i_matrix_symmetric( int *to, SEXP from);
238 :
239 :	bates	738	SEXP Matrix_expand_pointers(SEXP pP);
240 :
241 :	maechler	1432	SEXP dup_mMatrix_as_dgeMatrix(SEXP A);
242 :	maechler	1725	SEXP dup_mMatrix_as_geMatrix (SEXP A);
243 :	bates	1395
244 :	maechler	1654	SEXP new_dgeMatrix(int nrow, int ncol);
245 :	mmaechler	2525	SEXP m_encodeInd (SEXP ij, SEXP di, SEXP chk_bnds);
246 :			SEXP m_encodeInd2(SEXP i, SEXP j, SEXP di, SEXP chk_bnds);
247 :	maechler	1654
248 :	mmaechler	2203
249 :	bates	1461	static R_INLINE SEXP
250 :			mMatrix_as_dgeMatrix(SEXP A)
251 :			{
252 :	bates	1463	return strcmp(class_P(A), "dgeMatrix") ? dup_mMatrix_as_dgeMatrix(A) : A;
253 :	bates	1461	}
254 :	bates	1416
255 :	maechler	1725	static R_INLINE SEXP
256 :			mMatrix_as_geMatrix(SEXP A)
257 :			{
258 :			return strcmp(class_P(A) + 1, "geMatrix") ? dup_mMatrix_as_geMatrix(A) : A;
259 :			}
260 :
261 :	bates	1416	/**
262 :			* Return the 0-based index of a string match in a vector of strings
263 :			* terminated by an empty string. Returns -1 for no match.
264 :			*
265 :	bates	2104	* @param class string to match
266 :	bates	1416	* @param valid vector of possible matches terminated by an empty string
267 :			*
268 :			* @return index of match or -1 for no match
269 :			*/
270 :			static R_INLINE int
271 :	bates	1867	Matrix_check_class(const char *class, char **valid)
272 :	bates	1416	{
273 :			int ans;
274 :			for (ans = 0; ; ans++) {
275 :			if (!strlen(valid[ans])) return -1;
276 :			if (!strcmp(class, valid[ans])) return ans;
277 :			}
278 :			}
279 :
280 :	mmaechler	2364	int Matrix_check_class_etc(SEXP x, char **valid);
281 :			int Matrix_check_class_and_super(SEXP x, char **valid, SEXP rho);
282 :	mmaechler	2203
283 :	bates	582	#ifdef __cplusplus
284 :			}
285 :	bates	572	#endif
286 :	bates	582
287 :			#endif /* MATRIX_MUTILS_H_ */

---

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