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