SEXP createREnumerationValue(int val, const char * const *names, const int *values, int namesLength, const char *name) { SEXP ans; int i; PROTECT(ans =allocVector(INTSXP, 1)); INTEGER(ans)[0] = val; for(i = 0; i < namesLength; i++) { if(val == values[i]) { SET_NAMES(ans, mkString(names[i])); break; } } if(i == namesLength) { PROBLEM "Unrecognized value (%d) in enumeration %s", val, name ERROR; } /* Do we want an enumeration value element here also. */ SET_CLASS(ans, mkString(name)); Rf_PrintValue(ans); UNPROTECT(1); return(ans); }
SEXP R_get_function(char *fname) { SEXP expr, res; int error; printf("fname: %s\n", fname); SEXP robj = Rf_findVar(Rf_install(fname), R_GlobalEnv); if (robj == R_UnboundValue) return R_NilValue; robj = Rf_findFun(Rf_install(fname), R_GlobalEnv); printf("VALUE: \n"); Rf_PrintValue(robj); PROTECT(expr = allocVector(LANGSXP, 2)); SETCAR(expr, install("get")); SETCAR(CDR(expr), Rf_mkString(fname)); res = R_tryEval(expr, R_GlobalEnv, &error); // Rf_PrintValue(res); if (error) { // rb_raise(rb_eRException, "R execution exception. %s", expr); UNPROTECT(1); return NULL; } UNPROTECT(1); return res; }
HRESULT R_getCOMArgs(SEXP args, DISPPARAMS *parms, DISPID *ids, int numNamedArgs, int *namedArgPositions) { HRESULT hr; int numArgs = Rf_length(args), i, ctr; if(numArgs == 0) return(S_OK); #ifdef RDCOM_VERBOSE errorLog("Converting arguments (# %d, # %d named)\n", numArgs, numNamedArgs); #endif parms->rgvarg = (VARIANT *) S_alloc(numArgs, sizeof(VARIANT)); parms->cArgs = numArgs; /* If there are named arguments, then put these at the beginning of the rgvarg*/ if(numNamedArgs > 0) { int namedArgCtr = 0; VARIANT *var; SEXP el; SEXP names = GET_NAMES(args); parms->rgdispidNamedArgs = (DISPID *) S_alloc(numNamedArgs, sizeof(DISPID)); parms->cNamedArgs = numNamedArgs; for(i = 0, ctr = numArgs-1; i < numArgs ; i++) { if(strcmp(CHAR(STRING_ELT(names, i)), "") != 0) { var = &(parms->rgvarg[namedArgCtr]); parms->rgdispidNamedArgs[namedArgCtr] = ids[namedArgCtr + 1]; #ifdef RDCOM_VERBOSE errorLog("Putting named argument %d into %d\n", i+1, namedArgCtr); Rf_PrintValue(VECTOR_ELT(args, i)); #endif namedArgCtr++; } else { var = &(parms->rgvarg[ctr]); ctr--; } el = VECTOR_ELT(args, i); VariantInit(var); hr = R_convertRObjectToDCOM(el, var); } } else { parms->cNamedArgs = 0; parms->rgdispidNamedArgs = NULL; for(i = 0, ctr = numArgs-1; i < numArgs; i++, ctr--) { SEXP el = VECTOR_ELT(args, i); VariantInit(&parms->rgvarg[ctr]); hr = R_convertRObjectToDCOM(el, &(parms->rgvarg[ctr])); } } return(S_OK); }
SEXP R_doRefClasWsTest() { SEXP ans, klass; PROTECT(klass = MAKE_CLASS("MyTestRef")); PROTECT(ans = NEW_OBJECT(klass)); Rf_PrintValue(ans); UNPROTECT(2); return ans; }
// this is a non-throwing version returning an error code int RInside::parseEval(const std::string & line, SEXP & ans) { ParseStatus status; SEXP cmdSexp, cmdexpr = R_NilValue; int i, errorOccurred; mb_m.add((char*)line.c_str()); PROTECT(cmdSexp = Rf_allocVector(STRSXP, 1)); SET_STRING_ELT(cmdSexp, 0, Rf_mkChar(mb_m.getBufPtr())); cmdexpr = PROTECT(R_ParseVector(cmdSexp, -1, &status, R_NilValue)); switch (status){ case PARSE_OK: // Loop is needed here as EXPSEXP might be of length > 1 for(i = 0; i < Rf_length(cmdexpr); i++){ ans = R_tryEval(VECTOR_ELT(cmdexpr, i), *global_env_m, &errorOccurred); if (errorOccurred) { if (verbose_m) Rf_warning("%s: Error in evaluating R code (%d)\n", programName, status); UNPROTECT(2); mb_m.rewind(); return 1; } if (verbose_m) { Rf_PrintValue(ans); } } mb_m.rewind(); break; case PARSE_INCOMPLETE: // need to read another line break; case PARSE_NULL: if (verbose_m) Rf_warning("%s: ParseStatus is null (%d)\n", programName, status); UNPROTECT(2); mb_m.rewind(); return 1; break; case PARSE_ERROR: if (verbose_m) Rf_warning("Parse Error: \"%s\"\n", line.c_str()); UNPROTECT(2); mb_m.rewind(); return 1; break; case PARSE_EOF: if (verbose_m) Rf_warning("%s: ParseStatus is eof (%d)\n", programName, status); break; default: if (verbose_m) Rf_warning("%s: ParseStatus is not documented %d\n", programName, status); UNPROTECT(2); mb_m.rewind(); return 1; break; } UNPROTECT(2); return 0; }
// this is a non-throwing version returning an error code int REmbed::parseEval(QString line, SEXP & ans) { ParseStatus status; SEXP cmdSexp, cmdexpr = R_NilValue; int i, errorOccurred; program << line; PROTECT(cmdSexp = Rf_allocVector(STRSXP, 1)); SET_STRING_ELT(cmdSexp, 0, Rf_mkChar(program.join(" ").toStdString().c_str())); cmdexpr = PROTECT(R_ParseVector(cmdSexp, -1, &status, R_NilValue)); switch (status){ case PARSE_OK: // Loop is needed here as EXPSEXP might be of length > 1 for(i = 0; i < Rf_length(cmdexpr); i++){ ans = R_tryEval(VECTOR_ELT(cmdexpr, i), R_GlobalEnv, &errorOccurred); if (errorOccurred) { if (verbose) Rf_warning("%s: Error in evaluating R code (%d)\n", name, status); UNPROTECT(2); program.clear(); return 1; } if (verbose) { Rf_PrintValue(ans); } } program.clear(); break; case PARSE_INCOMPLETE: // need to read another line break; case PARSE_NULL: if (verbose) Rf_warning("%s: ParseStatus is null (%d)\n", name, status); UNPROTECT(2); program.clear(); return 1; break; case PARSE_ERROR: if (verbose) Rf_error("Parse Error: \"%s\"\n", line.toStdString().c_str()); UNPROTECT(2); program.clear(); return 1; break; case PARSE_EOF: if (verbose) Rf_warning("%s: ParseStatus is eof (%d)\n", name, status); break; default: if (verbose) Rf_warning("%s: ParseStatus is not documented %d\n", name, status); UNPROTECT(2); program.clear(); return 1; break; } UNPROTECT(2); return 0; }
int rffi_eval(char* cmds, int print) { int nbCmds,errorOccurred,status, i; SEXP text, expr, ans=R_NilValue /* -Wall */; //printf("Avant parsing\n"); nbCmds=1; //printf("nbCmds : %d\n",nbCmds); //printf("%s\n",cmds); text = PROTECT(allocVector(STRSXP, nbCmds)); for (i = 0 ; i < nbCmds ; i++) { SET_STRING_ELT(text, i, mkChar(cmds)); } expr = PROTECT(RR_ParseVector(text, -1, &status)); if (status != PARSE_OK) { //printf("Parsing error (status=%d) in:\n",status); for (i = 0 ; i < nbCmds ; i++) { //printf("%s\n",cmds); } UNPROTECT(2); return 0; } /* Note that expr becomes an EXPRSXP and hence we need the loop below (a straight eval(expr, R_GlobalEnv) won't work) */ { for(i = 0 ; i < nbCmds ; i++) ans = R_tryEval(VECTOR_ELT(expr, i),NULL, &errorOccurred); if(errorOccurred) { //fprintf(stderr, "Caught another error calling sqrt()\n"); fflush(stderr); UNPROTECT(2); return 0; } if (print) { Rf_PrintValue(ans); } } UNPROTECT(2); return 1; }
bool RFunction::InvokeDefault(const NPVariant *args, uint32_t argCount, NPVariant *result) { if(argCount && args[0].type == NPVariantType_Object && this->funcs->hasproperty(this->instance, args[0].value.objectValue, this->funcs->getstringidentifier("namedArgsForR"))) { return doNamedCall(this->instance, this->object, args, argCount, result, this->funcs); } SEXP Rargs[argCount]; convert_t convRet = CONV_DEFAULT; NPVariant convRetVariant; int numprot = 0; bool canfree; uint32_t j=0; bool wasConvRet; bool retained[argCount]; //argCountR is the number of arguments to be actually passed to the R function. Does not include, e.g. convertRet specification args int argCountR = argCount; //i is position in JS args, j is position in converted R args for(uint32_t i=0; i< argCount; i++) { wasConvRet = false; //If the argument is not an "emptyArg" object, indicating, eg, foo(a, , c), convert as normal if(args[i].type == NPVariantType_Object && this->funcs->hasproperty(this->instance, args[i].value.objectValue, this->funcs->getstringidentifier("_convertRet"))) { wasConvRet = true; funcs->getproperty(this->instance, args[i].value.objectValue, this->funcs->getstringidentifier("behavior"), &convRetVariant); if(convRetVariant.type==NPVariantType_Int32) convRet = (convert_t) convRetVariant.value.intValue; else if ( convRetVariant.type==NPVariantType_Double) convRet = (convert_t) convRetVariant.value.doubleValue; else convRet = CONV_CUSTOM; } else if(args[i].type == NPVariantType_Object && this->funcs->hasproperty(this->instance, args[i].value.objectValue, this->funcs->getstringidentifier("emptyRArg"))) { //If it is the special emptyRArg object, it represents a missing argument, eg rnorm(2, , 5) PROTECT(Rargs[j] = R_NilValue); Rargs[j] = R_MissingArg; numprot++; } else { PROTECT(Rargs[j] = R_NilValue); //We need to retain this because we are calling R which can initiate another conversion before we return and I think some things (eg events in raphZoom) are getting improperly freed during the inner conversion cycle if(NPVARIANT_IS_OBJECT(args[i])) { this->funcs->retainobject(args[i].value.objectValue); retained[ i ] = true; } else { retained[ i ] = false; } ConvertNPToR((NPVariant *) &(args[i]), this->instance, this->funcs, CONV_DEFAULT, &Rargs[j]); numprot++; } //If the argument was a convertRet specification it doesn't count as a "real argument", we decrease the argument count and do not increment i if(wasConvRet) argCountR--; else j++; } SEXP ans; SEXP call; int error = 0; int addProt = 0; SEXP ptr; //argCountR is the number of arguments after we remove any convertRet specifiers PROTECT(ptr = call = allocVector(LANGSXP, argCountR + 1)); SETCAR(ptr, (SEXP) this->object ); for(uint32_t i=0; i < argCountR; i++) { ptr = CDR( ptr ); SETCAR(ptr, Rargs[i]); } Rf_PrintValue(call); //PROTECT(ans = R_tryEval( call, R_GlobalEnv, &error)); PROTECT(ans = rQueue.requestRCall( call, R_GlobalEnv, &error, this->instance)); addProt = 2; if(!error) { //ConvertRToNP(ans, this->instance, this->funcs, result, CONV_DEFAULT); ConvertRToNP(ans, this->instance, this->funcs, result, convRet); if(convRet == CONV_CUSTOM) this->funcs->invokeDefault(this->instance, convRetVariant.value.objectValue, result, 1, result); } //If it's an error, just throw an error for the browser. else { ThrowRError(this, this->funcs); ConvertRToNP(R_NilValue, this->instance, this->funcs, result, CONV_DEFAULT); } UNPROTECT(numprot + addProt); //There is a bug in chrome where if an NPObject method call returns false NPN_SetException doesn't work. I'm going to experiment with always returning true... //return !error; //Unretain objects now that we are done calling R for(int k = 0; k < argCount; k++) { if(retained[k]) this->funcs->releasevariantvalue((NPVariant *) &args[k]); } return true; }
/* bool RFunction_GetProp(RFunction *Robj, NPIdentifier name, NPNetscapeFuncs *funcs, NPVariant *result, bool check, NPP inst) { SEXP obj, call, ptr, ans; //do we need to proect here? obj = Robj->object; int waserr = 0; bool toret = 0; PROTECT(ptr = call = allocVector(LANGSXP, 3)); //try [[ SETCAR(ptr, Rf_install("[[")); ptr = CDR( ptr ); SETCAR(ptr, obj); ptr = CDR( ptr ); if(funcs->identifierisstring(name)) SETCAR( ptr , Rf_install( (const char *) funcs->utf8fromidentifier(name))); else SETCAR( ptr , ScalarReal( (int) funcs->intfromidentifier(name))); PROTECT(ans = rQueue.requestRCall( call, R_GlobalEnv, &waserr, Robj->instance)); if(!waserr && !IsMissing(ans, true)) { //non-missing, non-null result. stop looking toret = 1; } else { //try $ ptr = call; SETCAR(ptr, Rf_install("$")); ans = rQueue.requestRCall( call, R_GlobalEnv, &waserr, Robj->instance); if(!waserr && !IsMissing(ans, true)) toret = 1; else { //try @ ptr = call; SETCAR(ptr, Rf_install("@")); ans = rQueue.requestRCall( call, R_GlobalEnv, &waserr, Robj->instance); if(!waserr && !IsMissing(ans, false)) toret = 1; else { ans = NEW_NUMERIC(1); REAL(ans)[0] = NA_REAL; } } } ConvertRToNP(ans, Robj->instance, funcs, result, CONV_REF); if(!check) return true; else return toret; } */ bool doNamedCall(NPP inst, SEXP fun, const NPVariant *argsIn, uint32_t count, NPVariant *_res, NPNetscapeFuncs *funcs) { fprintf(stderr, "\nAttempting to create R call with named arguments\n");fflush(stderr); uint32_t idcount = 0; NPIdentifier *ids; NPObject *obj = argsIn[0].value.objectValue; bool success = funcs->enumerate(inst, obj, &ids, &idcount); SEXP call, ans, ptr, tmp; NPVariant curprop; NPVariant *convFun = (NPVariant *) funcs->memalloc(sizeof(NPVariant)) ; convert_t conv= CONV_DEFAULT; int len = 1 + idcount; if(funcs->hasproperty(inst, obj, funcs->getstringidentifier("namedArgsForR"))) len = len -1; //the namedArgsForR property isn't going to be used as an argument in the function call if(funcs->hasproperty(inst, obj, funcs->getstringidentifier("convertRet"))) len = len -1; //the convertRet property isn't going to be used as an argument in the function call if(funcs->hasproperty(inst, obj, funcs->getstringidentifier("convertFun"))) len = len -1; //the convertFun property isn't going to be used as an argument in the function call PROTECT(ptr = call = allocVector(LANGSXP, len)); SETCAR(ptr, fun); PROTECT(tmp = R_NilValue); for(int i =0; i < idcount; i++) { funcs->getproperty(inst, obj, ids[i], &curprop); if(ids[i] == funcs->getstringidentifier("convertRet")) { //switched between 3 options on Javascript side and converted to number if(NPVARIANT_IS_INT32(curprop)) conv = (convert_t) curprop.value.intValue; else conv = (convert_t) curprop.value.doubleValue; } else if (ids[i] == funcs->getstringidentifier("convertFun")) { *convFun = curprop; // conv = CONV_REF; } else if(curprop.type == NPVariantType_Object && !funcs->hasproperty(inst, curprop.value.objectValue, funcs->getstringidentifier("emptyRArg"))) { ptr = CDR(ptr); //empty argument, ie 2nd "argument" in foo(a, , c) SETCAR(ptr, R_MissingArg); } else if(ids[i] != funcs->getstringidentifier("namedArgsForR")) { fprintf(stderr, "\nAccessing property %s\n", funcs->utf8fromidentifier(ids[i]));fflush(stderr); ptr = CDR(ptr); //funcs->getproperty(inst, obj, ids[i], &curprop); ConvertNPToR(&curprop, inst, funcs, CONV_DEFAULT, &tmp); SETCAR(ptr, tmp); SET_TAG(ptr, Rf_install((const char *) funcs->utf8fromidentifier(ids[i]))); } } fprintf(stderr, "\nFull call:\n");fflush(stderr); Rf_PrintValue(call); int err = 0; PROTECT(ans = rQueue.requestRCall(call, R_GlobalEnv, &err, inst)); //NPVariant *tmpres = ConvertRToNP(ans, inst, funcs, _res, conv); //ConvertRToNP(ans, inst, funcs, tmpres, conv); //call custom conversion method if available if(conv == 3) { funcs->invokeDefault(inst, convFun->value.objectValue, _res, 1, _res); } funcs->memfree(ids); funcs->releasevariantvalue(convFun); return !err; }
int main (int argc,char *argv[]) {/* Main */ double *f=NULL; int i; char *pp=NULL; FILE *fout=NULL; SEXP e, e1, rv, rs; init_R(argc, argv); /* Calling R and asking it to call compiled C routines! */ { int deuce=-999; DllInfo *info; R_CallMethodDef callMethods[] = { {"callback", (DL_FUNC) &callback, 1}, {NULL, NULL, 0} }; info = R_getEmbeddingDllInfo(); R_registerRoutines(info, NULL, callMethods, NULL, NULL); /* .Call is the R function used to call compiled code that uses internal R objects */ PROTECT(e1=lang3( install(".Call"), mkString("callback"),ScalarInteger(100))); /* evaluate the R command in the global environment*/ PROTECT(e=eval(e1,R_GlobalEnv)); /* show the value */ printf("Answer returned by R:"); Rf_PrintValue(e); /* store the value in a local variable */ deuce = INTEGER(e)[0]; printf("Got %d back from result SEXP\n\n", deuce); UNPROTECT(2); /* allow for R's garbage collection */ } /* Calling R and asking it to do computation on a C array */ f = (double *)malloc(sizeof(double)*256); for (i=0; i<256;++i) f[i]=(double)rand()/(double)RAND_MAX+i/64; /*Now copy array into R structs */ PROTECT(rv=allocVector(REALSXP, 256)); defineVar(install("f"), rv, R_GlobalEnv); /* put rv in R's environment and name it "f" */ for (i=0; i<256;++i) REAL(rv)[i] = f[i]; /* fill rv with values */ /* plot that array with R's: plot(f) */ PROTECT(e = lang1(install("x11"))); eval(e, R_GlobalEnv); UNPROTECT(1); PROTECT(e=lang2(install("plot"),install("f"))); eval(e, R_GlobalEnv); UNPROTECT(1); /* calculate the log of the values with log(f) */ PROTECT(e1=lang2(install("log"),install("f"))); PROTECT(e=eval(e1,R_GlobalEnv)); for (i=0; i<256;++i) { if (i<5 || i>250) { printf("%d: log(%f)=%f\n", i, f[i], REAL(e)[i]); } else if (!(i%20)) { printf("..."); } } UNPROTECT(2); /* Now run some R script with source(".../ExamineXmat.R") */ if (!(pp = Add_plausible_path("ExamineXmat.R"))) { fprintf(stderr,"Failed to find ExamineXmat.R\n"); exit(1); } PROTECT(rs=mkString(pp)); defineVar(install("sss"), rs, R_GlobalEnv); fprintf(stderr,"checking on script name: %s\n", STRING_VALUE(rs)); PROTECT(e=lang2(install("source"),install("sss"))); eval(e, R_GlobalEnv); UNPROTECT(2); fprintf(stderr,"Hit enter to proceed\n"); free(pp); pp=NULL; /* Here is should test calling R functions from some functions that we create. I will need to sort out how packges are formed for R and how R can find them on any machine etc. Nuts and bolts... A simple exercise here would be to learn how to construct our R library and call its functions from here ... */ free(f); f = NULL; free(pp); pp=NULL; getchar(); }