|
RInside Version 0.2.10
|
00001 // -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; indent-tabs-mode: nil; -*- 00002 // 00003 // RInside.cpp: R/C++ interface class library -- Easier R embedding into C++ 00004 // 00005 // Copyright (C) 2009 Dirk Eddelbuettel 00006 // Copyright (C) 2010 - 2012 Dirk Eddelbuettel and Romain Francois 00007 // 00008 // This file is part of RInside. 00009 // 00010 // RInside is free software: you can redistribute it and/or modify it 00011 // under the terms of the GNU General Public License as published by 00012 // the Free Software Foundation, either version 2 of the License, or 00013 // (at your option) any later version. 00014 // 00015 // RInside is distributed in the hope that it will be useful, but 00016 // WITHOUT ANY WARRANTY; without even the implied warranty of 00017 // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 00018 // GNU General Public License for more details. 00019 // 00020 // You should have received a copy of the GNU General Public License 00021 // along with RInside. If not, see <http://www.gnu.org/licenses/>. 00022 00023 #include <RInside.h> 00024 #include <Callbacks.h> 00025 00026 RInside* RInside::instance_m = 0 ; 00027 00028 const char *programName = "RInside"; 00029 00030 #ifdef WIN32 00031 // on Windows, we need to provide setenv which is in the file setenv.c here 00032 #include "setenv/setenv.c" 00033 extern int optind; 00034 #endif 00035 00036 RInside::~RInside() { // now empty as MemBuf is internal 00037 R_dot_Last(); 00038 R_RunExitFinalizers(); 00039 R_CleanTempDir(); 00040 //Rf_KillAllDevices(); 00041 //#ifndef WIN32 00042 //fpu_setup(FALSE); 00043 //#endif 00044 Rf_endEmbeddedR(0); 00045 instance_m = 0 ; 00046 } 00047 00048 RInside::RInside() 00049 #ifdef RINSIDE_CALLBACKS 00050 : callbacks(0) 00051 #endif 00052 { 00053 initialize(0, 0, false, false, false); 00054 } 00055 00056 #ifdef WIN32 00057 static int myReadConsole(const char *prompt, char *buf, int len, int addtohistory) { 00058 fputs(prompt, stdout); 00059 fflush(stdout); 00060 if (fgets(buf, len, stdin)) 00061 return 1; 00062 else 00063 return 0; 00064 } 00065 00066 static void myWriteConsole(const char *buf, int len) { 00067 fwrite(buf, sizeof(char), len, stdout); 00068 fflush(stdout); 00069 } 00070 00071 static void myCallBack() { 00072 /* called during i/o, eval, graphics in ProcessEvents */ 00073 } 00074 00075 static void myBusy(int which) { 00076 /* set a busy cursor ... if which = 1, unset if which = 0 */ 00077 } 00078 00079 void myAskOk(const char *info) { 00080 00081 } 00082 00083 int myAskYesNoCancel(const char *question) { 00084 const int yes = 1; 00085 return yes; 00086 } 00087 00088 #endif 00089 00090 RInside::RInside(const int argc, const char* const argv[], const bool loadRcpp, 00091 const bool verbose, const bool interactive) 00092 #ifdef RINSIDE_CALLBACKS 00093 : callbacks(0) 00094 #endif 00095 { 00096 initialize(argc, argv, loadRcpp, verbose, interactive); 00097 } 00098 00099 // TODO: use a vector<string> would make all this a bit more readable 00100 void RInside::initialize(const int argc, const char* const argv[], const bool loadRcpp, 00101 const bool verbose, const bool interactive) { 00102 00103 if (instance_m) { 00104 throw std::runtime_error( "can only have one RInside instance" ) ; 00105 } else { 00106 instance_m = this ; 00107 } 00108 00109 verbose_m = verbose; // Default is false 00110 interactive_m = interactive; 00111 00112 // generated from Makevars{.win} 00113 #include "RInsideEnvVars.h" 00114 00115 #ifdef WIN32 00116 // we need a special case for Windows where users may deploy an RInside binary from CRAN 00117 // which will have R_HOME set at compile time to CRAN's value -- so let's try to correct 00118 // this here: a) allow user's setting of R_HOME and b) use R's get_R_HOME() function 00119 if (getenv("R_HOME") == NULL) { // if on Windows and not set 00120 char *rhome = get_R_HOME(); // query it, including registry 00121 if (rhome != NULL) { // if something was found 00122 setenv("R_HOME", get_R_HOME(), 1); // store what we got as R_HOME 00123 } // this will now be used in next blocks 00124 } 00125 #endif 00126 00127 for (int i = 0; R_VARS[i] != NULL; i+= 2) { 00128 if (getenv(R_VARS[i]) == NULL) { // if env variable is not yet set 00129 if (setenv(R_VARS[i],R_VARS[i+1],1) != 0){ 00130 throw std::runtime_error(std::string("Could not set R environment variable ") + 00131 std::string(R_VARS[i]) + std::string(" to ") + 00132 std::string(R_VARS[i+1])); 00133 } 00134 } 00135 } 00136 00137 #ifndef WIN32 00138 R_SignalHandlers = 0; // Don't let R set up its own signal handlers 00139 #endif 00140 00141 init_tempdir(); 00142 00143 const char *R_argv[] = {(char*)programName, "--gui=none", "--no-save", "--no-readline", "--silent", "", ""}; 00144 const char *R_argv_opt[] = {"--vanilla", "--slave"}; 00145 int R_argc = (sizeof(R_argv) - sizeof(R_argv_opt) ) / sizeof(R_argv[0]); 00146 Rf_initEmbeddedR(R_argc, (char**)R_argv); 00147 00148 #ifndef WIN32 00149 R_CStackLimit = -1; // Don't do any stack checking, see R Exts, '8.1.5 Threading issues' 00150 #endif 00151 00152 R_ReplDLLinit(); // this is to populate the repl console buffers 00153 00154 structRstart Rst; 00155 R_DefParams(&Rst); 00156 Rst.R_Interactive = (Rboolean) interactive_m; // sets interactive() to eval to false 00157 #ifdef WIN32 00158 Rst.rhome = getenv("R_HOME"); // which is set above as part of R_VARS 00159 Rst.home = getRUser(); 00160 Rst.CharacterMode = LinkDLL; 00161 Rst.ReadConsole = myReadConsole; 00162 Rst.WriteConsole = myWriteConsole; 00163 Rst.CallBack = myCallBack; 00164 Rst.ShowMessage = myAskOk; 00165 Rst.YesNoCancel = myAskYesNoCancel; 00166 Rst.Busy = myBusy; 00167 #endif 00168 R_SetParams(&Rst); 00169 00170 global_env_m = R_GlobalEnv ; 00171 00172 if (loadRcpp) { // if asked for, load Rcpp (before the autoloads) 00173 // Rf_install is used best by first assigning like this so that symbols get into the symbol table 00174 // where they cannot be garbage collected; doing it on the fly does expose a minuscule risk of garbage 00175 // collection -- with thanks to Doug Bates for the explanation and Luke Tierney for the heads-up 00176 SEXP suppressMessagesSymbol = Rf_install("suppressMessages"); 00177 SEXP requireSymbol = Rf_install("require"); 00178 Rf_eval(Rf_lang2(suppressMessagesSymbol, Rf_lang2(requireSymbol, Rf_mkString("Rcpp"))), R_GlobalEnv); 00179 } 00180 00181 autoloads(); // loads all default packages 00182 00183 if ((argc - optind) > 1){ // for argv vector in Global Env */ 00184 Rcpp::CharacterVector s_argv( argv+(1+optind), argv+argc ); 00185 assign(s_argv, "argv"); 00186 } else { 00187 assign(R_NilValue, "argv") ; 00188 } 00189 00190 init_rand(); // for tempfile() to work correctly */ 00191 } 00192 00193 void RInside::init_tempdir(void) { 00194 const char *tmp; 00195 // FIXME: if per-session temp directory is used (as R does) then return 00196 tmp = getenv("TMPDIR"); 00197 if (tmp == NULL) { 00198 tmp = getenv("TMP"); 00199 if (tmp == NULL) { 00200 tmp = getenv("TEMP"); 00201 if (tmp == NULL) 00202 tmp = "/tmp"; 00203 } 00204 } 00205 R_TempDir = (char*) tmp; 00206 if (setenv("R_SESSION_TMPDIR",tmp,1) != 0){ 00207 throw std::runtime_error(std::string("Could not set / replace R_SESSION_TMPDIR to ") + std::string(tmp)); 00208 } 00209 } 00210 00211 void RInside::init_rand(void) { // code borrows from R's TimeToSeed() in datetime.c 00212 unsigned int pid = getpid(); 00213 struct timeval tv; // this is ifdef'ed by R, we just assume we have it 00214 gettimeofday (&tv, NULL); 00215 unsigned int seed = ((uint64_t) tv.tv_usec << 16) ^ tv.tv_sec; 00216 seed ^= (pid << 16); // R 2.14.0 started to also use pid to support parallel 00217 srand(seed); 00218 } 00219 00220 void RInside::autoloads() { 00221 00222 #include "RInsideAutoloads.h" 00223 00224 // Autoload default packages and names from autoloads.h 00225 // 00226 // This function behaves in almost every way like 00227 // R's autoload: 00228 // function (name, package, reset = FALSE, ...) 00229 // { 00230 // if (!reset && exists(name, envir = .GlobalEnv, inherits = FALSE)) 00231 // stop("an object with that name already exists") 00232 // m <- match.call() 00233 // m[[1]] <- as.name("list") 00234 // newcall <- eval(m, parent.frame()) 00235 // newcall <- as.call(c(as.name("autoloader"), newcall)) 00236 // newcall$reset <- NULL 00237 // if (is.na(match(package, .Autoloaded))) 00238 // assign(".Autoloaded", c(package, .Autoloaded), env = .AutoloadEnv) 00239 // do.call("delayedAssign", list(name, newcall, .GlobalEnv, 00240 // .AutoloadEnv)) 00241 // invisible() 00242 // } 00243 // 00244 // What's missing is the updating of the string vector .Autoloaded with 00245 // the list of packages, which by my code analysis is useless and only 00246 // for informational purposes. 00247 // 00248 // 00249 00250 // we build the call : 00251 // 00252 // delayedAssign( NAME, 00253 // autoloader( name = NAME, package = PACKAGE), 00254 // .GlobalEnv, 00255 // .AutoloadEnv ) 00256 // 00257 // where : 00258 // - PACKAGE is updated in a loop 00259 // - NAME is updated in a loop 00260 // 00261 // 00262 00263 int i,j, idx=0, nobj ; 00264 Rcpp::Language delayed_assign_call(Rcpp::Function("delayedAssign"), 00265 R_NilValue, // arg1: assigned in loop 00266 R_NilValue, // arg2: assigned in loop 00267 global_env_m, 00268 global_env_m.find(".AutoloadEnv") 00269 ); 00270 Rcpp::Language::Proxy delayed_assign_name = delayed_assign_call[1]; 00271 00272 Rcpp::Language autoloader_call(Rcpp::Function("autoloader"), 00273 Rcpp::Named( "name", R_NilValue) , // arg1 : assigned in loop 00274 Rcpp::Named( "package", R_NilValue) // arg2 : assigned in loop 00275 ); 00276 Rcpp::Language::Proxy autoloader_name = autoloader_call[1]; 00277 Rcpp::Language::Proxy autoloader_pack = autoloader_call[2]; 00278 delayed_assign_call[2] = autoloader_call; 00279 00280 try { 00281 for( i=0; i<packc; i++){ 00282 00283 // set the 'package' argument of the autoloader call */ 00284 autoloader_pack = pack[i] ; 00285 00286 nobj = packobjc[i] ; 00287 for (j = 0; j < nobj ; j++){ 00288 00289 // set the 'name' argument of the autoloader call */ 00290 autoloader_name = packobj[idx+j] ; 00291 00292 // Set the 'name' argument of the delayedAssign call */ 00293 delayed_assign_name = packobj[idx+j] ; 00294 00295 // evaluate the call */ 00296 delayed_assign_call.eval() ; 00297 00298 } 00299 idx += packobjc[i] ; 00300 } 00301 } catch( std::exception& ex){ 00302 throw std::runtime_error(std::string("Error calling delayedAssign: ") + std::string(ex.what())); 00303 } 00304 } 00305 00306 // this is a non-throwing version returning an error code 00307 int RInside::parseEval(const std::string & line, SEXP & ans) { 00308 ParseStatus status; 00309 SEXP cmdSexp, cmdexpr = R_NilValue; 00310 int i, errorOccurred; 00311 00312 mb_m.add((char*)line.c_str()); 00313 00314 PROTECT(cmdSexp = Rf_allocVector(STRSXP, 1)); 00315 SET_STRING_ELT(cmdSexp, 0, Rf_mkChar(mb_m.getBufPtr())); 00316 00317 cmdexpr = PROTECT(R_ParseVector(cmdSexp, -1, &status, R_NilValue)); 00318 00319 switch (status){ 00320 case PARSE_OK: 00321 // Loop is needed here as EXPSEXP might be of length > 1 00322 for(i = 0; i < Rf_length(cmdexpr); i++){ 00323 ans = R_tryEval(VECTOR_ELT(cmdexpr, i), global_env_m, &errorOccurred); 00324 if (errorOccurred) { 00325 if (verbose_m) Rf_warning("%s: Error in evaluating R code (%d)\n", programName, status); 00326 UNPROTECT(2); 00327 mb_m.rewind(); 00328 return 1; 00329 } 00330 if (verbose_m) { 00331 Rf_PrintValue(ans); 00332 } 00333 } 00334 mb_m.rewind(); 00335 break; 00336 case PARSE_INCOMPLETE: 00337 // need to read another line 00338 break; 00339 case PARSE_NULL: 00340 if (verbose_m) Rf_warning("%s: ParseStatus is null (%d)\n", programName, status); 00341 UNPROTECT(2); 00342 mb_m.rewind(); 00343 return 1; 00344 break; 00345 case PARSE_ERROR: 00346 if (verbose_m) Rf_warning("Parse Error: \"%s\"\n", line.c_str()); 00347 UNPROTECT(2); 00348 mb_m.rewind(); 00349 return 1; 00350 break; 00351 case PARSE_EOF: 00352 if (verbose_m) Rf_warning("%s: ParseStatus is eof (%d)\n", programName, status); 00353 break; 00354 default: 00355 if (verbose_m) Rf_warning("%s: ParseStatus is not documented %d\n", programName, status); 00356 UNPROTECT(2); 00357 mb_m.rewind(); 00358 return 1; 00359 break; 00360 } 00361 UNPROTECT(2); 00362 return 0; 00363 } 00364 00365 void RInside::parseEvalQ(const std::string & line) { 00366 SEXP ans; 00367 int rc = parseEval(line, ans); 00368 if (rc != 0) { 00369 throw std::runtime_error(std::string("Error evaluating: ") + line); 00370 } 00371 } 00372 00373 void RInside::parseEvalQNT(const std::string & line) { 00374 SEXP ans; 00375 parseEval(line, ans); 00376 } 00377 00378 RInside::Proxy RInside::parseEval(const std::string & line) { 00379 SEXP ans; 00380 int rc = parseEval(line, ans); 00381 if (rc != 0) { 00382 throw std::runtime_error(std::string("Error evaluating: ") + line); 00383 } 00384 return Proxy( ans ); 00385 } 00386 00387 RInside::Proxy RInside::parseEvalNT(const std::string & line) { 00388 SEXP ans; 00389 parseEval(line, ans); 00390 return Proxy( ans ); 00391 } 00392 00393 Rcpp::Environment::Binding RInside::operator[]( const std::string& name ){ 00394 return global_env_m[name]; 00395 } 00396 00397 RInside& RInside::instance(){ 00398 return *instance_m; 00399 } 00400 00401 RInside* RInside::instancePtr(){ 00402 return instance_m; 00403 } 00404 00405 /* callbacks */ 00406 00407 #ifdef RINSIDE_CALLBACKS 00408 00409 void Callbacks::Busy_( int which ){ 00410 R_is_busy = static_cast<bool>( which ) ; 00411 Busy( R_is_busy ) ; 00412 } 00413 00414 int Callbacks::ReadConsole_( const char* prompt, unsigned char* buf, int len, int addtohistory ){ 00415 try { 00416 std::string res( ReadConsole( prompt, static_cast<bool>(addtohistory) ) ) ; 00417 00418 /* At some point we need to figure out what to do if the result is 00419 * longer than "len"... For now, just truncate. */ 00420 00421 int l = res.size() ; 00422 int last = (l>len-1)?len-1:l ; 00423 strncpy( (char*)buf, res.c_str(), last ) ; 00424 buf[last] = 0 ; 00425 return 1 ; 00426 } catch( const std::exception& ex){ 00427 return -1 ; 00428 } 00429 } 00430 00431 00432 void Callbacks::WriteConsole_( const char* buf, int len, int oType ){ 00433 if( len ){ 00434 buffer.assign( buf, buf + len - 1 ) ; 00435 WriteConsole( buffer, oType) ; 00436 } 00437 } 00438 00439 void RInside_ShowMessage( const char* message ){ 00440 RInside::instance().callbacks->ShowMessage( message ) ; 00441 } 00442 00443 void RInside_WriteConsoleEx( const char* message, int len, int oType ){ 00444 RInside::instance().callbacks->WriteConsole_( message, len, oType ) ; 00445 } 00446 00447 int RInside_ReadConsole(const char *prompt, unsigned char *buf, int len, int addtohistory){ 00448 return RInside::instance().callbacks->ReadConsole_( prompt, buf, len, addtohistory ) ; 00449 } 00450 00451 void RInside_ResetConsole(){ 00452 RInside::instance().callbacks->ResetConsole() ; 00453 } 00454 00455 void RInside_FlushConsole(){ 00456 RInside::instance().callbacks->FlushConsole() ; 00457 } 00458 00459 void RInside_ClearerrConsole(){ 00460 RInside::instance().callbacks->CleanerrConsole() ; 00461 } 00462 00463 void RInside_Busy( int which ){ 00464 RInside::instance().callbacks->Busy_(which) ; 00465 } 00466 00467 void RInside::set_callbacks(Callbacks* callbacks_){ 00468 callbacks = callbacks_ ; 00469 00470 #ifdef WIN32 00471 // do something to tell user that he doesn't get this 00472 #else 00473 00474 /* short circuit the callback function pointers */ 00475 if( callbacks->has_ShowMessage() ){ 00476 ptr_R_ShowMessage = RInside_ShowMessage ; 00477 } 00478 if( callbacks->has_ReadConsole() ){ 00479 ptr_R_ReadConsole = RInside_ReadConsole; 00480 } 00481 if( callbacks->has_WriteConsole() ){ 00482 ptr_R_WriteConsoleEx = RInside_WriteConsoleEx ; 00483 ptr_R_WriteConsole = NULL; 00484 } 00485 if( callbacks->has_ResetConsole() ){ 00486 ptr_R_ResetConsole = RInside_ResetConsole; 00487 } 00488 if( callbacks->has_FlushConsole() ){ 00489 ptr_R_FlushConsole = RInside_FlushConsole; 00490 } 00491 if( callbacks->has_CleanerrConsole() ){ 00492 ptr_R_ClearerrConsole = RInside_ClearerrConsole; 00493 } 00494 if( callbacks->has_Busy() ){ 00495 ptr_R_Busy = RInside_Busy; 00496 } 00497 00498 R_Outputfile = NULL; 00499 R_Consolefile = NULL; 00500 #endif 00501 } 00502 00503 void RInside::repl(){ 00504 R_ReplDLLinit(); 00505 while( R_ReplDLLdo1() > 0 ) {} 00506 } 00507 00508 #endif