00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021
00022 #include "Rcpp.h"
00023
00024 RcppParams::RcppParams(SEXP params) {
00025 if (!Rf_isNewList(params))
00026 throw std::range_error("RcppParams: non-list passed to constructor");
00027 int len = Rf_length(params);
00028 SEXP names = Rf_getAttrib(params, R_NamesSymbol);
00029 if (names == R_NilValue)
00030 throw std::range_error("RcppParams: list must have named elements");
00031 for (int i = 0; i < len; i++) {
00032 std::string nm = std::string(CHAR(STRING_ELT(names,i)));
00033 if (nm.size() == 0)
00034 throw std::range_error("RcppParams: all list elements must be named");
00035 pmap[nm] = i;
00036 }
00037 _params = params;
00038 }
00039
00040 void RcppParams::checkNames(char *inputNames[], int len) {
00041 for (int i = 0; i < len; i++) {
00042 std::map<std::string,int>::iterator iter = pmap.find(inputNames[i]);
00043 if (iter == pmap.end()) {
00044 std::string mesg = "RcppParams::checkNames: missing required parameter ";
00045 throw std::range_error(mesg+inputNames[i]);
00046 }
00047 }
00048 }
00049
00050 bool RcppParams::exists(std::string name) {
00051 bool rc = true;
00052 std::map<std::string,int>::iterator iter = pmap.find(name);
00053 if (iter == pmap.end()) {
00054 rc = false;
00055 }
00056 return rc;
00057 }
00058
00059 RcppFrame::RcppFrame(SEXP df) {
00060 if (!Rf_isNewList(df))
00061 throw std::range_error("RcppFrame::RcppFrame: invalid data frame.");
00062 int ncol = Rf_length(df);
00063 SEXP names = Rf_getAttrib(df, R_NamesSymbol);
00064 colNames.resize(ncol);
00065 SEXP colData = VECTOR_ELT(df,0);
00066 int nrow = Rf_length(colData);
00067 if (nrow == 0)
00068 throw std::range_error("RcppFrame::RcppFrame: zero lenth column.");
00069
00070
00071 table.resize(nrow);
00072 for (int r = 0; r < nrow; r++)
00073 table[r].resize(ncol);
00074
00075 for (int i=0; i < ncol; i++) {
00076 colNames[i] = std::string(CHAR(STRING_ELT(names,i)));
00077 SEXP colData = VECTOR_ELT(df,i);
00078 if (!Rf_isVector(colData) || Rf_length(colData) != nrow)
00079 throw std::range_error("RcppFrame::RcppFrame: invalid column.");
00080
00081
00082
00083
00084 bool isDateClass = false;
00085 SEXP classname = Rf_getAttrib(colData, R_ClassSymbol);
00086 if (classname != R_NilValue)
00087 isDateClass = (strcmp(CHAR(STRING_ELT(classname,0)),"Date") == 0);
00088
00089 if (Rf_isReal(colData)) {
00090 if (isDateClass) {
00091 for (int j=0; j < nrow; j++)
00092 table[j][i].setDateValue(RcppDate((int)REAL(colData)[j]));
00093 }
00094 else
00095 for (int j=0; j < nrow; j++)
00096 table[j][i].setDoubleValue(REAL(colData)[j]);
00097 }
00098 else if (Rf_isInteger(colData)) {
00099 if (isDateClass) {
00100 for (int j=0; j < nrow; j++)
00101 table[j][i].setDateValue(RcppDate(INTEGER(colData)[j]));
00102 }
00103 else
00104 for (int j=0; j < nrow; j++)
00105 table[j][i].setIntValue(INTEGER(colData)[j]);
00106 }
00107 else if (Rf_isString(colData)) {
00108 for (int j=0; j < nrow; j++)
00109 table[j][i].setStringValue(std::string(CHAR(STRING_ELT(colData,j))));
00110 }
00111 else if (Rf_isFactor(colData)) {
00112 SEXP names = Rf_getAttrib(colData, R_LevelsSymbol);
00113 int numLevels = Rf_length(names);
00114 std::string *levelNames = new std::string[numLevels];
00115 for (int k=0; k < numLevels; k++)
00116 levelNames[k] = std::string(CHAR(STRING_ELT(names,k)));
00117 for (int j=0; j < nrow; j++)
00118 table[j][i].setFactorValue(levelNames, numLevels,
00119 INTEGER(colData)[j]);
00120 delete [] levelNames;
00121 }
00122 else if (Rf_isLogical(colData)) {
00123 for (int j=0; j < nrow; j++) {
00124 table[j][i].setLogicalValue(INTEGER(colData)[j]);
00125 }
00126 }
00127 else
00128 throw std::range_error("RcppFrame::RcppFrame: unsupported data frame column type.");
00129 }
00130 }
00131
00132 double RcppParams::getDoubleValue(std::string name) {
00133 std::map<std::string,int>::iterator iter = pmap.find(name);
00134 if (iter == pmap.end()) {
00135 std::string mesg = "RcppParams::getDoubleValue: no such name: ";
00136 throw std::range_error(mesg+name);
00137 }
00138 int posn = iter->second;
00139 SEXP elt = VECTOR_ELT(_params,posn);
00140 if (!Rf_isNumeric(elt) || Rf_length(elt) != 1) {
00141 std::string mesg = "RcppParams::getDoubleValue: must be scalar ";
00142 throw std::range_error(mesg+name);
00143 }
00144 if (Rf_isInteger(elt))
00145 return (double)INTEGER(elt)[0];
00146 else if (Rf_isReal(elt))
00147 return REAL(elt)[0];
00148 else {
00149 std::string mesg = "RcppParams::getDoubleValue: invalid value for ";
00150 throw std::range_error(mesg+name);
00151 }
00152 return 0;
00153 }
00154
00155 int RcppParams::getIntValue(std::string name) {
00156 std::map<std::string,int>::iterator iter = pmap.find(name);
00157 if (iter == pmap.end()) {
00158 std::string mesg = "RcppParams::getIntValue: no such name: ";
00159 throw std::range_error(mesg+name);
00160 }
00161 int posn = iter->second;
00162 SEXP elt = VECTOR_ELT(_params,posn);
00163 if (!Rf_isNumeric(elt) || Rf_length(elt) != 1) {
00164 std::string mesg = "RcppParams::getIntValue: must be scalar: ";
00165 throw std::range_error(mesg+name);
00166 }
00167 if (Rf_isInteger(elt))
00168 return INTEGER(elt)[0];
00169 else if (Rf_isReal(elt))
00170 return (int)REAL(elt)[0];
00171 else {
00172 std::string mesg = "RcppParams::getIntValue: invalid value for: ";
00173 throw std::range_error(mesg+name);
00174 }
00175 return 0;
00176 }
00177
00178 bool RcppParams::getBoolValue(std::string name) {
00179 std::map<std::string,int>::iterator iter = pmap.find(name);
00180 if (iter == pmap.end()) {
00181 std::string mesg = "RcppParams::getBoolValue: no such name: ";
00182 throw std::range_error(mesg+name);
00183 }
00184 int posn = iter->second;
00185 SEXP elt = VECTOR_ELT(_params,posn);
00186 if (Rf_isLogical(elt))
00187 return INTEGER(elt)[0];
00188 else {
00189 std::string mesg = "RcppParams::getBoolValue: invalid value for: ";
00190 throw std::range_error(mesg+name);
00191 }
00192 return false;
00193 }
00194
00195 std::string RcppParams::getStringValue(std::string name) {
00196 std::map<std::string,int>::iterator iter = pmap.find(name);
00197 if (iter == pmap.end()) {
00198 std::string mesg = "RcppParams::getStringValue: no such name: ";
00199 throw std::range_error(mesg+name);
00200 }
00201 int posn = iter->second;
00202 SEXP elt = VECTOR_ELT(_params,posn);
00203 if (Rf_isString(elt))
00204 return std::string(CHAR(STRING_ELT(elt,0)));
00205 else {
00206 std::string mesg = "RcppParams::getStringValue: invalid value for: ";
00207 throw std::range_error(mesg+name);
00208 }
00209 return "";
00210 }
00211
00212 RcppDate RcppParams::getDateValue(std::string name) {
00213 std::map<std::string,int>::iterator iter = pmap.find(name);
00214 if (iter == pmap.end()) {
00215 std::string mesg = "RcppParams::getDateValue: no such name: ";
00216 throw std::range_error(mesg+name);
00217 }
00218 int posn = iter->second;
00219 SEXP elt = VECTOR_ELT(_params,posn);
00220 if (!Rf_isNumeric(elt) || Rf_length(elt) != 1) {
00221 std::string mesg = "RcppParams::getDateValue: invalide date: ";
00222 throw std::range_error(mesg+name);
00223 }
00224
00225 int d;
00226 if (Rf_isReal(elt))
00227 d = (int)REAL(elt)[0];
00228 else {
00229 std::string mesg = "RcppParams::getDateValue: invalid value for: ";
00230 throw std::range_error(mesg+name);
00231 }
00232 return RcppDate(d);
00233 }
00234
00235 RcppDatetime RcppParams::getDatetimeValue(std::string name) {
00236 std::map<std::string,int>::iterator iter = pmap.find(name);
00237 if (iter == pmap.end()) {
00238 std::string mesg = "RcppParams::getDatetimeValue: no such name: ";
00239 throw std::range_error(mesg+name);
00240 }
00241 int posn = iter->second;
00242 SEXP elt = VECTOR_ELT(_params, posn);
00243 if (!Rf_isNumeric(elt) || Rf_length(elt) != 1) {
00244 std::string mesg = "RcppParams::getDateValue: invalide date: ";
00245 throw std::range_error(mesg+name);
00246 }
00247 double d;
00248 if (Rf_isReal(elt))
00249 d = REAL(elt)[0];
00250 else {
00251 std::string mesg = "RcppParams::getDatetimeValue: invalid value for: ";
00252 throw std::range_error(mesg+name);
00253 }
00254 return RcppDatetime(d);
00255 }
00256
00257 RcppDateVector::RcppDateVector(SEXP vec) {
00258 int i;
00259 if (!Rf_isNumeric(vec) || Rf_isMatrix(vec) || Rf_isLogical(vec))
00260 throw std::range_error("RcppDateVector: invalid numeric vector in constructor");
00261 int len = Rf_length(vec);
00262 if (len == 0)
00263 throw std::range_error("RcppDateVector: null vector in constructor");
00264 v = new RcppDate[len];
00265 for (i = 0; i < len; i++)
00266 v[i] = RcppDate((int)REAL(vec)[i]);
00267 length = len;
00268 }
00269
00270 RcppDatetimeVector::RcppDatetimeVector(SEXP vec) {
00271 int i;
00272 if (!Rf_isNumeric(vec) || Rf_isMatrix(vec) || Rf_isLogical(vec))
00273 throw std::range_error("RcppDatetimeVector: invalid numeric vector in constructor");
00274 int len = Rf_length(vec);
00275 if (len == 0)
00276 throw std::range_error("RcppDatetimeVector: null vector in constructor");
00277 v = new RcppDatetime[len];
00278 for (i = 0; i < len; i++)
00279 v[i] = RcppDatetime(REAL(vec)[i]);
00280 length = len;
00281 }
00282
00283 RcppStringVector::RcppStringVector(SEXP vec) {
00284 int i;
00285 if (Rf_isMatrix(vec) || Rf_isLogical(vec))
00286 throw std::range_error("RcppStringVector: invalid numeric vector in constructor");
00287 if (!Rf_isString(vec))
00288 throw std::range_error("RcppStringVector: invalid string");
00289 int len = Rf_length(vec);
00290 if (len == 0)
00291 throw std::range_error("RcppStringVector: null vector in constructor");
00292 v = new std::string[len];
00293 for (i = 0; i < len; i++)
00294 v[i] = std::string(CHAR(STRING_ELT(vec,i)));
00295 length = len;
00296 }
00297
00298 template <typename T>
00299 RcppVector<T>::RcppVector(SEXP vec) {
00300 int i;
00301
00302
00303
00304
00305
00306
00307
00308 if (!Rf_isNumeric(vec) || Rf_isMatrix(vec) || Rf_isLogical(vec))
00309 throw std::range_error("RcppVector: invalid numeric vector in constructor");
00310 len = Rf_length(vec);
00311 v = (T *)R_alloc(len, sizeof(T));
00312 if (Rf_isInteger(vec)) {
00313 for (i = 0; i < len; i++)
00314 v[i] = (T)(INTEGER(vec)[i]);
00315 }
00316 else if (Rf_isReal(vec)) {
00317 for (i = 0; i < len; i++)
00318 v[i] = (T)(REAL(vec)[i]);
00319 }
00320 }
00321
00322 template <typename T>
00323 RcppVector<T>::RcppVector(int _len) {
00324 len = _len;
00325 v = (T *)R_alloc(len, sizeof(T));
00326 for (int i = 0; i < len; i++)
00327 v[i] = 0;
00328 }
00329
00330 template <typename T>
00331 T *RcppVector<T>::cVector() {
00332 T* tmp = (T *)R_alloc(len, sizeof(T));
00333 for (int i = 0; i < len; i++)
00334 tmp[i] = v[i];
00335 return tmp;
00336 }
00337
00338 template <typename T>
00339 std::vector<T> RcppVector<T>::stlVector() {
00340 std::vector<T> tmp(len);
00341 for (int i = 0; i < len; i++)
00342 tmp[i] = v[i];
00343 return tmp;
00344 }
00345
00346 template <typename T>
00347 RcppMatrix<T>::RcppMatrix(SEXP mat) {
00348
00349 if (!Rf_isNumeric(mat) || !Rf_isMatrix(mat))
00350 throw std::range_error("RcppMatrix: invalid numeric matrix in constructor");
00351
00352
00353 SEXP dimAttr = Rf_getAttrib(mat, R_DimSymbol);
00354 dim1 = INTEGER(dimAttr)[0];
00355 dim2 = INTEGER(dimAttr)[1];
00356
00357
00358
00359 int i,j;
00360 int isInt = Rf_isInteger(mat);
00361 T *m = (T *)R_alloc(dim1*dim2, sizeof(T));
00362 a = (T **)R_alloc(dim1, sizeof(T *));
00363 for (i = 0; i < dim1; i++)
00364 a[i] = m + i*dim2;
00365 if (isInt) {
00366 for (i=0; i < dim1; i++)
00367 for (j=0; j < dim2; j++)
00368 a[i][j] = (T)(INTEGER(mat)[i+dim1*j]);
00369 }
00370 else {
00371 for (i=0; i < dim1; i++)
00372 for (j=0; j < dim2; j++)
00373 a[i][j] = (T)(REAL(mat)[i+dim1*j]);
00374 }
00375 }
00376
00377 template <typename T>
00378 RcppMatrix<T>::RcppMatrix(int _dim1, int _dim2) {
00379 dim1 = _dim1;
00380 dim2 = _dim2;
00381 int i,j;
00382 T *m = (T *)R_alloc(dim1*dim2, sizeof(T));
00383 a = (T **)R_alloc(dim1, sizeof(T *));
00384 for (i = 0; i < dim1; i++)
00385 a[i] = m + i*dim2;
00386 for (i=0; i < dim1; i++)
00387 for (j=0; j < dim2; j++)
00388 a[i][j] = 0;
00389 }
00390
00391 template <typename T>
00392 std::vector<std::vector<T> > RcppMatrix<T>::stlMatrix() {
00393 int i,j;
00394 std::vector<std::vector<T> > temp;
00395 for (i = 0; i < dim1; i++) {
00396 temp.push_back(std::vector<T>(dim2));
00397 }
00398 for (i = 0; i < dim1; i++)
00399 for (j = 0; j < dim2; j++)
00400 temp[i][j] = a[i][j];
00401 return temp;
00402 }
00403
00404 template <typename T>
00405 T **RcppMatrix<T>::cMatrix() {
00406 int i,j;
00407 T *m = (T *)R_alloc(dim1*dim2, sizeof(T));
00408 T **tmp = (T **)R_alloc(dim1, sizeof(T *));
00409 for (i = 0; i < dim1; i++)
00410 tmp[i] = m + i*dim2;
00411 for (i=0; i < dim1; i++)
00412 for (j=0; j < dim2; j++)
00413 tmp[i][j] = a[i][j];
00414 return tmp;
00415 }
00416
00417
00418 template class RcppVector<int>;
00419 template class RcppVector<double>;
00420 template class RcppMatrix<int>;
00421 template class RcppMatrix<double>;
00422
00423 template <typename T>
00424 RcppVectorView<T>::RcppVectorView(SEXP vec) {
00425 if (!Rf_isNumeric(vec) || Rf_isMatrix(vec) || Rf_isLogical(vec))
00426 throw std::range_error("RcppVectorView: invalid numeric vector in constructor");
00427 len = Rf_length(vec);
00428 if (Rf_isInteger(vec)) v = (T *)(INTEGER(vec));
00429 else if (Rf_isReal(vec)) v = (T *)(REAL(vec));
00430 }
00431
00432 template class RcppVectorView<int>;
00433 template class RcppVectorView<double>;
00434
00435 template <typename T>
00436 RcppMatrixView<T>::RcppMatrixView(SEXP mat) {
00437 if (!Rf_isNumeric(mat) || !Rf_isMatrix(mat))
00438 throw std::range_error("RcppMatrixView: invalid numeric matrix in constructor");
00439
00440 SEXP dimAttr = Rf_getAttrib(mat, R_DimSymbol);
00441 d1 = INTEGER(dimAttr)[0];
00442 d2 = INTEGER(dimAttr)[1];
00443 if (Rf_isInteger(mat)) a = (T *)(INTEGER(mat));
00444 else if (Rf_isReal(mat)) a = (T *)(REAL(mat));
00445 }
00446
00447 template class RcppMatrixView<int>;
00448 template class RcppMatrixView<double>;
00449
00450 RcppStringVectorView::RcppStringVectorView(SEXP vec) {
00451
00452 if (Rf_isMatrix(vec) || Rf_isLogical(vec))
00453 throw std::range_error("RcppStringVectorView: invalid numeric vector in constructor");
00454 if (!Rf_isString(vec))
00455 throw std::range_error("RcppStringVectorView: invalid string");
00456 int len = Rf_length(vec);
00457 if (len == 0)
00458 throw std::range_error("RcppStringVectorView: null vector in constructor");
00459
00460
00461
00462 length = len;
00463 v = vec;
00464 }
00465
00466
00467 void RcppResultSet::add(std::string name, RcppDate& date) {
00468 SEXP value = PROTECT(Rf_allocVector(REALSXP, 1));
00469 numProtected++;
00470 REAL(value)[0] = date.getJDN() - RcppDate::Jan1970Offset;
00471 SEXP dateclass = PROTECT(Rf_allocVector(STRSXP,1));
00472 numProtected++;
00473 SET_STRING_ELT(dateclass, 0, Rf_mkChar("Date"));
00474 Rf_setAttrib(value, R_ClassSymbol, dateclass);
00475 values.push_back(make_pair(name, value));
00476 }
00477
00478 void RcppResultSet::add(std::string name, RcppDatetime& datetime) {
00479 SEXP value = PROTECT(Rf_allocVector(REALSXP, 1));
00480 numProtected++;
00481 REAL(value)[0] = datetime.getFractionalTimestamp();
00482 SEXP datetimeclass = PROTECT(Rf_allocVector(STRSXP,2));
00483 numProtected++;
00484 SET_STRING_ELT(datetimeclass, 0, Rf_mkChar("POSIXt"));
00485 SET_STRING_ELT(datetimeclass, 1, Rf_mkChar("POSIXct"));
00486 Rf_setAttrib(value, R_ClassSymbol, datetimeclass);
00487 values.push_back(make_pair(name, value));
00488 }
00489
00490 void RcppResultSet::add(std::string name, double x) {
00491 SEXP value = PROTECT(Rf_allocVector(REALSXP, 1));
00492 numProtected++;
00493 REAL(value)[0] = x;
00494 values.push_back(make_pair(name, value));
00495 }
00496
00497 void RcppResultSet::add(std::string name, int i) {
00498 SEXP value = PROTECT(Rf_allocVector(INTSXP, 1));
00499 numProtected++;
00500 INTEGER(value)[0] = i;
00501 values.push_back(make_pair(name, value));
00502 }
00503
00504 void RcppResultSet::add(std::string name, std::string strvalue) {
00505 SEXP value = PROTECT(Rf_allocVector(STRSXP, 1));
00506 numProtected++;
00507 SET_STRING_ELT(value, 0, Rf_mkChar(strvalue.c_str()));
00508 values.push_back(make_pair(name, value));
00509 }
00510
00511 void RcppResultSet::add(std::string name, double *vec, int len) {
00512 if (vec == 0)
00513 throw std::range_error("RcppResultSet::add: NULL double vector");
00514 SEXP value = PROTECT(Rf_allocVector(REALSXP, len));
00515 numProtected++;
00516 for (int i = 0; i < len; i++)
00517 REAL(value)[i] = vec[i];
00518 values.push_back(make_pair(name, value));
00519 }
00520
00521 void RcppResultSet::add(std::string name, RcppDateVector& datevec) {
00522 SEXP value = PROTECT(Rf_allocVector(REALSXP, datevec.size()));
00523 numProtected++;
00524 for (int i = 0; i < datevec.size(); i++) {
00525 REAL(value)[i] = datevec(i).getJDN() - RcppDate::Jan1970Offset;
00526 }
00527 SEXP dateclass = PROTECT(Rf_allocVector(STRSXP,1));
00528 numProtected++;
00529 SET_STRING_ELT(dateclass, 0, Rf_mkChar("Date"));
00530 Rf_setAttrib(value, R_ClassSymbol, dateclass);
00531 values.push_back(make_pair(name, value));
00532 }
00533
00534 void RcppResultSet::add(std::string name, RcppDatetimeVector &dtvec) {
00535 SEXP value = PROTECT(Rf_allocVector(REALSXP, dtvec.size()));
00536 numProtected++;
00537 for (int i = 0; i < dtvec.size(); i++) {
00538 REAL(value)[i] = dtvec(i).getFractionalTimestamp();
00539 }
00540 SEXP datetimeclass = PROTECT(Rf_allocVector(STRSXP,2));
00541 numProtected++;
00542 SET_STRING_ELT(datetimeclass, 0, Rf_mkChar("POSIXt"));
00543 SET_STRING_ELT(datetimeclass, 1, Rf_mkChar("POSIXct"));
00544 Rf_setAttrib(value, R_ClassSymbol, datetimeclass);
00545 values.push_back(make_pair(name, value));
00546 }
00547
00548 void RcppResultSet::add(std::string name, RcppStringVector& stringvec) {
00549 int len = (int)stringvec.size();
00550 SEXP value = PROTECT(Rf_allocVector(STRSXP, len));
00551 numProtected++;
00552 for (int i = 0; i < len; i++)
00553 SET_STRING_ELT(value, i, Rf_mkChar(stringvec(i).c_str()));
00554 values.push_back(make_pair(name, value));
00555 }
00556
00557 void RcppResultSet::add(std::string name, int *vec, int len) {
00558 if (vec == 0)
00559 throw std::range_error("RcppResultSet::add: NULL int vector");
00560 SEXP value = PROTECT(Rf_allocVector(INTSXP, len));
00561 numProtected++;
00562 for (int i = 0; i < len; i++)
00563 INTEGER(value)[i] = vec[i];
00564 values.push_back(make_pair(name, value));
00565 }
00566
00567 void RcppResultSet::add(std::string name, double **mat, int nx, int ny) {
00568 if (mat == 0)
00569 throw std::range_error("RcppResultSet::add: NULL double matrix");
00570 SEXP value = PROTECT(Rf_allocMatrix(REALSXP, nx, ny));
00571 numProtected++;
00572 for (int i = 0; i < nx; i++)
00573 for (int j = 0; j < ny; j++)
00574 REAL(value)[i + nx*j] = mat[i][j];
00575 values.push_back(make_pair(name, value));
00576 }
00577
00578 void RcppResultSet::add(std::string name, int **mat, int nx, int ny) {
00579 if (mat == 0)
00580 throw std::range_error("RcppResultSet::add: NULL int matrix");
00581 SEXP value = PROTECT(Rf_allocMatrix(INTSXP, nx, ny));
00582 numProtected++;
00583 for (int i = 0; i < nx; i++)
00584 for (int j = 0; j < ny; j++)
00585 INTEGER(value)[i + nx*j] = mat[i][j];
00586 values.push_back(make_pair(name, value));
00587 }
00588
00589 void RcppResultSet::add(std::string name, std::vector<std::string>& vec) {
00590 if (vec.size() == 0)
00591 throw std::range_error("RcppResultSet::add; zero length vector<string>");
00592 int len = (int)vec.size();
00593 SEXP value = PROTECT(Rf_allocVector(STRSXP, len));
00594 numProtected++;
00595 for (int i = 0; i < len; i++)
00596 SET_STRING_ELT(value, i, Rf_mkChar(vec[i].c_str()));
00597 values.push_back(make_pair(name, value));
00598 }
00599
00600 void RcppResultSet::add(std::string name, std::vector<int>& vec) {
00601 if (vec.size() == 0)
00602 throw std::range_error("RcppResultSet::add; zero length vector<int>");
00603 int len = (int)vec.size();
00604 SEXP value = PROTECT(Rf_allocVector(INTSXP, len));
00605 numProtected++;
00606 for (int i = 0; i < len; i++)
00607 INTEGER(value)[i] = vec[i];
00608 values.push_back(make_pair(name, value));
00609 }
00610
00611 void RcppResultSet::add(std::string name, std::vector<double>& vec) {
00612 if (vec.size() == 0)
00613 throw std::range_error("RcppResultSet::add; zero length vector<double>");
00614 int len = (int)vec.size();
00615 SEXP value = PROTECT(Rf_allocVector(REALSXP, len));
00616 numProtected++;
00617 for (int i = 0; i < len; i++)
00618 REAL(value)[i] = vec[i];
00619 values.push_back(make_pair(name, value));
00620 }
00621
00622 void RcppResultSet::add(std::string name, std::vector<std::vector<int> >& mat) {
00623 if (mat.size() == 0)
00624 throw std::range_error("RcppResultSet::add: zero length vector<vector<int> >");
00625 else if (mat[0].size() == 0)
00626 throw std::range_error("RcppResultSet::add: no columns in vector<vector<int> >");
00627 int nx = (int)mat.size();
00628 int ny = (int)mat[0].size();
00629 SEXP value = PROTECT(Rf_allocMatrix(INTSXP, nx, ny));
00630 numProtected++;
00631 for (int i = 0; i < nx; i++)
00632 for (int j = 0; j < ny; j++)
00633 INTEGER(value)[i + nx*j] = mat[i][j];
00634 values.push_back(make_pair(name, value));
00635 }
00636
00637 void RcppResultSet::add(std::string name, std::vector<std::vector<double> >& mat) {
00638 if (mat.size() == 0)
00639 throw std::range_error("RcppResultSet::add: zero length vector<vector<double> >");
00640 else if (mat[0].size() == 0)
00641 throw std::range_error("RcppResultSet::add: no columns in vector<vector<double> >");
00642 int nx = (int)mat.size();
00643 int ny = (int)mat[0].size();
00644 SEXP value = PROTECT(Rf_allocMatrix(REALSXP, nx, ny));
00645 numProtected++;
00646 for (int i = 0; i < nx; i++)
00647 for (int j = 0; j < ny; j++)
00648 REAL(value)[i + nx*j] = mat[i][j];
00649 values.push_back(make_pair(name, value));
00650 }
00651
00652 void RcppResultSet::add(std::string name, RcppVector<int>& vec) {
00653 int len = vec.size();
00654 int *a = vec.cVector();
00655 SEXP value = PROTECT(Rf_allocVector(INTSXP, len));
00656 numProtected++;
00657 for (int i = 0; i < len; i++)
00658 INTEGER(value)[i] = a[i];
00659 values.push_back(make_pair(name, value));
00660 }
00661
00662 void RcppResultSet::add(std::string name, RcppVector<double>& vec) {
00663 int len = vec.size();
00664 double *a = vec.cVector();
00665 SEXP value = PROTECT(Rf_allocVector(REALSXP, len));
00666 numProtected++;
00667 for (int i = 0; i < len; i++)
00668 REAL(value)[i] = a[i];
00669 values.push_back(make_pair(name, value));
00670 }
00671
00672 void RcppResultSet::add(std::string name, RcppMatrix<int>& mat) {
00673 int nx = mat.getDim1();
00674 int ny = mat.getDim2();
00675 int **a = mat.cMatrix();
00676 SEXP value = PROTECT(Rf_allocMatrix(INTSXP, nx, ny));
00677 numProtected++;
00678 for (int i = 0; i < nx; i++)
00679 for (int j = 0; j < ny; j++)
00680 INTEGER(value)[i + nx*j] = a[i][j];
00681 values.push_back(make_pair(name, value));
00682 }
00683
00684 void RcppResultSet::add(std::string name, RcppMatrix<double>& mat) {
00685 int nx = mat.getDim1();
00686 int ny = mat.getDim2();
00687 double **a = mat.cMatrix();
00688 SEXP value = PROTECT(Rf_allocMatrix(REALSXP, nx, ny));
00689 numProtected++;
00690 for (int i = 0; i < nx; i++)
00691 for (int j = 0; j < ny; j++)
00692 REAL(value)[i + nx*j] = a[i][j];
00693 values.push_back(make_pair(name, value));
00694 }
00695
00696 void RcppResultSet::add(std::string name, RcppFrame& frame) {
00697 std::vector<std::string> colNames = frame.getColNames();
00698 std::vector<std::vector<ColDatum> > table = frame.getTableData();
00699 int ncol = colNames.size();
00700 int nrow = table.size();
00701 SEXP rl = PROTECT(Rf_allocVector(VECSXP,ncol));
00702 SEXP nm = PROTECT(Rf_allocVector(STRSXP,ncol));
00703 numProtected += 2;
00704 for (int i=0; i < ncol; i++) {
00705 SEXP value, names;
00706 if (table[0][i].getType() == COLTYPE_DOUBLE) {
00707 value = PROTECT(Rf_allocVector(REALSXP,nrow));
00708 numProtected++;
00709 for (int j=0; j < nrow; j++)
00710 REAL(value)[j] = table[j][i].getDoubleValue();
00711 } else if (table[0][i].getType() == COLTYPE_INT) {
00712 value = PROTECT(Rf_allocVector(INTSXP,nrow));
00713 numProtected++;
00714 for (int j=0; j < nrow; j++)
00715 INTEGER(value)[j] = table[j][i].getIntValue();
00716 } else if (table[0][i].getType() == COLTYPE_FACTOR) {
00717 value = PROTECT(Rf_allocVector(INTSXP,nrow));
00718 numProtected++;
00719 int levels = table[0][i].getFactorNumLevels();
00720 names = PROTECT(Rf_allocVector(STRSXP,levels));
00721 numProtected++;
00722 std::string *levelNames = table[0][i].getFactorLevelNames();
00723 for (int k=0; k < levels; k++)
00724 SET_STRING_ELT(names, k, Rf_mkChar(levelNames[k].c_str()));
00725 for (int j=0; j < nrow; j++) {
00726 int level = table[j][i].getFactorLevel();
00727 INTEGER(value)[j] = level;
00728 }
00729 Rf_setAttrib(value, R_LevelsSymbol, names);
00730 SEXP factorclass = PROTECT(Rf_allocVector(STRSXP,1));
00731 numProtected++;
00732 SET_STRING_ELT(factorclass, 0, Rf_mkChar("factor"));
00733 Rf_setAttrib(value, R_ClassSymbol, factorclass);
00734 } else if (table[0][i].getType() == COLTYPE_STRING) {
00735 value = PROTECT(Rf_allocVector(STRSXP,nrow));
00736 numProtected++;
00737 for (int j=0; j < nrow; j++) {
00738 SET_STRING_ELT(value, j, Rf_mkChar(table[j][i].getStringValue().c_str()));
00739 }
00740 } else if (table[0][i].getType() == COLTYPE_LOGICAL) {
00741 value = PROTECT(Rf_allocVector(LGLSXP,nrow));
00742 numProtected++;
00743 for (int j=0; j < nrow; j++) {
00744 LOGICAL(value)[j] = table[j][i].getLogicalValue();
00745 }
00746 } else if (table[0][i].getType() == COLTYPE_DATE) {
00747 value = PROTECT(Rf_allocVector(REALSXP,nrow));
00748 numProtected++;
00749 for (int j=0; j < nrow; j++)
00750 REAL(value)[j] = table[j][i].getDateRCode();
00751 SEXP dateclass = PROTECT(Rf_allocVector(STRSXP,1));
00752 numProtected++;
00753 SET_STRING_ELT(dateclass, 0, Rf_mkChar("Date"));
00754 Rf_setAttrib(value, R_ClassSymbol, dateclass);
00755 } else if (table[0][i].getType() == COLTYPE_DATETIME) {
00756 value = PROTECT(Rf_allocVector(REALSXP,nrow));
00757 numProtected++;
00758 for (int j=0; j < nrow; j++) {
00759
00760
00761 REAL(value)[j] = table[j][i].getDatetimeValue().getFractionalTimestamp();
00762 }
00763 SEXP dateclass = PROTECT(Rf_allocVector(STRSXP,2));
00764 numProtected++;
00765 SET_STRING_ELT(dateclass, 0, Rf_mkChar("POSIXt"));
00766 SET_STRING_ELT(dateclass, 1, Rf_mkChar("POSIXct"));
00767 Rf_setAttrib(value, R_ClassSymbol, dateclass);
00768 } else {
00769 throw std::range_error("RcppResultSet::add invalid column type");
00770 }
00771 SET_VECTOR_ELT(rl, i, value);
00772 SET_STRING_ELT(nm, i, Rf_mkChar(colNames[i].c_str()));
00773 }
00774 Rf_setAttrib(rl, R_NamesSymbol, nm);
00775 values.push_back(make_pair(name, rl));
00776 }
00777
00778 void RcppResultSet::add(std::string name, RcppList &list) {
00779
00780 values.push_back(make_pair(name, list.getList()));
00781 }
00782
00783 void RcppResultSet::add(std::string name, SEXP sexp, bool isProtected) {
00784 values.push_back(make_pair(name, sexp));
00785 if (isProtected)
00786 numProtected++;
00787 }
00788
00789 SEXP RcppResultSet::getReturnList() {
00790 int nret = (int)values.size();
00791 SEXP rl = PROTECT(Rf_allocVector(VECSXP,nret));
00792 SEXP nm = PROTECT(Rf_allocVector(STRSXP,nret));
00793 std::list<std::pair<std::string,SEXP> >::iterator iter = values.begin();
00794 for (int i = 0; iter != values.end(); iter++, i++) {
00795 SET_VECTOR_ELT(rl, i, iter->second);
00796 SET_STRING_ELT(nm, i, Rf_mkChar(iter->first.c_str()));
00797 }
00798 Rf_setAttrib(rl, R_NamesSymbol, nm);
00799 UNPROTECT(numProtected+2);
00800 return rl;
00801 }
00802
00803
00804 std::ostream& operator<<(std::ostream& os, const RcppDate& date) {
00805 os << date.getYear() << "-" << date.getMonth() << "-" << date.getDay();
00806 return os;
00807 }
00808
00809
00810 RcppDate operator+(const RcppDate& date, int offset) {
00811 RcppDate temp(date.month, date.day, date.year);
00812 temp.jdn += offset;
00813 temp.jdn2mdy();
00814 return temp;
00815 }
00816
00817 int operator-(const RcppDate& date2, const RcppDate& date1) {
00818 return date2.jdn - date1.jdn;
00819 }
00820
00821 bool operator<(const RcppDate &date1, const RcppDate& date2) {
00822 return date1.jdn < date2.jdn;
00823 }
00824
00825 bool operator>(const RcppDate &date1, const RcppDate& date2) {
00826 return date1.jdn > date2.jdn;
00827 }
00828
00829 bool operator>=(const RcppDate &date1, const RcppDate& date2) {
00830 return date1.jdn >= date2.jdn;
00831 }
00832
00833 bool operator<=(const RcppDate &date1, const RcppDate& date2) {
00834 return date1.jdn <= date2.jdn;
00835 }
00836
00837 bool operator==(const RcppDate &date1, const RcppDate& date2) {
00838 return date1.jdn == date2.jdn;
00839 }
00840
00841
00842 const int RcppDate::Jan1970Offset = 2440588;
00843
00844
00845 const int RcppDate::QLtoJan1970Offset = 25569;
00846
00847
00848
00849
00850
00851
00852
00853
00854
00855
00856
00857
00858
00859
00860 void RcppDate::mdy2jdn() {
00861 int m = month, d = day, y = year;
00862 int a = (14 - m)/12;
00863 y += 4800 - a;
00864 m += 12*a - 3;
00865 jdn = (d + (153*m + 2)/5 + 365*y
00866 + y/4 - y/100 + y/400 - 32045);
00867 }
00868
00869
00870 void RcppDate::jdn2mdy() {
00871 int jul = jdn + 32044;
00872 int g = jul/146097;
00873 int dg = jul % 146097;
00874 int c = (dg/36524 + 1)*3/4;
00875 int dc = dg - c*36524;
00876 int b = dc/1461;
00877 int db = dc % 1461;
00878 int a = (db/365 + 1)*3/4;
00879 int da = db - a*365;
00880 int y = g*400 + c*100 + b*4 + a;
00881 int m = (da*5 + 308)/153 - 2;
00882 int d = da - (m + 4)*153 /5 + 122;
00883 y = y - 4800 + (m + 2)/12;
00884 m = (m + 2) % 12 + 1;
00885 d = d + 1;
00886 month = m;
00887 day = d;
00888 year = y;
00889 }
00890
00891 SEXP RcppFunction::listCall() {
00892 if (names.size() != (unsigned)listSize)
00893 throw std::range_error("RcppFunction::listCall: no. of names != no. of items");
00894 if (currListPosn != listSize)
00895 throw std::range_error("RcppFunction::listCall: list has incorrect size");
00896 SEXP nm = PROTECT(Rf_allocVector(STRSXP,listSize));
00897 numProtected++;
00898 for (int i=0; i < listSize; i++)
00899 SET_STRING_ELT(nm, i, Rf_mkChar(names[i].c_str()));
00900 Rf_setAttrib(listArg, R_NamesSymbol, nm);
00901 SEXP R_fcall;
00902 PROTECT(R_fcall = Rf_lang2(fn, R_NilValue));
00903 numProtected++;
00904 SETCADR(R_fcall, listArg);
00905 SEXP result = Rf_eval(R_fcall, R_NilValue);
00906 names.clear();
00907 listSize = currListPosn = 0;
00908 return result;
00909 }
00910
00911 SEXP RcppFunction::vectorCall() {
00912 if (vectorArg == R_NilValue)
00913 throw std::range_error("RcppFunction::vectorCall: vector has not been set");
00914 SEXP R_fcall;
00915 PROTECT(R_fcall = Rf_lang2(fn, R_NilValue));
00916 numProtected++;
00917 SETCADR(R_fcall, vectorArg);
00918 SEXP result = Rf_eval(R_fcall, R_NilValue);
00919 vectorArg = R_NilValue;
00920 return result;
00921 }
00922
00923 void RcppFunction::setRVector(std::vector<double>& v) {
00924 vectorArg = PROTECT(Rf_allocVector(REALSXP,v.size()));
00925 numProtected++;
00926 for (int i=0; i < (int)v.size(); i++)
00927 REAL(vectorArg)[i] = v[i];
00928 }
00929
00930 void RcppFunction::setRListSize(int n) {
00931 listSize = n;
00932 listArg = PROTECT(Rf_allocVector(VECSXP, n));
00933 numProtected++;
00934 }
00935
00936 void RcppFunction::appendToRList(std::string name, double value) {
00937 if (currListPosn < 0 || currListPosn >= listSize)
00938 throw std::range_error("RcppFunction::appendToRList(double): list posn out of range");
00939 SEXP valsxp = PROTECT(Rf_allocVector(REALSXP,1));
00940 numProtected++;
00941 REAL(valsxp)[0] = value;
00942 SET_VECTOR_ELT(listArg, currListPosn++, valsxp);
00943 names.push_back(name);
00944 }
00945
00946 void RcppFunction::appendToRList(std::string name, int value) {
00947 if (currListPosn < 0 || currListPosn >= listSize)
00948 throw std::range_error("RcppFunction::appendToRlist(int): posn out of range");
00949 SEXP valsxp = PROTECT(Rf_allocVector(INTSXP,1));
00950 numProtected++;
00951 INTEGER(valsxp)[0] = value;
00952 SET_VECTOR_ELT(listArg, currListPosn++, valsxp);
00953 names.push_back(name);
00954 }
00955
00956 void RcppFunction::appendToRList(std::string name, std::string value) {
00957 if (currListPosn < 0 || currListPosn >= listSize)
00958 throw std::range_error("RcppFunction::appendToRlist(string): posn out of range");
00959 SEXP valsxp = PROTECT(Rf_allocVector(STRSXP,1));
00960 numProtected++;
00961 SET_STRING_ELT(valsxp, 0, Rf_mkChar(value.c_str()));
00962 SET_VECTOR_ELT(listArg, currListPosn++, valsxp);
00963 names.push_back(name);
00964 }
00965
00966 void RcppFunction::appendToRList(std::string name, RcppDate& date) {
00967 if (currListPosn < 0 || currListPosn >= listSize)
00968 throw std::range_error("RcppFunction::appendToRlist(RcppDate): list posn out of range");
00969 SEXP valsxp = PROTECT(Rf_allocVector(REALSXP,1));
00970 numProtected++;
00971 REAL(valsxp)[0] = date.getJDN() - RcppDate::Jan1970Offset;
00972 SEXP dateclass = PROTECT(Rf_allocVector(STRSXP, 1));
00973 numProtected++;
00974 SET_STRING_ELT(dateclass, 0, Rf_mkChar("Date"));
00975 Rf_setAttrib(valsxp, R_ClassSymbol, dateclass);
00976 SET_VECTOR_ELT(listArg, currListPosn++, valsxp);
00977 names.push_back(name);
00978 }
00979
00980 void RcppFunction::appendToRList(std::string name, RcppDatetime& datetime) {
00981 if (currListPosn < 0 || currListPosn >= listSize)
00982 throw std::range_error("RcppFunction::appendToRlist(RcppDatetime): list posn out of range");
00983 SEXP valsxp = PROTECT(Rf_allocVector(REALSXP,1));
00984 numProtected++;
00985 REAL(valsxp)[0] = datetime.getFractionalTimestamp();
00986 SEXP datetimeclass = PROTECT(Rf_allocVector(STRSXP, 2));
00987 numProtected++;
00988 SET_STRING_ELT(datetimeclass, 0, Rf_mkChar("POSIXt"));
00989 SET_STRING_ELT(datetimeclass, 1, Rf_mkChar("POSIXct"));
00990 Rf_setAttrib(valsxp, R_ClassSymbol, datetimeclass);
00991 SET_VECTOR_ELT(listArg, currListPosn++, valsxp);
00992 names.push_back(name);
00993 }
00994
00995 #include <cstring>
00996
00997
00998
00999
01000 char *copyMessageToR(const char* const mesg) {
01001 char* Rmesg;
01002 const char* prefix = "Exception: ";
01003 void* Rheap = R_alloc(strlen(prefix)+strlen(mesg)+1,sizeof(char));
01004 Rmesg = static_cast<char*>(Rheap);
01005 strcpy(Rmesg, prefix);
01006 strcat(Rmesg, mesg);
01007 return Rmesg;
01008 }
01009