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();
}
