SEXP attribute_hidden do_envirgets(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP env, s = CAR(args);
checkArity(op, args);
check1arg(args, call, "x");
env = CADR(args);
if (TYPEOF(CAR(args)) == CLOSXP
&& (isEnvironment(env) ||
isEnvironment(env = simple_as_environment(env)) ||
isNull(env))) {
if (isNull(env))
error(_("use of NULL environment is defunct"));
if(MAYBE_SHARED(s))
/* this copies but does not duplicate args or code */
s = duplicate(s);
if (TYPEOF(BODY(s)) == BCODESXP)
/* switch to interpreted version if compiled */
SET_BODY(s, R_ClosureExpr(CAR(args)));
SET_CLOENV(s, env);
}
else if (isNull(env) || isEnvironment(env) ||
isEnvironment(env = simple_as_environment(env)))
setAttrib(s, R_DotEnvSymbol, env);
else
error(_("replacement object is not an environment"));
return s;
}
SEXP attribute_hidden do_parentenvgets(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP env, parent;
checkArity(op, args);
env = CAR(args);
if (isNull(env)) {
error(_("use of NULL environment is defunct"));
env = R_BaseEnv;
} else
if( !isEnvironment(env) &&
!isEnvironment((env = simple_as_environment(env))))
error(_("argument is not an environment"));
if( env == R_EmptyEnv )
error(_("can not set parent of the empty environment"));
if (R_EnvironmentIsLocked(env) && R_IsNamespaceEnv(env))
error(_("can not set the parent environment of a namespace"));
if (R_EnvironmentIsLocked(env) && R_IsImportsEnv(env))
error(_("can not set the parent environment of package imports"));
parent = CADR(args);
if (isNull(parent)) {
error(_("use of NULL environment is defunct"));
parent = R_BaseEnv;
} else
if( !isEnvironment(parent) &&
!isEnvironment((parent = simple_as_environment(parent))))
error(_("'parent' is not an environment"));
SET_ENCLOS(env, parent);
return( CAR(args) );
}
SEXP attribute_hidden do_delayed(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP name = R_NilValue /* -Wall */, expr, eenv, aenv;
checkArity(op, args);
if (!isString(CAR(args)) || length(CAR(args)) == 0)
error(_("invalid first argument"));
else
name = installTrChar(STRING_ELT(CAR(args), 0));
args = CDR(args);
expr = CAR(args);
args = CDR(args);
eenv = CAR(args);
if (isNull(eenv)) {
error(_("use of NULL environment is defunct"));
eenv = R_BaseEnv;
} else
if (!isEnvironment(eenv))
errorcall(call, _("invalid '%s' argument"), "eval.env");
args = CDR(args);
aenv = CAR(args);
if (isNull(aenv)) {
error(_("use of NULL environment is defunct"));
aenv = R_BaseEnv;
} else
if (!isEnvironment(aenv))
errorcall(call, _("invalid '%s' argument"), "assign.env");
defineVar(name, mkPROMISE(expr, eenv), aenv);
return R_NilValue;
}
/** do_newenv() : .Internal(new.env(hash, parent, size))
*
* @return a newly created environment()
*/
SEXP attribute_hidden do_newenv(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP enclos, size, ans;
int hash;
checkArity(op, args);
hash = asInteger(CAR(args));
args = CDR(args);
enclos = CAR(args);
if (isNull(enclos)) {
error(_("use of NULL environment is defunct"));
enclos = R_BaseEnv;
} else
if( !isEnvironment(enclos) &&
!isEnvironment((enclos = simple_as_environment(enclos))))
error(_("'enclos' must be an environment"));
if( hash ) {
args = CDR(args);
PROTECT(size = coerceVector(CAR(args), INTSXP));
if (INTEGER(size)[0] == NA_INTEGER)
INTEGER(size)[0] = 0; /* so it will use the internal default */
ans = R_NewHashedEnv(enclos, size);
UNPROTECT(1);
} else
ans = NewEnvironment(R_NilValue, R_NilValue, enclos);
return ans;
}
/* makeLazy(names, values, expr, eenv, aenv) */
SEXP attribute_hidden do_makelazy(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP names, values, val, expr, eenv, aenv, expr0;
R_xlen_t i;
checkArity(op, args);
names = CAR(args); args = CDR(args);
if (!isString(names))
error(_("invalid first argument"));
values = CAR(args); args = CDR(args);
expr = CAR(args); args = CDR(args);
eenv = CAR(args); args = CDR(args);
if (!isEnvironment(eenv)) error(_("invalid '%s' argument"), "eval.env");
aenv = CAR(args);
if (!isEnvironment(aenv)) error(_("invalid '%s' argument"), "assign.env");
for(i = 0; i < XLENGTH(names); i++) {
SEXP name = installChar(STRING_ELT(names, i));
PROTECT(val = eval(VECTOR_ELT(values, i), eenv));
PROTECT(expr0 = duplicate(expr));
SETCAR(CDR(expr0), val);
defineVar(name, mkPROMISE(expr0, eenv), aenv);
UNPROTECT(2);
}
return R_NilValue;
}
SEXP attribute_hidden do_parentenv(SEXP call, SEXP op, SEXP args, SEXP rho)
{
checkArity(op, args);
SEXP arg = CAR(args);
if( !isEnvironment(arg) &&
!isEnvironment((arg = simple_as_environment(arg))))
error( _("argument is not an environment"));
if( arg == R_EmptyEnv )
error(_("the empty environment has no parent"));
return( ENCLOS(arg) );
}
SEXP get_function_from_env_attrib(SEXP x, SEXP attribSym, SEXP nameSym) {
SEXP methods_env = Rf_getAttrib(x, attribSym);
if (isEnvironment(methods_env)) {
return Rf_findVarInFrame(methods_env, nameSym);
}
return R_NilValue;
}
SEXP CHM_set_common_env(SEXP rho) {
if (!isEnvironment(rho))
error(_("Argument rho must be an environment"));
chm_common_env = rho;
dboundSym = install("dbound");
grow0Sym = install("grow0");
grow1Sym = install("grow1");
grow2Sym = install("grow2");
maxrankSym = install("maxrank");
supernodal_switchSym = install("supernodal_switch");
supernodalSym = install("supernodal");
final_asisSym = install("final_asis");
final_superSym = install("final_super");
final_llSym = install("final_ll");
final_packSym = install("final_pack");
final_monotonicSym = install("final_monotonic");
final_resymbolSym = install("final_resymbol");
prefer_zomplexSym = install("final_zomplex");
prefer_upperSym = install("final_upper");
quick_return_if_not_posdefSym = install("quick_return_if_not_posdef");
nmethodsSym = install("nmethods");
m0_ordSym = install("m0.ord");
postorderSym = install("postorder");
CHM_store_common();
return R_NilValue;
}
SEXP port_nlminb(SEXP fn, SEXP gr, SEXP hs, SEXP rho,
SEXP lowerb, SEXP upperb, SEXP d, SEXP iv, SEXP v)
{
int i, n = LENGTH(d);
SEXP xpt;
double *b = (double *) NULL, *g = (double *) NULL,
*h = (double *) NULL, fx = R_PosInf;
if (isNull(rho)) {
error(_("use of NULL environment is defunct"));
rho = R_BaseEnv;
} else
if (!isEnvironment(rho))
error(_("'rho' must be an environment"));
if (!isReal(d) || n < 1)
error(_("'d' must be a nonempty numeric vector"));
if (hs != R_NilValue && gr == R_NilValue)
error(_("When Hessian defined must also have gradient defined"));
if (R_NilValue == (xpt = findVarInFrame(rho, install(".par"))) ||
!isReal(xpt) || LENGTH(xpt) != n)
error(_("environment 'rho' must contain a numeric vector '.par' of length %d"),
n);
/* We are going to alter .par, so must duplicate it */
defineVar(install(".par"), duplicate(xpt), rho);
PROTECT(xpt = findVarInFrame(rho, install(".par")));
if ((LENGTH(lowerb) == n) && (LENGTH(upperb) == n)) {
if (isReal(lowerb) && isReal(upperb)) {
double *rl=REAL(lowerb), *ru=REAL(upperb);
b = Calloc(2*n, double);
for (i = 0; i < n; i++) {
b[2*i] = rl[i];
b[2*i + 1] = ru[i];
}
} else error(_("'lower' and 'upper' must be numeric vectors"));
SEXP bcplm_metrop_rw(SEXP n, SEXP m, SEXP sd, SEXP lb, SEXP rb,
SEXP fun, SEXP rho){
mh_str *da;
SEXP ans, acc;
double sm; /* the mean used in each iteration */
int ns = INTEGER(n)[0];
if (!isFunction(fun)) error(("'fun' is not a function"));
if (!isEnvironment(rho)) error(("'rho'is not an environment"));
/* construct the mh_str object */
da = (mh_str *) R_alloc(1, sizeof(mh_str));
PROTECT(da->R_fcall = lang2(fun, R_NilValue));
da->R_env = rho;
/* run the random walk metropolis algorithm */
PROTECT(ans = allocVector(REALSXP, ns));
PROTECT(acc = allocVector(INTSXP, 1));
INTEGER(acc)[0] = 0;
GetRNGstate();
for (int i = 0; i < ns; i++){
sm = (i) ? REAL(ans)[i - 1] : REAL(m)[0];
INTEGER(acc)[0] += metrop_tnorm_rw(sm, REAL(sd)[0], REAL(lb)[0], REAL(rb)[0],
REAL(ans) + i, R_fun, da);
}
setAttrib(ans, install("accept"), acc);
UNPROTECT(3);
PutRNGstate();
return ans;
}
SEXP rpy_remove(SEXP symbol, SEXP env, SEXP rho)
{
SEXP c_R, call_R, res, fun_R;
PROTECT(fun_R = rpy_findFun(install("rm"), rho));
if(!isEnvironment(rho)) error("'rho' should be an environment");
/* incantation to summon R */
PROTECT(c_R = call_R = allocList(2+1));
SET_TYPEOF(c_R, LANGSXP);
SETCAR(c_R, fun_R);
c_R = CDR(c_R);
/* first argument is the name of the variable to be removed */
SETCAR(c_R, symbol);
//SET_TAG(c_R, install("list"));
c_R = CDR(c_R);
/* second argument is the environment in which the variable
should be removed */
SETCAR(c_R, env);
SET_TAG(c_R, install("envir"));
c_R = CDR(c_R);
int error = 0;
PROTECT(res = R_tryEval(call_R, rho, &error));
UNPROTECT(3);
return res;
}
SEXP librinterface_remove(SEXP symbol, SEXP env, SEXP rho)
{
SEXP c_R, call_R, res;
static SEXP fun_R = NULL;
/* Only fetch rm() the first time */
if (fun_R == NULL) {
PROTECT(fun_R = librinterface_FindFun(install("rm"), rho));
R_PreserveObject(fun_R);
UNPROTECT(1);
}
if(!isEnvironment(rho)) error("'rho' should be an environment");
/* incantation to summon R */
PROTECT(c_R = call_R = allocList(2+1));
SET_TYPEOF(c_R, LANGSXP);
SETCAR(c_R, fun_R);
c_R = CDR(c_R);
/* first argument is the name of the variable to be removed */
SETCAR(c_R, symbol);
//SET_TAG(c_R, install("list"));
c_R = CDR(c_R);
/* second argument is the environment in which the variable
should be removed */
SETCAR(c_R, env);
SET_TAG(c_R, install("envir"));
c_R = CDR(c_R);
int error = 0;
PROTECT(res = R_tryEval(call_R, rho, &error));
UNPROTECT(3);
return res;
}
SEXP subset_R8(SEXP x, SEXP name) {
// Look in x (an environment) for the object
SEXP nameSym = Rf_install(CHAR(STRING_ELT(name, 0)));
SEXP foundVar = Rf_findVarInFrame(x, nameSym);
if (foundVar != R_UnboundValue) {
return foundVar;
}
// if not found in x, look in methods
SEXP fun = get_function_from_env_attrib(x, Rf_install("methods"), nameSym);
// If not found in methods, search in methods2. This is present only for
// storing private methods in a superclass.
if (!isFunction(fun)) {
fun = get_function_from_env_attrib(x, Rf_install("methods2"), nameSym);
}
if (!isFunction(fun)) {
return R_NilValue;
}
// Make a copy of the function, with a new environment
SEXP fun2 = PROTECT(duplicate(fun));
SEXP eval_env = Rf_getAttrib(x, Rf_install("eval_env"));
if (!isEnvironment(eval_env)) {
UNPROTECT(1);
return R_NilValue;
}
SET_CLOENV(fun2, eval_env);
UNPROTECT(1);
return fun2;
}
/* -------- getvar from environment ------------------------------------------*/
SEXP getvar(SEXP name, SEXP Rho) {
SEXP ans;
if(!isString(name) || length(name) != 1)
error("name is not a single string");
if(!isEnvironment(Rho))
error("Rho should be an environment");
ans = findVar(install(CHAR(STRING_ELT(name, 0))), Rho);
return(ans);
}
//get from the R doc! (see the R doc for further explanation)
SEXP C_getVarInEnvir(char* name, SEXP rho) {
SEXP ans;
//if(!isString(name) || length(name) != 1) error("name is not a single string");
if(!isEnvironment(rho)) error("rho should be an environment");
ans = findVar(install(name), rho);
//Rprintf("first value is %f\n", REAL(ans)[0]);
return(ans);
}
SEXP rzmq_unserialize(SEXP data, SEXP rho) {
static SEXP R_unserialize_fun = findVar(install("unserialize"), R_GlobalEnv);
SEXP R_fcall, ans;
if(!isEnvironment(rho)) error("'rho' should be an environment");
PROTECT(R_fcall = lang2(R_unserialize_fun, data));
PROTECT(ans = eval(R_fcall, rho));
UNPROTECT(2);
return ans;
}
SEXP getvar(SEXP name, SEXP rho)
{
SEXP ans;
if(!isString(name) || length(name) != 1)
error("name is not a single string");
if(!isEnvironment(rho))
error("rho should be an environment");
ans = findVar(install(CHAR(STRING_ELT(name, 0))), rho);
printf("first value is %f\n", REAL(ans)[0]);
return(R_NilValue);
}
SEXP rpy_devoff(SEXP devnum, SEXP rho)
{
SEXP c_R, call_R, res, fun_R;
#ifdef RPY_DEBUG_GRDEV
printf("rpy_devoff(): checking 'rho'.\n");
#endif
if(!isEnvironment(rho)) {
#ifdef RPY_DEBUG_GRDEV
printf("rpy_devoff(): invalid 'rho'.\n");
#endif
error("'rho' should be an environment\n");
}
#ifdef RPY_DEBUG_GRDEV
printf("rpy_devoff(): Looking for dev.off()...\n");
#endif
PROTECT(fun_R = rpy2_findfun(install("dev.off"), rho));
if (fun_R == R_UnboundValue)
printf("dev.off() could not be found.\n");
#ifdef RPY_DEBUG_GRDEV
printf("rpy_devoff(): found.\n");
#endif
/* incantation to summon R */
PROTECT(c_R = call_R = allocList(2));
SET_TYPEOF(c_R, LANGSXP);
SETCAR(c_R, fun_R);
c_R = CDR(c_R);
/* first argument is the device number to be closed */
SETCAR(c_R, devnum);
SET_TAG(c_R, install("which"));
c_R = CDR(c_R);
int error = 0;
#ifdef RPY_DEBUG_GRDEV
printf("rpy_devoff(): R_tryEval()\n");
#endif
PROTECT(res = R_tryEval(call_R, rho, &error));
#ifdef RPY_DEBUG_GRDEV
printf("rpy_devoff(): unprotecting.\n");
#endif
UNPROTECT(3);
return res;
}
static void getParseFilename(char* buffer, size_t buflen)
{
buffer[0] = '\0';
if (R_ParseErrorFile) {
if (isEnvironment(R_ParseErrorFile)) {
SEXP filename;
PROTECT(filename = findVar(install("filename"), R_ParseErrorFile));
if (isString(filename) && length(filename))
strncpy(buffer, CHAR(STRING_ELT(filename, 0)), buflen - 1);
UNPROTECT(1);
} else if (isString(R_ParseErrorFile) && length(R_ParseErrorFile))
strncpy(buffer, CHAR(STRING_ELT(R_ParseErrorFile, 0)), buflen - 1);
}
}
R_init_splusTimeSeries(DllInfo *dll)
{
R_registerRoutines(dll, cMethods, NULL, NULL, NULL);
R_useDynamicSymbols(dll, FALSE);
/* These are callable from other packages' C code: */
#define RREGDEF(name) R_RegisterCCallable("splusTimeSeries", #name, (DL_FUNC) name)
splusTimeSeries_NS = R_FindNamespace(mkString("splusTimeSeries"));
if(splusTimeSeries_NS == R_UnboundValue)
error("missing 'splusTimeSeries' namespace: should never happen");
#ifdef DEBUG_splusTimeSeries
if(isEnvironment(splusTimeSeries_NS))
Rprintf("splusTimeSeries_NS: %s\n",
CHAR(asChar(eval(lang2(install("format"),splusTimeSeries_NS),
R_GlobalEnv))));
else
#else
if(!isEnvironment(splusTimeSeries_NS))
#endif
error("splusTimeSeries namespace not determined correctly");
}
SEXP lapply(SEXP list, SEXP expr, SEXP rho)
{
int i, n = length(list);
SEXP ans;
if(!isNewList(list)) error("`list' must be a list");
if(!isEnvironment(rho)) error("`rho' should be an environment");
PROTECT(ans = allocVector(VECSXP, n));
for(i = 0; i < n; i++) {
defineVar(install("x"), VECTOR_ELT(list, i), rho);
SET_VECTOR_ELT(ans, i, eval(expr, rho));
}
setAttrib(ans, R_NamesSymbol, getAttrib(list, R_NamesSymbol));
UNPROTECT(1);
return(ans);
}
static Rboolean R_IsImportsEnv(SEXP env)
{
if (isNull(env) || !isEnvironment(env))
return FALSE;
if (ENCLOS(env) != R_BaseNamespace)
return FALSE;
SEXP name = getAttrib(env, R_NameSymbol);
if (!isString(name) || length(name) != 1)
return FALSE;
const char *imports_prefix = "imports:";
const char *name_string = CHAR(STRING_ELT(name, 0));
if (!strncmp(name_string, imports_prefix, strlen(imports_prefix)))
return TRUE;
else
return FALSE;
}
SEXP lapply2(SEXP list, SEXP fn, SEXP rho)
{
int i, n = length(list);
SEXP R_fcall, ans;
if(!isNewList(list)) error("`list' must be a list");
if(!isFunction(fn)) error("`fn' must be a function");
if(!isEnvironment(rho)) error("`rho' should be an environment");
PROTECT(R_fcall = lang2(fn, R_NilValue));
PROTECT(ans = allocVector(VECSXP, n));
for(i = 0; i < n; i++) {
SETCADR(R_fcall, VECTOR_ELT(list, i));
SET_VECTOR_ELT(ans, i, eval(R_fcall, rho));
}
setAttrib(ans, R_NamesSymbol, getAttrib(list, R_NamesSymbol));
UNPROTECT(2);
return(ans);
}
SEXP rpy_unserialize(SEXP connection, SEXP rho)
{
SEXP c_R, call_R, res, fun_R;
PROTECT(fun_R = rpy_findFun(install("unserialize"), rho));
if(!isEnvironment(rho)) error("'rho' should be an environment");
/* obscure incatation to summon R */
PROTECT(c_R = call_R = allocList(2));
SET_TYPEOF(c_R, LANGSXP);
SETCAR(c_R, fun_R);
c_R = CDR(c_R);
/* first argument is a RAWSXP representation of the object to unserialize */
SETCAR(c_R, connection);
c_R = CDR(c_R);
PROTECT(res = eval(call_R, rho));
UNPROTECT(2);
return res;
}
int Inspect(char* str, int len, Object* object){
if( isNil(object) )
return InspectNil(str, len, object);
if( isConsCell(object) )
return InspectConsCell(str, len, object);
if( isSymbol(object) )
return InspectSymbol(str, len, object);
if( isInteger(object) )
return InspectInteger(str, len, object);
if( isLambda(object) )
return InspectLambda(str, len, object);
if( isPrimitiveFunc(object) )
return InspectPrimitiveFunc(str, len, object);
if( isContinuation(object) )
return InspectContinuation(str, len, object);
if( isEnvironment(object) )
return InspectEnvironment(str, len, object);
if( isBool(object) )
return InspectBool(str, len, object);
if( isSpecialForm(object) )
return InspectSpecialForm(str, len, object);
if( isCondition(object) )
return InspectCondition(str, len, object);
if( isCharacter(object) )
return InspectCharacter(str, len, object);
else
return InspectUnknown(str, len, object);
}
void redux_redis_subscribe_loop(redisContext* context, int pattern,
SEXP callback, SEXP envir) {
if (!isFunction(callback)) {
error("'callback' must be a function");
}
if (!isEnvironment(envir)) {
error("'envir' must be an environment");
}
SEXP call = PROTECT(lang2(callback, R_NilValue));
redisReply *reply = NULL;
int keep_going = 1;
// Nasty:
SEXP nms = PROTECT(allocVector(STRSXP, pattern ? 4 : 3));
int i = 0;
SET_STRING_ELT(nms, i++, mkChar("type"));
if (pattern) {
SET_STRING_ELT(nms, i++, mkChar("pattern"));
}
SET_STRING_ELT(nms, i++, mkChar("channel"));
SET_STRING_ELT(nms, i++, mkChar("value"));
// And we're off. Adding a timeout here seems sensible to me as
// that would allow for _some_ sort of interrupt checking, but as it
// is, this seems extremely difficult to do without risking killing
// the client.
while (keep_going) {
R_CheckUserInterrupt();
redisGetReply(context, (void*)&reply);
SEXP x = PROTECT(redis_reply_to_sexp(reply, REPLY_ERROR_OK));
setAttrib(x, R_NamesSymbol, nms);
SETCADR(call, x);
freeReplyObject(reply);
SEXP val = PROTECT(eval(call, envir));
if (TYPEOF(val) == LGLSXP && LENGTH(val) == 1 && INTEGER(val)[0] == 1) {
keep_going = 0;
}
UNPROTECT(2); // x, val
}
UNPROTECT(2); // nms, call
}
int Describe(char* str, int len, Object* object){
if( isNil(object) )
return DescribeNil(str, len, object);
if( isConsCell(object) )
return DescribeConsCell(str, len, object);
if( isSymbol(object) )
return DescribeSymbol(str, len, object);
if( isInteger(object) )
return DescribeInteger(str, len, object);
if( isLambda(object) )
return DescribeLambda(str, len, object);
if( isPrimitiveFunc(object) )
return DescribePrimitiveFunc(str, len, object);
if( isContinuation(object) )
return DescribeContinuation(str, len, object);
if( isEnvironment(object) )
return DescribeEnvironment(str, len, object);
if( isBool(object) )
return DescribeBool(str, len, object);
if( isSpecialForm(object) )
return DescribeSpecialForm(str, len, object);
if( isCondition(object) )
return DescribeCondition(str, len, object);
if( isCharacter(object) )
return DescribeCharacter(str, len, object);
else
return DescribeUnknown(str, len, object);
}
SEXP loop_apply(SEXP n, SEXP f, SEXP rho) {
if(!isFunction(f)) error("'f' must be a function");
if(!isEnvironment(rho)) error("'rho' should be an environment");
int n1 = INTEGER(n)[0];
SEXP results, R_fcall;
PROTECT(results = allocVector(VECSXP, n1));
PROTECT(R_fcall = lang2(f, R_NilValue));
SEXP ii;
for(int i = 0; i < n1; i++) {
PROTECT(ii = ScalarInteger(i + 1));
SETCADR(R_fcall, ii);
SET_VECTOR_ELT(results, i, eval(R_fcall, rho));
UNPROTECT(1);
}
UNPROTECT(2);
return results;
}
SEXP rpy_serialize(SEXP object, SEXP rho)
{
SEXP c_R, call_R, res, fun_R;
PROTECT(fun_R = rpy_findFun(install("serialize"), rho));
if(!isEnvironment(rho)) error("'rho' should be an environment");
/* obscure incatation to summon R */
PROTECT(c_R = call_R = allocList(3));
SET_TYPEOF(c_R, LANGSXP);
SETCAR(c_R, fun_R);
c_R = CDR(c_R);
/* first argument is the SEXP object to serialize */
SETCAR(c_R, object);
c_R = CDR(c_R);
/* second argument is NULL */
SETCAR(c_R, R_NilValue);
c_R = CDR(c_R);
PROTECT(res = eval(call_R, rho));
UNPROTECT(3);
return res;
}
SEXP numeric_deriv(SEXP args)
{
SEXP theta, expr, rho, ans, ans1, gradient, par, dimnames;
double tt, xx, delta, eps = sqrt(DOUBLE_EPS);
int start, i, j;
expr = CADR(args);
if(!isString(theta = CADDR(args)))
error("theta should be of type character");
if(!isEnvironment(rho = CADDDR(args)))
error("rho should be an environment");
PROTECT(ans = coerceVector(eval(expr, rho), REALSXP));
PROTECT(gradient = allocMatrix(REALSXP, LENGTH(ans), LENGTH(theta)));
for(i = 0, start = 0; i < LENGTH(theta); i++, start += LENGTH(ans)) {
PROTECT(par = findVar(install(CHAR(STRING_ELT(theta, i))), rho));
tt = REAL(par)[0];
xx = fabs(tt);
delta = (xx < 1) ? eps : xx*eps;
REAL(par)[0] += delta;
PROTECT(ans1 = coerceVector(eval(expr, rho), REALSXP));
for(j = 0; j < LENGTH(ans); j++)
REAL(gradient)[j + start] =
(REAL(ans1)[j] - REAL(ans)[j])/delta;
REAL(par)[0] = tt;
UNPROTECT(2); /* par, ans1 */
}
PROTECT(dimnames = allocVector(VECSXP, 2));
SET_VECTOR_ELT(dimnames, 1, theta);
dimnamesgets(gradient, dimnames);
setAttrib(ans, install("gradient"), gradient);
UNPROTECT(3); /* ans gradient dimnames */
return ans;
}
