SEXP
do_D (SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP expr, var;
var = Rf_install ();
expr = ((args)->u.listsxp.carval);
Rf_protect (expr = D (expr, var));
expr = AddParens (expr);
return expr;
}
static SEXP AddParens(SEXP expr)
{
SEXP e;
if (TYPEOF(expr) == LANGSXP) {
e = CDR(expr);
while(e != R_NilValue) {
SETCAR(e, AddParens(CAR(e)));
e = CDR(e);
}
}
if (isPlusForm(expr)) {
if (isPlusForm(CADDR(expr))) {
SETCADDR(expr, lang2(ParenSymbol, CADDR(expr)));
}
}
else if (isMinusForm(expr)) {
if (isPlusForm(CADDR(expr)) || isMinusForm(CADDR(expr))) {
SETCADDR(expr, lang2(ParenSymbol, CADDR(expr)));
}
}
else if (isTimesForm(expr)) {
if (isPlusForm(CADDR(expr)) || isMinusForm(CADDR(expr))
|| isTimesForm(CADDR(expr)) || isDivideForm(CADDR(expr))) {
SETCADDR(expr, lang2(ParenSymbol, CADDR(expr)));
}
if (isPlusForm(CADR(expr)) || isMinusForm(CADR(expr))) {
SETCADR(expr, lang2(ParenSymbol, CADR(expr)));
}
}
else if (isDivideForm(expr)) {
if (isPlusForm(CADDR(expr)) || isMinusForm(CADDR(expr))
|| isTimesForm(CADDR(expr)) || isDivideForm(CADDR(expr))) {
SETCADDR(expr, lang2(ParenSymbol, CADDR(expr)));
}
if (isPlusForm(CADR(expr)) || isMinusForm(CADR(expr))) {
SETCADR(expr, lang2(ParenSymbol, CADR(expr)));
}
}
else if (isPowerForm(expr)) {
if (isPowerForm(CADR(expr))) {
SETCADR(expr, lang2(ParenSymbol, CADR(expr)));
}
if (isPlusForm(CADDR(expr)) || isMinusForm(CADDR(expr))
|| isTimesForm(CADDR(expr)) || isDivideForm(CADDR(expr))) {
SETCADDR(expr, lang2(ParenSymbol, CADDR(expr)));
}
}
return expr;
}
SEXP doD(SEXP args)
{
SEXP expr, var;
args = CDR(args);
if (isExpression(CAR(args))) expr = VECTOR_ELT(CAR(args), 0);
else expr = CAR(args);
if (!(isLanguage(expr) || isSymbol(expr) || isNumeric(expr) || isComplex(expr)))
error(_("'expr' must be an expression or call"));
var = CADR(args);
if (!isString(var) || length(var) < 1)
error(_("variable must be a character string"));
if (length(var) > 1)
warning(_("only the first element is used as variable name"));
var = installTrChar(STRING_ELT(var, 0));
InitDerivSymbols();
PROTECT(expr = D(expr, var));
expr = AddParens(expr);
UNPROTECT(1);
return expr;
}
SEXP deriv(SEXP args)
{
/* deriv(expr, namevec, function.arg, tag, hessian) */
SEXP ans, ans2, expr, funarg, names, s;
int f_index, *d_index, *d2_index;
int i, j, k, nexpr, nderiv=0, hessian;
SEXP exprlist, tag;
args = CDR(args);
InitDerivSymbols();
PROTECT(exprlist = LCONS(R_BraceSymbol, R_NilValue));
/* expr: */
if (isExpression(CAR(args)))
PROTECT(expr = VECTOR_ELT(CAR(args), 0));
else PROTECT(expr = CAR(args));
args = CDR(args);
/* namevec: */
names = CAR(args);
if (!isString(names) || (nderiv = length(names)) < 1)
error(_("invalid variable names"));
args = CDR(args);
/* function.arg: */
funarg = CAR(args);
args = CDR(args);
/* tag: */
tag = CAR(args);
if (!isString(tag) || length(tag) < 1
|| length(STRING_ELT(tag, 0)) < 1 || length(STRING_ELT(tag, 0)) > 60)
error(_("invalid tag"));
args = CDR(args);
/* hessian: */
hessian = asLogical(CAR(args));
/* NOTE: FindSubexprs is destructive, hence the duplication.
It can allocate, so protect the duplicate.
*/
PROTECT(ans = duplicate(expr));
f_index = FindSubexprs(ans, exprlist, tag);
d_index = (int*)R_alloc((size_t) nderiv, sizeof(int));
if (hessian)
d2_index = (int*)R_alloc((size_t) ((nderiv * (1 + nderiv))/2),
sizeof(int));
else d2_index = d_index;/*-Wall*/
UNPROTECT(1);
for(i=0, k=0; i<nderiv ; i++) {
PROTECT(ans = duplicate(expr));
PROTECT(ans = D(ans, installTrChar(STRING_ELT(names, i))));
PROTECT(ans2 = duplicate(ans)); /* keep a temporary copy */
d_index[i] = FindSubexprs(ans, exprlist, tag); /* examine the derivative first */
PROTECT(ans = duplicate(ans2)); /* restore the copy */
if (hessian) {
for(j = i; j < nderiv; j++) {
PROTECT(ans2 = duplicate(ans)); /* install could allocate */
PROTECT(ans2 = D(ans2, installTrChar(STRING_ELT(names, j))));
d2_index[k] = FindSubexprs(ans2, exprlist, tag);
k++;
UNPROTECT(2);
}
}
UNPROTECT(4);
}
nexpr = length(exprlist) - 1;
if (f_index) {
Accumulate2(MakeVariable(f_index, tag), exprlist);
}
else {
PROTECT(ans = duplicate(expr));
Accumulate2(expr, exprlist);
UNPROTECT(1);
}
Accumulate2(R_NilValue, exprlist);
if (hessian) { Accumulate2(R_NilValue, exprlist); }
for (i = 0, k = 0; i < nderiv ; i++) {
if (d_index[i]) {
Accumulate2(MakeVariable(d_index[i], tag), exprlist);
if (hessian) {
PROTECT(ans = duplicate(expr));
PROTECT(ans = D(ans, installTrChar(STRING_ELT(names, i))));
for (j = i; j < nderiv; j++) {
if (d2_index[k]) {
Accumulate2(MakeVariable(d2_index[k], tag), exprlist);
} else {
PROTECT(ans2 = duplicate(ans));
PROTECT(ans2 = D(ans2, installTrChar(STRING_ELT(names, j))));
Accumulate2(ans2, exprlist);
UNPROTECT(2);
}
k++;
}
UNPROTECT(2);
}
} else { /* the first derivative is constant or simple variable */
PROTECT(ans = duplicate(expr));
PROTECT(ans = D(ans, installTrChar(STRING_ELT(names, i))));
Accumulate2(ans, exprlist);
UNPROTECT(2);
if (hessian) {
for (j = i; j < nderiv; j++) {
if (d2_index[k]) {
Accumulate2(MakeVariable(d2_index[k], tag), exprlist);
} else {
PROTECT(ans2 = duplicate(ans));
PROTECT(ans2 = D(ans2, installTrChar(STRING_ELT(names, j))));
if(isZero(ans2)) Accumulate2(R_MissingArg, exprlist);
else Accumulate2(ans2, exprlist);
UNPROTECT(2);
}
k++;
}
}
}
}
Accumulate2(R_NilValue, exprlist);
Accumulate2(R_NilValue, exprlist);
if (hessian) { Accumulate2(R_NilValue, exprlist); }
i = 0;
ans = CDR(exprlist);
while (i < nexpr) {
if (CountOccurrences(MakeVariable(i+1, tag), CDR(ans)) < 2) {
SETCDR(ans, Replace(MakeVariable(i+1, tag), CAR(ans), CDR(ans)));
SETCAR(ans, R_MissingArg);
}
else {
SEXP var;
PROTECT(var = MakeVariable(i+1, tag));
SETCAR(ans, lang3(install("<-"), var, AddParens(CAR(ans))));
UNPROTECT(1);
}
i = i + 1;
ans = CDR(ans);
}
/* .value <- ... */
SETCAR(ans, lang3(install("<-"), install(".value"), AddParens(CAR(ans))));
ans = CDR(ans);
/* .grad <- ... */
SETCAR(ans, CreateGrad(names));
ans = CDR(ans);
/* .hessian <- ... */
if (hessian) { SETCAR(ans, CreateHess(names)); ans = CDR(ans); }
/* .grad[, "..."] <- ... */
for (i = 0; i < nderiv ; i++) {
SETCAR(ans, DerivAssign(STRING_ELT(names, i), AddParens(CAR(ans))));
ans = CDR(ans);
if (hessian) {
for (j = i; j < nderiv; j++) {
if (CAR(ans) != R_MissingArg) {
if (i == j) {
SETCAR(ans, HessAssign1(STRING_ELT(names, i),
AddParens(CAR(ans))));
} else {
SETCAR(ans, HessAssign2(STRING_ELT(names, i),
STRING_ELT(names, j),
AddParens(CAR(ans))));
}
}
ans = CDR(ans);
}
}
}
/* attr(.value, "gradient") <- .grad */
SETCAR(ans, AddGrad());
ans = CDR(ans);
if (hessian) { SETCAR(ans, AddHess()); ans = CDR(ans); }
/* .value */
SETCAR(ans, install(".value"));
/* Prune the expression list removing eliminated sub-expressions */
SETCDR(exprlist, Prune(CDR(exprlist)));
if (TYPEOF(funarg) == LGLSXP && LOGICAL(funarg)[0]) { /* fun = TRUE */
funarg = names;
}
if (TYPEOF(funarg) == CLOSXP)
{
funarg = mkCLOSXP(FORMALS(funarg), exprlist, CLOENV(funarg));
}
else if (isString(funarg)) {
SEXP formals = allocList(length(funarg));
ans = formals;
for(i = 0; i < length(funarg); i++) {
SET_TAG(ans, installTrChar(STRING_ELT(funarg, i)));
SETCAR(ans, R_MissingArg);
ans = CDR(ans);
}
funarg = mkCLOSXP(formals, exprlist, R_GlobalEnv);
}
else {
funarg = allocVector(EXPRSXP, 1);
SET_VECTOR_ELT(funarg, 0, exprlist);
/* funarg = lang2(install("expression"), exprlist); */
}
UNPROTECT(2);
return funarg;
}
