1 using namespace std;
2
3 #include "tntsupp.h"
4 #include "geese.h"
5
6 #include <R.h>
7 #include <Rmath.h>
8 #include <Rdefines.h>
9
10 #include "famstr.h"
11 #include "param.h"
12 #include "inter.h"
13
14
asDMatrix(SEXP a)15 DMatrix asDMatrix(SEXP a) {
16 double *x;
17 x = NUMERIC_POINTER(AS_NUMERIC(a));
18 int *dims = INTEGER_POINTER(AS_INTEGER(GET_DIM(a)));
19 DMatrix ans(dims[0], dims[1], x);
20 return ans;
21 }
22
asDVector(SEXP a)23 DVector asDVector(SEXP a) {
24 double *x;
25 x = NUMERIC_POINTER(AS_NUMERIC(a));
26 int len = GET_LENGTH(a);
27 DVector ans(len, x);
28 return ans;
29 }
30
asIVector(SEXP a)31 IVector asIVector(SEXP a) {
32 int *x;
33 x = INTEGER_POINTER(AS_INTEGER(a));
34 int len = GET_LENGTH(a);
35 IVector ans(len, x);
36 return ans;
37 }
38
asVDVector(SEXP a)39 Vector<DVector> asVDVector(SEXP a) {//a is a matrix
40 double *x;
41 x = NUMERIC_POINTER(AS_NUMERIC(a));
42 int *dims = INTEGER_POINTER(AS_INTEGER(GET_DIM(a)));
43 Vector<DVector> ans(dims[1]);
44 for (int i = 1; i <= ans.size(); i++) {
45 DVector tmp(dims[0], x);
46 ans(i) = tmp;
47 x += dims[0];
48 }
49 return ans;
50 }
51
asSEXP(const DMatrix & a)52 SEXP asSEXP(const DMatrix &a) {
53 int size = a.num_cols() * a.num_rows();
54
55 SEXP val;
56 PROTECT(val = NEW_NUMERIC(size));
57 double *p = NUMERIC_POINTER(val);
58 const double *q = a.begin();
59 for (int i = 0; i < size; i++) p[i] = q[i];
60 // SET_CLASS(val, ScalarString(mkChar("matrix")));
61
62 SEXP dim;
63 PROTECT(dim = NEW_INTEGER(2));
64 INTEGER(dim)[0] = a.num_rows(); INTEGER(dim)[1] = a.num_cols();
65 SET_DIM(val, dim);
66
67 UNPROTECT(2);
68 return val;
69 }
70
asSEXP(const DVector & a)71 SEXP asSEXP(const DVector &a) {
72 int size = a.size();
73 SEXP val;
74 PROTECT(val = NEW_NUMERIC(size));
75 double *p = NUMERIC_POINTER(val);
76 const double *q = a.begin();
77 for (int i = 0; i < size; i++) p[i] = q[i];
78 // SET_CLASS(val, ScalarString(mkChar("vector")));
79
80 SEXP len;
81 PROTECT(len = NEW_INTEGER(1));
82 INTEGER(len)[0] = size;
83 SET_LENGTH(val, size);
84 UNPROTECT(2);
85 return val;
86 }
87
asSEXP(const IVector & a)88 SEXP asSEXP(const IVector &a) {
89 int size = a.size();
90 SEXP val;
91 PROTECT(val = NEW_INTEGER(size));
92 int *p = INTEGER_POINTER(val);
93 const int *q = a.begin();
94 for (int i = 0; i < size; i++) p[i] = q[i];
95 // SET_CLASS(val, ScalarString(mkChar("vector")));
96
97 SEXP len;
98 PROTECT(len = NEW_INTEGER(1));
99 INTEGER(len)[0] = size;
100 SET_LENGTH(val, size);
101 UNPROTECT(2);
102 return val;
103 }
104
105
asControl(SEXP con)106 Control asControl(SEXP con) {
107 //con is a list of trace, jack, j1s, fij, maxiter, epsilon
108 int trace, jack, j1s, fij, maxiter;
109 double tol;
110 trace = INTEGER(VECTOR_ELT(con, 0))[0];
111 jack = INTEGER(VECTOR_ELT(con, 1))[0];
112 j1s = INTEGER(VECTOR_ELT(con, 2))[0];
113 fij = INTEGER(VECTOR_ELT(con, 3))[0];
114 maxiter = INTEGER(VECTOR_ELT(con, 4))[0];
115 tol = REAL(VECTOR_ELT(con, 5))[0];
116 Control Con(trace, jack, j1s, fij, maxiter, tol);
117 return Con;
118 }
119
asGeeParam(SEXP par)120 GeeParam asGeeParam(SEXP par) {
121 //par is a list of beta, alpha, gamma;
122 DVector Beta = asDVector(VECTOR_ELT(par, 0));
123 DVector Alpha = asDVector(VECTOR_ELT(par, 1));
124 DVector Gamma = asDVector(VECTOR_ELT(par, 2));
125 GeeParam Par(Beta, Alpha, Gamma);
126 return Par;
127 }
128
asGeeStr(SEXP geestr)129 GeeStr asGeeStr(SEXP geestr) {
130 //geestr is a list of maxwave, meanlink, v, scalelink, corrlink, scale.fix;
131 int maxwave = INTEGER(AS_INTEGER(VECTOR_ELT(geestr, 0)))[0];
132 IVector MeanLink, V, ScaleLink;
133
134 // FIXME: rchk gives warning here ...
135 //MeanLink = asIVector(AS_INTEGER(VECTOR_ELT(geestr, 1)));
136 //V = asIVector(AS_INTEGER(VECTOR_ELT(geestr, 2)));
137 //ScaleLink = asIVector(AS_INTEGER(VECTOR_ELT(geestr, 3)));
138 // and to here
139
140 // Attempted fix
141 SEXP ML, VV, SL;
142 PROTECT(ML = AS_INTEGER(VECTOR_ELT(geestr, 1)));
143 PROTECT(VV = AS_INTEGER(VECTOR_ELT(geestr, 2)));
144 PROTECT(SL = AS_INTEGER(VECTOR_ELT(geestr, 3)));
145 MeanLink = asIVector(ML);
146 V = asIVector(VV);
147 ScaleLink = asIVector(SL);
148 // to here
149
150 int corrlink = INTEGER(AS_INTEGER(VECTOR_ELT(geestr, 4)))[0];
151 int scalefix = INTEGER(AS_INTEGER(VECTOR_ELT(geestr, 5)))[0];
152 GeeStr G(maxwave, MeanLink, V, ScaleLink, corrlink, scalefix);
153 UNPROTECT(3);
154
155 return G;
156 }
157
158
159
160
161 // GeeStr asGeeStr(SEXP geestr) {
162 // //geestr is a list of maxwave, meanlink, v, scalelink, corrlink, scale.fix;
163 // int maxwave = INTEGER(AS_INTEGER(VECTOR_ELT(geestr, 0)))[0];
164 // IVector MeanLink = asIVector(AS_INTEGER(VECTOR_ELT(geestr, 1)));
165 // IVector V = asIVector(AS_INTEGER(VECTOR_ELT(geestr, 2)));
166 // IVector ScaleLink = asIVector(AS_INTEGER(VECTOR_ELT(geestr, 3)));
167 // int corrlink = INTEGER(AS_INTEGER(VECTOR_ELT(geestr, 4)))[0];
168 // int scalefix = INTEGER(AS_INTEGER(VECTOR_ELT(geestr, 5)))[0];
169 // GeeStr G(maxwave, MeanLink, V, ScaleLink, corrlink, scalefix);
170 // return G;
171 // }
172
asCorr(SEXP cor)173 Corr asCorr(SEXP cor) {
174 //cor is a list of corst, maxwave
175 int corstr, maxwave;
176 corstr = INTEGER(VECTOR_ELT(cor, 0))[0];
177 maxwave = INTEGER(VECTOR_ELT(cor, 1))[0];
178 Corr Cor(corstr, maxwave);
179 return Cor;
180 }
181
asSEXP(GeeParam & Par)182 SEXP asSEXP(GeeParam &Par) {
183 SEXP ans;
184 PROTECT(ans = NEW_LIST(19));
185 SET_VECTOR_ELT(ans, 0, asSEXP(Par.beta()));
186 SET_VECTOR_ELT(ans, 1, asSEXP(Par.alpha()));
187 SET_VECTOR_ELT(ans, 2, asSEXP(Par.gamma()));
188 SET_VECTOR_ELT(ans, 3, asSEXP(Par.vbeta()));
189 SET_VECTOR_ELT(ans, 4, asSEXP(Par.valpha()));
190 SET_VECTOR_ELT(ans, 5, asSEXP(Par.vgamma()));
191 SET_VECTOR_ELT(ans, 6, asSEXP(Par.vbeta_naiv()));
192 SET_VECTOR_ELT(ans, 7, asSEXP(Par.valpha_naiv()));
193 SET_VECTOR_ELT(ans, 8, asSEXP(Par.valpha_stab()));
194 SET_VECTOR_ELT(ans, 9, asSEXP(Par.vbeta_ajs()));
195 SET_VECTOR_ELT(ans, 10, asSEXP(Par.valpha_ajs()));
196 SET_VECTOR_ELT(ans, 11, asSEXP(Par.vgamma_ajs()));
197 SET_VECTOR_ELT(ans, 12, asSEXP(Par.vbeta_j1s()));
198 SET_VECTOR_ELT(ans, 13, asSEXP(Par.valpha_j1s()));
199 SET_VECTOR_ELT(ans, 14, asSEXP(Par.vgamma_j1s()));
200 SET_VECTOR_ELT(ans, 15, asSEXP(Par.vbeta_fij()));
201 SET_VECTOR_ELT(ans, 16, asSEXP(Par.valpha_fij()));
202 SET_VECTOR_ELT(ans, 17, asSEXP(Par.vgamma_fij()));
203
204 IVector Err(1); Err(1) = Par.err();
205 SET_VECTOR_ELT(ans, 18, asSEXP(Err));
206 UNPROTECT(1);
207 return ans;
208 }
209