/* This is used for [[ and [[<- with a vector of indices of length > 1 .
x is a list or pairlist, and it is indexed recusively from
level start to level stop-1. ( 0...len-1 or 0..len-2 then len-1).
For [[<- it needs to duplicate if substructure might be shared.
*/
SEXP attribute_hidden
vectorIndex(SEXP x, SEXP thesub, int start, int stop, int pok, SEXP call,
Rboolean dup)
{
int i;
R_xlen_t offset;
SEXP cx;
/* sanity check */
if (dup && MAYBE_SHARED(x))
error("should only be called in an assignment context.");
for(i = start; i < stop; i++) {
if(!isVectorList(x) && !isPairList(x)) {
if (i)
errorcall(call, _("recursive indexing failed at level %d\n"), i+1);
else
errorcall(call, _("attempt to select more than one element"));
}
PROTECT(x);
SEXP names = PROTECT(getAttrib(x, R_NamesSymbol));
offset = get1index(thesub, names,
xlength(x), pok, i, call);
UNPROTECT(2); /* x, names */
if(offset < 0 || offset >= xlength(x))
errorcall(call, _("no such index at level %d\n"), i+1);
if(isPairList(x)) {
#ifdef LONG_VECTOR_SUPPORT
if (offset > R_SHORT_LEN_MAX)
error("invalid subscript for pairlist");
#endif
cx = nthcdr(x, (int) offset);
if (NAMED(x) > NAMED(CAR(cx)))
SET_NAMED(CAR(x), NAMED(x));
x = CAR(cx);
if (dup && MAYBE_SHARED(x)) {
x = shallow_duplicate(x);
SETCAR(cx, x);
}
} else {
cx = x;
x = VECTOR_ELT(x, offset);
if (NAMED(cx) > NAMED(x))
SET_NAMED(x, NAMED(cx));
if (dup && MAYBE_SHARED(x)) {
x = shallow_duplicate(x);
SET_VECTOR_ELT(cx, offset, x);
}
}
}
return x;
}
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_subset2_dflt(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans, dims, dimnames, indx, subs, x;
int i, ndims, nsubs;
int drop = 1, pok, exact = -1;
int named_x;
R_xlen_t offset = 0;
PROTECT(args);
ExtractDropArg(args, &drop);
/* Is partial matching ok? When the exact arg is NA, a warning is
issued if partial matching occurs.
*/
exact = ExtractExactArg(args);
if (exact == -1)
pok = exact;
else
pok = !exact;
x = CAR(args);
/* This code was intended for compatibility with S, */
/* but in fact S does not do this. Will anyone notice? */
if (x == R_NilValue) {
UNPROTECT(1); /* args */
return x;
}
/* Get the subscripting and dimensioning information */
/* and check that any array subscripting is compatible. */
subs = CDR(args);
if(0 == (nsubs = length(subs)))
errorcall(call, _("no index specified"));
dims = getAttrib(x, R_DimSymbol);
ndims = length(dims);
if(nsubs > 1 && nsubs != ndims)
errorcall(call, _("incorrect number of subscripts"));
/* code to allow classes to extend environment */
if(TYPEOF(x) == S4SXP) {
x = R_getS4DataSlot(x, ANYSXP);
if(x == R_NilValue)
errorcall(call, _("this S4 class is not subsettable"));
}
PROTECT(x);
/* split out ENVSXP for now */
if( TYPEOF(x) == ENVSXP ) {
if( nsubs != 1 || !isString(CAR(subs)) || length(CAR(subs)) != 1 )
errorcall(call, _("wrong arguments for subsetting an environment"));
ans = findVarInFrame(x, installTrChar(STRING_ELT(CAR(subs), 0)));
if( TYPEOF(ans) == PROMSXP ) {
PROTECT(ans);
ans = eval(ans, R_GlobalEnv);
UNPROTECT(1); /* ans */
} else SET_NAMED(ans, 2);
UNPROTECT(2); /* args, x */
if(ans == R_UnboundValue)
return(R_NilValue);
if (NAMED(ans))
SET_NAMED(ans, 2);
return ans;
}
/* back to the regular program */
if (!(isVector(x) || isList(x) || isLanguage(x)))
errorcall(call, R_MSG_ob_nonsub, type2char(TYPEOF(x)));
named_x = NAMED(x); /* x may change below; save this now. See PR#13411 */
if(nsubs == 1) { /* vector indexing */
SEXP thesub = CAR(subs);
int len = length(thesub);
if (len > 1) {
#ifdef SWITCH_TO_REFCNT
if (IS_GETTER_CALL(call)) {
/* this is (most likely) a getter call in a complex
assighment so we duplicate as needed. The original
x should have been duplicated if it might be
shared */
if (MAYBE_SHARED(x))
error("getter call used outside of a complex assignment.");
x = vectorIndex(x, thesub, 0, len-1, pok, call, TRUE);
}
else
x = vectorIndex(x, thesub, 0, len-1, pok, call, FALSE);
#else
x = vectorIndex(x, thesub, 0, len-1, pok, call, FALSE);
#endif
named_x = NAMED(x);
UNPROTECT(1); /* x */
PROTECT(x);
}
SEXP xnames = PROTECT(getAttrib(x, R_NamesSymbol));
offset = get1index(thesub, xnames,
xlength(x), pok, len > 1 ? len-1 : -1, call);
UNPROTECT(1); /* xnames */
if (offset < 0 || offset >= xlength(x)) {
/* a bold attempt to get the same behaviour for $ and [[ */
if (offset < 0 && (isNewList(x) ||
isExpression(x) ||
isList(x) ||
isLanguage(x))) {
UNPROTECT(2); /* args, x */
return R_NilValue;
}
else errorcall(call, R_MSG_subs_o_b);
}
} else { /* matrix indexing */
/* Here we use the fact that: */
/* CAR(R_NilValue) = R_NilValue */
/* CDR(R_NilValue) = R_NilValue */
int ndn; /* Number of dimnames. Unlikely to be anything but
0 or nsubs, but just in case... */
PROTECT(indx = allocVector(INTSXP, nsubs));
dimnames = getAttrib(x, R_DimNamesSymbol);
ndn = length(dimnames);
for (i = 0; i < nsubs; i++) {
INTEGER(indx)[i] = (int)
get1index(CAR(subs),
(i < ndn) ? VECTOR_ELT(dimnames, i) : R_NilValue,
INTEGER(indx)[i], pok, -1, call);
subs = CDR(subs);
if (INTEGER(indx)[i] < 0 ||
INTEGER(indx)[i] >= INTEGER(dims)[i])
errorcall(call, R_MSG_subs_o_b);
}
offset = 0;
for (i = (nsubs - 1); i > 0; i--)
offset = (offset + INTEGER(indx)[i]) * INTEGER(dims)[i - 1];
offset += INTEGER(indx)[0];
UNPROTECT(1); /* indx */
}
if(isPairList(x)) {
#ifdef LONG_VECTOR_SUPPORT
if (offset > R_SHORT_LEN_MAX)
error("invalid subscript for pairlist");
#endif
ans = CAR(nthcdr(x, (int) offset));
if (named_x > NAMED(ans))
SET_NAMED(ans, named_x);
} else if(isVectorList(x)) {
/* did unconditional duplication before 2.4.0 */
ans = VECTOR_ELT(x, offset);
if (named_x > NAMED(ans))
SET_NAMED(ans, named_x);
} else {
ans = allocVector(TYPEOF(x), 1);
switch (TYPEOF(x)) {
case LGLSXP:
case INTSXP:
INTEGER(ans)[0] = INTEGER(x)[offset];
break;
case REALSXP:
REAL(ans)[0] = REAL(x)[offset];
break;
case CPLXSXP:
COMPLEX(ans)[0] = COMPLEX(x)[offset];
break;
case STRSXP:
SET_STRING_ELT(ans, 0, STRING_ELT(x, offset));
break;
case RAWSXP:
RAW(ans)[0] = RAW(x)[offset];
break;
default:
UNIMPLEMENTED_TYPE("do_subset2", x);
}
}
UNPROTECT(2); /* args, x */
return ans;
}
/*
* call to numeric_deriv from R -
* .Call("numeric_deriv", expr, theta, rho)
* Returns: ans
*/
SEXP
numeric_deriv(SEXP expr, SEXP theta, SEXP rho, SEXP dir)
{
SEXP ans, gradient, pars;
double eps = sqrt(DOUBLE_EPS), *rDir;
int start, i, j, k, lengthTheta = 0;
if(!isString(theta))
error(_("'theta' should be of type character"));
if (isNull(rho)) {
error(_("use of NULL environment is defunct"));
rho = R_BaseEnv;
} else
if(!isEnvironment(rho))
error(_("'rho' should be an environment"));
PROTECT(dir = coerceVector(dir, REALSXP));
if(TYPEOF(dir) != REALSXP || LENGTH(dir) != LENGTH(theta))
error(_("'dir' is not a numeric vector of the correct length"));
rDir = REAL(dir);
PROTECT(pars = allocVector(VECSXP, LENGTH(theta)));
PROTECT(ans = duplicate(eval(expr, rho)));
if(!isReal(ans)) {
SEXP temp = coerceVector(ans, REALSXP);
UNPROTECT(1);
PROTECT(ans = temp);
}
for(i = 0; i < LENGTH(ans); i++) {
if (!R_FINITE(REAL(ans)[i]))
error(_("Missing value or an infinity produced when evaluating the model"));
}
const void *vmax = vmaxget();
for(i = 0; i < LENGTH(theta); i++) {
const char *name = translateChar(STRING_ELT(theta, i));
SEXP s_name = install(name);
SEXP temp = findVar(s_name, rho);
if(isInteger(temp))
error(_("variable '%s' is integer, not numeric"), name);
if(!isReal(temp))
error(_("variable '%s' is not numeric"), name);
if (MAYBE_SHARED(temp)) /* We'll be modifying the variable, so need to make sure it's unique PR#15849 */
defineVar(s_name, temp = duplicate(temp), rho);
MARK_NOT_MUTABLE(temp);
SET_VECTOR_ELT(pars, i, temp);
lengthTheta += LENGTH(VECTOR_ELT(pars, i));
}
vmaxset(vmax);
PROTECT(gradient = allocMatrix(REALSXP, LENGTH(ans), lengthTheta));
for(i = 0, start = 0; i < LENGTH(theta); i++) {
for(j = 0; j < LENGTH(VECTOR_ELT(pars, i)); j++, start += LENGTH(ans)) {
SEXP ans_del;
double origPar, xx, delta;
origPar = REAL(VECTOR_ELT(pars, i))[j];
xx = fabs(origPar);
delta = (xx == 0) ? eps : xx*eps;
REAL(VECTOR_ELT(pars, i))[j] += rDir[i] * delta;
PROTECT(ans_del = eval(expr, rho));
if(!isReal(ans_del)) ans_del = coerceVector(ans_del, REALSXP);
UNPROTECT(1);
for(k = 0; k < LENGTH(ans); k++) {
if (!R_FINITE(REAL(ans_del)[k]))
error(_("Missing value or an infinity produced when evaluating the model"));
REAL(gradient)[start + k] =
rDir[i] * (REAL(ans_del)[k] - REAL(ans)[k])/delta;
}
REAL(VECTOR_ELT(pars, i))[j] = origPar;
}
}
setAttrib(ans, install("gradient"), gradient);
UNPROTECT(4);
return ans;
}
