SCM

SCM Repository

[matrix] Annotation of /pkg/src/geMutils.c
ViewVC logotype

Annotation of /pkg/src/geMutils.c

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : bates 10 #include "geMutils.h"
2 :    
3 :     char norm_type(char *typstr)
4 :     {
5 :     char typup;
6 :    
7 :     if (strlen(typstr) != 1)
8 :     error("argument type[1]='%s' must be a character string of string length 1",
9 :     typstr);
10 :     typup = toupper(*typstr);
11 :     if (typup == '1') typup = 'O'; /* aliases */
12 :     if (typup == 'E') typup = 'F';
13 :     if (typup != 'M' && typup != 'O' && typup != 'I' && typup != 'F')
14 :     error("argument type[1]='%s' must be one of 'M','1','O','I','F' or 'E'",
15 :     typstr);
16 :     return typup;
17 :     }
18 :    
19 :     char rcond_type(char *typstr)
20 :     {
21 :     char typup;
22 :    
23 :     if (strlen(typstr) != 1)
24 :     error("argument type[1]='%s' must be a character string of string length 1",
25 :     typstr);
26 :     typup = toupper(*typstr);
27 :     if (typup == '1') typup = 'O'; /* alias */
28 :     if (typup != 'O' && typup != 'I')
29 :     error("argument type[1]='%s' must be one of '1','O', or 'I'",
30 :     typstr);
31 :     return typup;
32 :     }
33 :    
34 :     double get_double_by_name(SEXP obj, char *nm)
35 :     {
36 :     SEXP nms = getAttrib(obj, R_NamesSymbol);
37 :     int i, len = length(obj);
38 :    
39 :     if ((!isReal(obj)) || (length(obj) > 0 && nms == R_NilValue))
40 :     error("object must be a named, numeric vector");
41 :     for (i = 0; i < len; i++) {
42 :     if (!strcmp(nm, CHAR(STRING_ELT(nms, i)))) {
43 :     return REAL(obj)[i];
44 :     }
45 :     }
46 :     return R_NaReal;
47 :     }
48 :    
49 :     SEXP
50 :     set_double_by_name(SEXP obj, double val, char *nm)
51 :     {
52 :     SEXP nms = getAttrib(obj, R_NamesSymbol);
53 :     int i, len = length(obj);
54 :    
55 :     if ((!isReal(obj)) || (length(obj) > 0 && nms == R_NilValue))
56 :     error("object must be a named, numeric vector");
57 :     for (i = 0; i < len; i++) {
58 :     if (!strcmp(nm, CHAR(STRING_ELT(nms, i)))) {
59 :     REAL(obj)[i] = val;
60 :     return obj;
61 :     }
62 :     }
63 :     {SEXP nx = PROTECT(allocVector(REALSXP, len + 1)),
64 :     nnms = allocVector(STRSXP, len + 1);
65 :    
66 :     setAttrib(nx, R_NamesSymbol, nnms);
67 :     for (i = 0; i < len; i++) {
68 :     REAL(nx)[i] = REAL(obj)[i];
69 :     SET_STRING_ELT(nnms, i, duplicate(STRING_ELT(nms, i)));
70 :     }
71 :     REAL(nx)[len] = val;
72 :     SET_STRING_ELT(nnms, len, mkChar(nm));
73 :     UNPROTECT(1);
74 :     return nx;
75 :     }
76 :     }
77 :    
78 :     SEXP as_det_obj(double val, int log, int sign)
79 :     {
80 :     SEXP det = PROTECT(allocVector(VECSXP, 2)),
81 :     nms = allocVector(STRSXP, 2),
82 :     vv = ScalarReal(val);
83 :    
84 :     setAttrib(det, R_NamesSymbol, nms);
85 :     SET_STRING_ELT(nms, 0, mkChar("modulus"));
86 :     SET_STRING_ELT(nms, 1, mkChar("sign"));
87 :     setAttrib(vv, install("logarithm"), ScalarLogical(log));
88 :     SET_VECTOR_ELT(det, 0, vv);
89 :     SET_VECTOR_ELT(det, 1, ScalarInteger(sign));
90 :     setAttrib(det, R_ClassSymbol, ScalarString(mkChar("det")));
91 :     UNPROTECT(1);
92 :     return det;
93 :     }
94 :    
95 :     SEXP get_factorization(SEXP obj, char *nm)
96 :     {
97 :     SEXP fac = GET_SLOT(obj, install("factorization")),
98 :     nms = getAttrib(fac, R_NamesSymbol);
99 :     int i, len = length(fac);
100 :    
101 :     if ((!isNewList(fac)) || (length(fac) > 0 && nms == R_NilValue))
102 :     error("factorization slot must be a named list");
103 :     for (i = 0; i < len; i++) {
104 :     if (!strcmp(nm, CHAR(STRING_ELT(nms, i)))) {
105 :     return VECTOR_ELT(fac, i);
106 :     }
107 :     }
108 :     return R_NilValue;
109 :     }
110 :    
111 :     SEXP set_factorization(SEXP obj, SEXP val, char *nm)
112 :     {
113 :     SEXP fac = GET_SLOT(obj, install("factorization")),
114 :     nms = getAttrib(fac, R_NamesSymbol), nfac, nnms;
115 :     int i, len = length(fac);
116 :    
117 :     if ((!isNewList(fac)) || (length(fac) > 0 && nms == R_NilValue))
118 :     error("factorization slot must be a named list");
119 :     for (i = 0; i < len; i++) {
120 :     if (!strcmp(nm, CHAR(STRING_ELT(nms, i)))) {
121 :     SET_VECTOR_ELT(fac, i, val);
122 :     return val;
123 :     }
124 :     }
125 :     nfac = allocVector(VECSXP, len + 1);
126 :     nnms = allocVector(STRSXP, len + 1);
127 :     setAttrib(nfac, R_NamesSymbol, nnms);
128 :     for (i = 0; i < len; i++) {
129 :     SET_VECTOR_ELT(nfac, i, VECTOR_ELT(fac, i));
130 :     SET_STRING_ELT(nnms, i, duplicate(STRING_ELT(nms, i)));
131 :     }
132 :     SET_VECTOR_ELT(nfac, len, val);
133 :     SET_STRING_ELT(nnms, len, mkChar(nm));
134 :     SET_SLOT(obj, install("factorization"), nfac);
135 :     return val;
136 :     }
137 :    
138 :     SEXP Matrix_init(void)
139 :     {
140 :     Matrix_DimSym = install("Dim");
141 :     Matrix_diagSym = install("diag");
142 :     Matrix_iSym = install("i");
143 :     Matrix_pSym = install("p");
144 :     Matrix_uploSym = install("uplo");
145 :     Matrix_xSym = install("x");
146 :     Matrix_zSym = install("z");
147 :     return R_NilValue;
148 :     }
149 :    
150 :     SEXP cscMatrix_set_Dim(SEXP x, int nrow)
151 :     {
152 :     int *dims = INTEGER(GET_SLOT(x, Matrix_DimSym));
153 :    
154 :     dims[0] = nrow;
155 :     dims[1] = length(GET_SLOT(x, Matrix_pSym)) - 1;
156 :     return x;
157 :     }

root@r-forge.r-project.org
ViewVC Help
Powered by ViewVC 1.0.0  
Thanks to:
Vienna University of Economics and Business Powered By FusionForge