00001
00002
00003
00004
00005
00006
00007
00008 #include "RInside.h"
00009 #include <sys/time.h>
00010
00011 bool verbose = false;
00012 const char *programName = "RInside";
00013
00014 RInside::~RInside() {
00015 if (verbose) std::cout << "RInside::dtor BEGIN" << std::endl;
00016 Rf_endEmbeddedR(0);
00017 if (verbose) std::cout << "RInside::dtor END" << std::endl;
00018 }
00019
00020 RInside::RInside(const int argc, const char* const argv[]) {
00021 if (verbose) std::cout << "RInside::ctor BEGIN" << std::endl;
00022
00023 verbose_m = false;
00024
00025
00026 #include "RInsideEnvVars.h"
00027
00028 for (int i = 0; R_VARS[i] != NULL; i+= 2) {
00029 if (getenv(R_VARS[i]) == NULL) {
00030 if (setenv(R_VARS[i],R_VARS[i+1],1) != 0){
00031 perror("ERROR: couldn't set/replace an R environment variable");
00032 exit(1);
00033 }
00034 }
00035 }
00036
00037 R_SignalHandlers = 0;
00038
00039 #ifdef CSTACK_DEFNS
00040 R_CStackLimit = (uintptr_t)-1;
00041 #endif
00042
00043 init_tempdir();
00044
00045 const char *R_argv[] = {(char*)programName, "--gui=none", "--no-save", "--no-readline", "--silent", "", ""};
00046 const char *R_argv_opt[] = {"--vanilla", "--slave"};
00047 int R_argc = (sizeof(R_argv) - sizeof(R_argv_opt) ) / sizeof(R_argv[0]);
00048 Rf_initEmbeddedR(R_argc, (char**)R_argv);
00049
00050 R_ReplDLLinit();
00051
00052
00053
00054 autoloads();
00055
00056 SEXP s_argv = R_NilValue;
00057 if ((argc - optind) > 1){
00058 int nargv = argc - optind - 1;
00059 PROTECT(s_argv = allocVector(STRSXP,nargv));
00060 for (int i = 0; i <nargv; i++){
00061 STRING_PTR(s_argv)[i] = mkChar(argv[i+1+optind]);
00062 }
00063 UNPROTECT(1);
00064
00065 setVar(install("argv"),s_argv,R_GlobalEnv);
00066 } else {
00067 setVar(install("argv"),R_NilValue,R_GlobalEnv);
00068 }
00069
00070 init_rand();
00071 if (verbose) std::cout << "RInside::ctor END" << std::endl;
00072 }
00073
00074 void RInside::init_tempdir(void) {
00075 const char *tmp;
00076
00077 tmp = getenv("TMPDIR");
00078 if (tmp == NULL) {
00079 tmp = getenv("TMP");
00080 if (tmp == NULL) {
00081 tmp = getenv("TEMP");
00082 if (tmp == NULL)
00083 tmp = "/tmp";
00084 }
00085 }
00086 R_TempDir = (char*) tmp;
00087 if (setenv("R_SESSION_TMPDIR",tmp,1) != 0){
00088 perror("Fatal Error: couldn't set/replace R_SESSION_TMPDIR!");
00089 exit(1);
00090 }
00091 }
00092
00093 void RInside::init_rand(void) {
00094 unsigned int seed;
00095 struct timeval tv;
00096 gettimeofday (&tv, NULL);
00097
00098 seed = ((unsigned int) tv.tv_usec << 16) ^ tv.tv_sec;
00099 srand(seed);
00100 }
00101
00102 void RInside::autoloads() {
00103
00104 #include "RInsideAutoloads.h"
00105
00106
00107
00108
00109
00110
00111
00112
00113
00114
00115
00116
00117
00118
00119
00120
00121
00122
00123
00124
00125
00126
00127
00128
00129
00130
00131
00132
00133 SEXP da, dacall, al, alcall, AutoloadEnv, name, package;
00134 int i,j, idx=0, errorOccurred, ptct;
00135
00136
00137 PROTECT(da = Rf_findFun(Rf_install("delayedAssign"), R_GlobalEnv));
00138 PROTECT(AutoloadEnv = Rf_findVar(Rf_install(".AutoloadEnv"), R_GlobalEnv));
00139 if (AutoloadEnv == R_NilValue){
00140 fprintf(stderr,"%s: Cannot find .AutoloadEnv!\n", programName);
00141 exit(1);
00142 }
00143 PROTECT(dacall = allocVector(LANGSXP,5));
00144 SETCAR(dacall,da);
00145
00146
00147 SETCAR(CDR(CDR(CDR(dacall))),R_GlobalEnv);
00148 SETCAR(CDR(CDR(CDR(CDR(dacall)))),AutoloadEnv);
00149
00150
00151 PROTECT(al = Rf_findFun(Rf_install("autoloader"), R_GlobalEnv));
00152 PROTECT(alcall = allocVector(LANGSXP,3));
00153 SET_TAG(alcall, R_NilValue);
00154 SETCAR(alcall,al);
00155
00156
00157
00158 ptct = 5;
00159 for(i = 0; i < packc; i++){
00160 idx += (i != 0)? packobjc[i-1] : 0;
00161 for (j = 0; j < packobjc[i]; j++){
00162
00163
00164 PROTECT(name = NEW_CHARACTER(1));
00165 PROTECT(package = NEW_CHARACTER(1));
00166 SET_STRING_ELT(name, 0, COPY_TO_USER_STRING(packobj[idx+j]));
00167 SET_STRING_ELT(package, 0, COPY_TO_USER_STRING(pack[i]));
00168
00169
00170 PROTECT(alcall = allocVector(LANGSXP,3));
00171 SET_TAG(alcall, R_NilValue);
00172 SETCAR(alcall,al);
00173 SETCAR(CDR(alcall),name);
00174 SETCAR(CDR(CDR(alcall)),package);
00175
00176
00177 SETCAR(CDR(dacall),name);
00178 SETCAR(CDR(CDR(dacall)),alcall);
00179
00180 R_tryEval(dacall,R_GlobalEnv,&errorOccurred);
00181 if (errorOccurred){
00182 fprintf(stderr,"%s: Error calling delayedAssign!\n",
00183 programName);
00184 exit(1);
00185 }
00186
00187 ptct += 3;
00188 }
00189 }
00190 UNPROTECT(ptct);
00191 }
00192
00193 int RInside::parseEval(const std::string & line, SEXP & ans) {
00194 ParseStatus status;
00195 SEXP cmdSexp, cmdexpr = R_NilValue;
00196 int i, errorOccurred;
00197
00198 mb_m.add((char*)line.c_str());
00199
00200 PROTECT(cmdSexp = allocVector(STRSXP, 1));
00201 SET_STRING_ELT(cmdSexp, 0, mkChar((char*)mb_m.getBufPtr()));
00202
00203 cmdexpr = PROTECT(R_ParseVector(cmdSexp, -1, &status, R_NilValue));
00204 switch (status){
00205 case PARSE_OK:
00206
00207 for(i = 0; i < length(cmdexpr); i++){
00208 ans = R_tryEval(VECTOR_ELT(cmdexpr, i),NULL,&errorOccurred);
00209 if (errorOccurred) return 1;
00210
00211 if (verbose_m) {
00212 PrintValue(ans);
00213 }
00214 }
00215 mb_m.rewind();
00216 break;
00217 case PARSE_INCOMPLETE:
00218
00219 break;
00220 case PARSE_NULL:
00221 fprintf(stderr, "%s: ParseStatus is null (%d)\n", programName, status);
00222 return 1;
00223 break;
00224 case PARSE_ERROR:
00225 fprintf(stderr,"Parse Error: \"%s\"\n", line.c_str());
00226 return 1;
00227 break;
00228 case PARSE_EOF:
00229 fprintf(stderr, "%s: ParseStatus is eof (%d)\n", programName, status);
00230 break;
00231 default:
00232 fprintf(stderr, "%s: ParseStatus is not documented %d\n", programName, status);
00233 return 1;
00234 break;
00235 }
00236 UNPROTECT(2);
00237 return 0;
00238 }
00239
00240 int RInside::parseEvalQ(const std::string & line) {
00241 SEXP ans;
00242 int rc = parseEval(line, ans);
00243 return rc;
00244 }
00245
00246
00247 void RInside::assign(const std::vector< std::vector< double > > & mat, const std::string & nam) {
00248 int nx = mat.size();
00249 int ny = mat[0].size();
00250 SEXP sexpmat = PROTECT(allocMatrix(REALSXP, nx, ny));
00251 for(int i = 0; i < nx; i++) {
00252 for(int j = 0; j < ny; j++) {
00253 REAL(sexpmat)[i + nx*j] = mat[i][j];
00254 }
00255 }
00256 setVar(install((char*) nam.c_str()), sexpmat, R_GlobalEnv);
00257 UNPROTECT(1);
00258 }
00259
00260
00261 void RInside::assign(const std::vector< std::vector< int > > & mat, const std::string & nam) {
00262 int nx = mat.size();
00263 int ny = mat[0].size();
00264 SEXP sexpmat = PROTECT(allocMatrix(INTSXP, nx, ny));
00265 for(int i = 0; i < nx; i++) {
00266 for(int j = 0; j < ny; j++) {
00267 INTEGER(sexpmat)[i + nx*j] = mat[i][j];
00268 }
00269 }
00270 setVar(install((char*) nam.c_str()), sexpmat, R_GlobalEnv);
00271 UNPROTECT(1);
00272 }
00273
00274
00275 void RInside::assign(const std::vector< double > & vec, const std::string & nam) {
00276 int nx = vec.size();
00277 SEXP sexpvec = PROTECT(allocVector(REALSXP, nx));
00278 for(int i = 0; i < nx; i++) {
00279 REAL(sexpvec)[i] = vec[i];
00280 }
00281 setVar(install((char*) nam.c_str()), sexpvec, R_GlobalEnv);
00282 UNPROTECT(1);
00283 }
00284
00285
00286 void RInside::assign(const std::vector< std::string > & vec, const std::string & nam) {
00287 int len = (int)vec.size();
00288 SEXP sexpvec = PROTECT(allocVector(STRSXP, len));
00289 for (int i = 0; i < len; i++) {
00290 SET_STRING_ELT(sexpvec, i, mkChar(vec[i].c_str()));
00291 }
00292 setVar(install((char*) nam.c_str()), sexpvec, R_GlobalEnv);
00293 UNPROTECT(1);
00294 }
00295
00296
00297
00298 void RInside::assign(const std::vector< int > & vec, const std::string & nam) {
00299 int nx = vec.size();
00300 SEXP sexpvec = PROTECT(allocVector(INTSXP, nx));
00301 for(int i = 0; i < nx; i++) {
00302 INTEGER(sexpvec)[i] = vec[i];
00303 }
00304 setVar(install((char*) nam.c_str()), sexpvec, R_GlobalEnv);
00305 UNPROTECT(1);
00306 }
00307
00308 void RInside::assign(const std::string & txt, const std::string & nam) {
00309 SEXP value = PROTECT(allocVector(STRSXP, 1));
00310 SET_STRING_ELT(value, 0, mkChar(txt.c_str()));
00311 setVar(install((char*) nam.c_str()), value, R_GlobalEnv);
00312 UNPROTECT(1);
00313 }