00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021
00022
00023 #include <RcppFunction.h>
00024
00025 RcppFunction::RcppFunction(SEXP fn) : fn(fn) {
00026 if (!Rf_isFunction(fn))
00027 throw std::range_error("RcppFunction: non-function where function expected");
00028 numProtected = 0;
00029 currListPosn = 0;
00030 listSize = 0;
00031 vectorArg = listArg = R_NilValue;
00032 };
00033
00034 RcppFunction::~RcppFunction() {
00035 UNPROTECT(numProtected);
00036 }
00037
00038 SEXP RcppFunction::listCall() {
00039 if (names.size() != (unsigned)listSize)
00040 throw std::range_error("RcppFunction::listCall: no. of names != no. of items");
00041 if (currListPosn != listSize)
00042 throw std::range_error("RcppFunction::listCall: list has incorrect size");
00043 SEXP nm = PROTECT(Rf_allocVector(STRSXP,listSize));
00044 numProtected++;
00045 for (int i=0; i < listSize; i++)
00046 SET_STRING_ELT(nm, i, Rf_mkChar(names[i].c_str()));
00047 Rf_setAttrib(listArg, R_NamesSymbol, nm);
00048 SEXP R_fcall;
00049 PROTECT(R_fcall = Rf_lang2(fn, R_NilValue));
00050 numProtected++;
00051 SETCADR(R_fcall, listArg);
00052 SEXP result = Rf_eval(R_fcall, R_NilValue);
00053 names.clear();
00054 listSize = currListPosn = 0;
00055 return result;
00056 }
00057
00058 SEXP RcppFunction::vectorCall() {
00059 if (vectorArg == R_NilValue)
00060 throw std::range_error("RcppFunction::vectorCall: vector has not been set");
00061 SEXP R_fcall;
00062 PROTECT(R_fcall = Rf_lang2(fn, R_NilValue));
00063 numProtected++;
00064 SETCADR(R_fcall, vectorArg);
00065 SEXP result = Rf_eval(R_fcall, R_NilValue);
00066 vectorArg = R_NilValue;
00067 return result;
00068 }
00069
00070 void RcppFunction::setRVector(std::vector<double>& v) {
00071 vectorArg = PROTECT(Rf_allocVector(REALSXP,v.size()));
00072 numProtected++;
00073 for (int i=0; i < (int)v.size(); i++)
00074 REAL(vectorArg)[i] = v[i];
00075 }
00076
00077 void RcppFunction::setRListSize(int n) {
00078 listSize = n;
00079 listArg = PROTECT(Rf_allocVector(VECSXP, n));
00080 numProtected++;
00081 }
00082
00083 void RcppFunction::appendToRList(std::string name, double value) {
00084 if (currListPosn < 0 || currListPosn >= listSize)
00085 throw std::range_error("RcppFunction::appendToRList(double): list posn out of range");
00086 SEXP valsxp = PROTECT(Rf_allocVector(REALSXP,1));
00087 numProtected++;
00088 REAL(valsxp)[0] = value;
00089 SET_VECTOR_ELT(listArg, currListPosn++, valsxp);
00090 names.push_back(name);
00091 }
00092
00093 void RcppFunction::appendToRList(std::string name, int value) {
00094 if (currListPosn < 0 || currListPosn >= listSize)
00095 throw std::range_error("RcppFunction::appendToRlist(int): posn out of range");
00096 SEXP valsxp = PROTECT(Rf_allocVector(INTSXP,1));
00097 numProtected++;
00098 INTEGER(valsxp)[0] = value;
00099 SET_VECTOR_ELT(listArg, currListPosn++, valsxp);
00100 names.push_back(name);
00101 }
00102
00103 void RcppFunction::appendToRList(std::string name, std::string value) {
00104 if (currListPosn < 0 || currListPosn >= listSize)
00105 throw std::range_error("RcppFunction::appendToRlist(string): posn out of range");
00106 SEXP valsxp = PROTECT(Rf_allocVector(STRSXP,1));
00107 numProtected++;
00108 SET_STRING_ELT(valsxp, 0, Rf_mkChar(value.c_str()));
00109 SET_VECTOR_ELT(listArg, currListPosn++, valsxp);
00110 names.push_back(name);
00111 }
00112
00113 void RcppFunction::appendToRList(std::string name, RcppDate& date) {
00114 if (currListPosn < 0 || currListPosn >= listSize)
00115 throw std::range_error("RcppFunction::appendToRlist(RcppDate): list posn out of range");
00116 SEXP valsxp = PROTECT(Rf_allocVector(REALSXP,1));
00117 numProtected++;
00118 REAL(valsxp)[0] = date.getJDN() - RcppDate::Jan1970Offset;
00119 SEXP dateclass = PROTECT(Rf_allocVector(STRSXP, 1));
00120 numProtected++;
00121 SET_STRING_ELT(dateclass, 0, Rf_mkChar("Date"));
00122 Rf_setAttrib(valsxp, R_ClassSymbol, dateclass);
00123 SET_VECTOR_ELT(listArg, currListPosn++, valsxp);
00124 names.push_back(name);
00125 }
00126
00127 void RcppFunction::appendToRList(std::string name, RcppDatetime& datetime) {
00128 if (currListPosn < 0 || currListPosn >= listSize)
00129 throw std::range_error("RcppFunction::appendToRlist(RcppDatetime): list posn out of range");
00130 SEXP valsxp = PROTECT(Rf_allocVector(REALSXP,1));
00131 numProtected++;
00132 REAL(valsxp)[0] = datetime.getFractionalTimestamp();
00133 SEXP datetimeclass = PROTECT(Rf_allocVector(STRSXP, 2));
00134 numProtected++;
00135 SET_STRING_ELT(datetimeclass, 0, Rf_mkChar("POSIXt"));
00136 SET_STRING_ELT(datetimeclass, 1, Rf_mkChar("POSIXct"));
00137 Rf_setAttrib(valsxp, R_ClassSymbol, datetimeclass);
00138 SET_VECTOR_ELT(listArg, currListPosn++, valsxp);
00139 names.push_back(name);
00140 }
00141
00142 void RcppFunction::clearProtectionStack() {
00143 UNPROTECT(numProtected);
00144 numProtected = 0;
00145 }