SEXP interp_walk(SEXP x, SEXP env, SEXP data) {
if (!Rf_isLanguage(x))
return x;
if (is_call_to(x, "uq")) {
SEXP uq_call = PROTECT(Rf_lang3(Rf_install("uq"), CADR(x), data));
SEXP res = PROTECT(Rf_eval(uq_call, env));
UNPROTECT(2);
return res;
}
if (is_call_to(x, "uqf")) {
return Rf_eval(x, env);
}
// Recursive case
for(SEXP cur = x; cur != R_NilValue; cur = CDR(cur)) {
SETCAR(cur, interp_walk(CAR(cur), env, data));
SEXP nxt = CDR(cur);
if (is_call_to(CAR(nxt), "uqs")) {
// uqs() does error checking and returns a pair list
SEXP args_pl = Rf_eval(CAR(nxt), env);
// Insert args_pl into existing pairlist of args
SEXP last_arg = findLast(args_pl);
SETCDR(last_arg, CDR(nxt));
SETCDR(cur, args_pl);
}
}
return x;
}
static float eval_dist(feature_t *f1, feature_t *f2) {
double *x = REAL(cf1), *y = REAL(cf2);
int i;
for (i = 0; i < FDIM; i++) {
x[i] = f1->loc[i];
y[i] = f2->loc[i];
}
SEXP res = Rf_eval(Rf_lang3(dist_clos, cf1, cf2), R_GlobalEnv);
if (TYPEOF(res) == INTSXP && LENGTH(res) == 1)
return (float) (INTEGER(res)[0]);
if (TYPEOF(res) != REALSXP || LENGTH(res) != 1)
Rf_error("invalid distance result - must be a numeric vector of length one");
return (float)(REAL(res)[0]);
}
// Evaluator
SEXP Rcpp_eval__impl(SEXP expr_, SEXP env) {
RCPP_DEBUG( "Rcpp_eval( expr = <%p>, env = <%p> )", expr_, env )
Scoped<SEXP> expr = expr_ ;
reset_current_error() ;
Environment RCPP = Environment::Rcpp11_namespace();
static SEXP tryCatchSym = NULL, evalqSym, conditionMessageSym, errorRecorderSym, errorSym ;
if (!tryCatchSym) {
tryCatchSym = ::Rf_install("tryCatch");
evalqSym = ::Rf_install("evalq");
conditionMessageSym = ::Rf_install("conditionMessage");
errorRecorderSym = ::Rf_install(".rcpp_error_recorder");
errorSym = ::Rf_install("error");
}
RCPP_DEBUG( " [Rcpp_eval] RCPP = " )
Scoped<SEXP> call = Rf_lang3(
tryCatchSym,
Rf_lang3( evalqSym, expr, env ),
errorRecorderSym
) ;
SET_TAG( CDDR(call), errorSym ) ;
/* call the tryCatch call */
Scoped<SEXP> res = ::Rf_eval( call, RCPP );
if( error_occured() ) {
Scoped<SEXP> current_error = rcpp_get_current_error() ;
Scoped<SEXP> conditionMessageCall = ::Rf_lang2(conditionMessageSym, current_error) ;
Scoped<SEXP> condition_message = ::Rf_eval(conditionMessageCall, R_GlobalEnv) ;
std::string message(CHAR(::Rf_asChar(condition_message)));
throw eval_error(message) ;
}
return res ;
}
static SEXP
simplify (SEXP fun, SEXP arg1, SEXP arg2)
{
SEXP ans;
if (fun == PlusSymbol)
{
if (isZero (arg1))
ans = arg2;
else if (isUminus (arg1))
ans =
simplify (MinusSymbol, arg2,
((((arg1)->u.listsxp.cdrval))->u.listsxp.carval));
else if (isUminus (arg2))
ans =
simplify (MinusSymbol, arg1,
((((arg2)->u.listsxp.cdrval))->u.listsxp.carval));
}
else if (fun == DivideSymbol)
{
ans = Rf_lang3 (DivideSymbol, arg1, arg2);
}
return ans;
}
/* D() implements the "derivative table" : */
static SEXP D(SEXP expr, SEXP var)
{
#define PP_S(F,a1,a2) PP(simplify(F,a1,a2))
#define PP_S2(F,a1) PP(simplify(F,a1, R_MissingArg))
SEXP ans = R_NilValue, expr1, expr2;
switch(TYPEOF(expr)) {
case LGLSXP:
case INTSXP:
case REALSXP:
case CPLXSXP:
ans = Constant(0);
break;
case SYMSXP:
if (expr == var) ans = Constant(1.);
else ans = Constant(0.);
break;
case LISTSXP:
if (inherits(expr, "expression")) ans = D(CAR(expr), var);
else ans = Constant(NA_REAL);
break;
case LANGSXP:
if (CAR(expr) == ParenSymbol) {
ans = D(CADR(expr), var);
}
else if (CAR(expr) == PlusSymbol) {
if (length(expr) == 2)
ans = D(CADR(expr), var);
else {
ans = simplify(PlusSymbol,
PP(D(CADR(expr), var)),
PP(D(CADDR(expr), var)));
UNPROTECT(2);
}
}
else if (CAR(expr) == MinusSymbol) {
if (length(expr) == 2) {
ans = simplify(MinusSymbol,
PP(D(CADR(expr), var)),
R_MissingArg);
UNPROTECT(1);
}
else {
ans = simplify(MinusSymbol,
PP(D(CADR(expr), var)),
PP(D(CADDR(expr), var)));
UNPROTECT(2);
}
}
else if (CAR(expr) == TimesSymbol) {
ans = simplify(PlusSymbol,
PP_S(TimesSymbol,PP(D(CADR(expr),var)), CADDR(expr)),
PP_S(TimesSymbol,CADR(expr), PP(D(CADDR(expr),var))));
UNPROTECT(4);
}
else if (CAR(expr) == DivideSymbol) {
PROTECT(expr1 = D(CADR(expr), var));
PROTECT(expr2 = D(CADDR(expr), var));
ans = simplify(MinusSymbol,
PP_S(DivideSymbol, expr1, CADDR(expr)),
PP_S(DivideSymbol,
PP_S(TimesSymbol, CADR(expr), expr2),
PP_S(PowerSymbol,CADDR(expr),PP(Constant(2.)))));
UNPROTECT(7);
}
else if (CAR(expr) == PowerSymbol) {
if (isLogical(CADDR(expr)) || isNumeric(CADDR(expr))) {
ans = simplify(TimesSymbol,
CADDR(expr),
PP_S(TimesSymbol,
PP(D(CADR(expr), var)),
PP_S(PowerSymbol,
CADR(expr),
PP(Constant(asReal(CADDR(expr))-1.)))));
UNPROTECT(4);
}
else {
expr1 = simplify(TimesSymbol,
PP_S(PowerSymbol,
CADR(expr),
PP_S(MinusSymbol,
CADDR(expr),
PP(Constant(1.0)))),
PP_S(TimesSymbol,
CADDR(expr),
PP(D(CADR(expr), var))));
UNPROTECT(5);
PROTECT(expr1);
expr2 = simplify(TimesSymbol,
PP_S(PowerSymbol, CADR(expr), CADDR(expr)),
PP_S(TimesSymbol,
PP_S2(LogSymbol, CADR(expr)),
PP(D(CADDR(expr), var))));
UNPROTECT(4);
PROTECT(expr2);
ans = simplify(PlusSymbol, expr1, expr2);
UNPROTECT(2);
}
}
else if (CAR(expr) == ExpSymbol) {
ans = simplify(TimesSymbol,
expr,
PP(D(CADR(expr), var)));
UNPROTECT(1);
}
else if (CAR(expr) == LogSymbol) {
if (length(expr) != 2)
error("only single-argument calls are supported");
ans = simplify(DivideSymbol,
PP(D(CADR(expr), var)),
CADR(expr));
UNPROTECT(1);
}
else if (CAR(expr) == CosSymbol) {
ans = simplify(TimesSymbol,
PP_S2(SinSymbol, CADR(expr)),
PP_S2(MinusSymbol, PP(D(CADR(expr), var))));
UNPROTECT(3);
}
else if (CAR(expr) == SinSymbol) {
ans = simplify(TimesSymbol,
PP_S2(CosSymbol, CADR(expr)),
PP(D(CADR(expr), var)));
UNPROTECT(2);
}
else if (CAR(expr) == TanSymbol) {
ans = simplify(DivideSymbol,
PP(D(CADR(expr), var)),
PP_S(PowerSymbol,
PP_S2(CosSymbol, CADR(expr)),
PP(Constant(2.0))));
UNPROTECT(4);
}
else if (CAR(expr) == CoshSymbol) {
ans = simplify(TimesSymbol,
PP_S2(SinhSymbol, CADR(expr)),
PP(D(CADR(expr), var)));
UNPROTECT(2);
}
else if (CAR(expr) == SinhSymbol) {
ans = simplify(TimesSymbol,
PP_S2(CoshSymbol, CADR(expr)),
PP(D(CADR(expr), var))),
UNPROTECT(2);
}
else if (CAR(expr) == TanhSymbol) {
ans = simplify(DivideSymbol,
PP(D(CADR(expr), var)),
PP_S(PowerSymbol,
PP_S2(CoshSymbol, CADR(expr)),
PP(Constant(2.0))));
UNPROTECT(4);
}
else if (CAR(expr) == SqrtSymbol) {
PROTECT(expr1 = Rf_lang3(PowerSymbol, CADR(expr), Constant(0.5)));
ans = D(expr1, var);
UNPROTECT(1);
}
else if (CAR(expr) == PnormSymbol) {
ans = simplify(TimesSymbol,
PP_S2(DnormSymbol, CADR(expr)),
PP(D(CADR(expr), var)));
UNPROTECT(2);
}
else if (CAR(expr) == DnormSymbol) {
ans = simplify(TimesSymbol,
PP_S2(MinusSymbol, CADR(expr)),
PP_S(TimesSymbol,
PP_S2(DnormSymbol, CADR(expr)),
PP(D(CADR(expr), var))));
UNPROTECT(4);
}
else if (CAR(expr) == AsinSymbol) {
ans = simplify(DivideSymbol,
PP(D(CADR(expr), var)),
PP_S(SqrtSymbol,
PP_S(MinusSymbol, PP(Constant(1.)),
PP_S(PowerSymbol,CADR(expr),PP(Constant(2.)))),
R_MissingArg));
UNPROTECT(6);
}
else if (CAR(expr) == AcosSymbol) {
ans = simplify(MinusSymbol,
PP_S(DivideSymbol,
PP(D(CADR(expr), var)),
PP_S(SqrtSymbol,
PP_S(MinusSymbol,PP(Constant(1.)),
PP_S(PowerSymbol,
CADR(expr),PP(Constant(2.)))),
R_MissingArg)), R_MissingArg);
UNPROTECT(7);
}
else if (CAR(expr) == AtanSymbol) {
ans = simplify(DivideSymbol,
PP(D(CADR(expr), var)),
PP_S(PlusSymbol,PP(Constant(1.)),
PP_S(PowerSymbol, CADR(expr),PP(Constant(2.)))));
UNPROTECT(5);
}
else if (CAR(expr) == LGammaSymbol) {
ans = simplify(TimesSymbol,
PP(D(CADR(expr), var)),
PP_S2(DiGammaSymbol, CADR(expr)));
UNPROTECT(2);
}
else if (CAR(expr) == GammaSymbol) {
ans = simplify(TimesSymbol,
PP(D(CADR(expr), var)),
PP_S(TimesSymbol,
expr,
PP_S2(DiGammaSymbol, CADR(expr))));
UNPROTECT(3);
}
else if (CAR(expr) == DiGammaSymbol) {
ans = simplify(TimesSymbol,
PP(D(CADR(expr), var)),
PP_S2(TriGammaSymbol, CADR(expr)));
UNPROTECT(2);
}
else if (CAR(expr) == TriGammaSymbol) {
ans = simplify(TimesSymbol,
PP(D(CADR(expr), var)),
PP_S(PsiSymbol, CADR(expr), PP(ScalarInteger(2))));
UNPROTECT(3);
}
else if (CAR(expr) == PsiSymbol) {
if (length(expr) == 2){
ans = simplify(TimesSymbol,
PP(D(CADR(expr), var)),
PP_S(PsiSymbol, CADR(expr), PP(ScalarInteger(1))));
UNPROTECT(3);
} else if (TYPEOF(CADDR(expr)) == INTSXP ||
TYPEOF(CADDR(expr)) == REALSXP) {
ans = simplify(TimesSymbol,
PP(D(CADR(expr), var)),
PP_S(PsiSymbol,
CADR(expr),
PP(ScalarInteger(asInteger(CADDR(expr))+1))));
UNPROTECT(3);
} else {
ans = simplify(TimesSymbol,
PP(D(CADR(expr), var)),
PP_S(PsiSymbol,
CADR(expr),
simplify(PlusSymbol, CADDR(expr),
PP(ScalarInteger(1)))));
UNPROTECT(3);
}
}
else {
SEXP u = deparse1(CAR(expr), 0, SIMPLEDEPARSE);
error(_("Function '%s' is not in the derivatives table"),
translateChar(STRING_ELT(u, 0)));
}
break;
default:
ans = Constant(NA_REAL);
}
return ans;
#undef PP_S
} /* D() */