/* 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 lazy_duplicate(SEXP s) {
switch (TYPEOF(s)) {
case NILSXP:
case SYMSXP:
case ENVSXP:
case SPECIALSXP:
case BUILTINSXP:
case EXTPTRSXP:
case BCODESXP:
case WEAKREFSXP:
case CHARSXP:
case PROMSXP:
break;
case CLOSXP:
case LISTSXP:
case LANGSXP:
case DOTSXP:
case EXPRSXP:
case VECSXP:
case LGLSXP:
case INTSXP:
case REALSXP:
case CPLXSXP:
case RAWSXP:
case STRSXP:
case S4SXP:
SET_NAMED(s, 2);
break;
default:
UNIMPLEMENTED_TYPE("lazy_duplicate", s);
}
return s;
}
SEXP attribute_hidden do_commentgets(SEXP call, SEXP op, SEXP args, SEXP env)
{
checkArity(op, args);
if (NAMED(CAR(args)) == 2) SETCAR(args, duplicate(CAR(args)));
if (length(CADR(args)) == 0) SETCADR(args, R_NilValue);
setAttrib(CAR(args), R_CommentSymbol, CADR(args));
SET_NAMED(CAR(args), 0);
return CAR(args);
}
static R_INLINE SEXP VECTOR_ELT_FIX_NAMED(SEXP y, R_xlen_t i) {
/* if RHS (container or element) has NAMED > 0 set NAMED = 2.
Duplicating might be safer/more consistent (fix bug reported by
Radford Neal; similar to PR15098) */
SEXP val = VECTOR_ELT(y, i);
if ((NAMED(y) || NAMED(val)))
if (NAMED(val) < 2)
SET_NAMED(val, 2);
return val;
}
/* oldClass<-(), primitive */
SEXP attribute_hidden do_classgets(SEXP call, SEXP op, SEXP args, SEXP env)
{
checkArity(op, args);
check1arg(args, call, "x");
if (NAMED(CAR(args)) == 2) SETCAR(args, duplicate(CAR(args)));
if (length(CADR(args)) == 0) SETCADR(args, R_NilValue);
if(IS_S4_OBJECT(CAR(args)))
UNSET_S4_OBJECT(CAR(args));
setAttrib(CAR(args), R_ClassSymbol, CADR(args));
SET_NAMED(CAR(args), 0);
return CAR(args);
}
/* duplicate RHS value of complex assignment if necessary to prevent cycles */
INLINE_FUN SEXP R_FixupRHS(SEXP x, SEXP y)
{
if( y != R_NilValue && MAYBE_REFERENCED(y) ) {
if (R_cycle_detected(x, y)) {
#ifdef WARNING_ON_CYCLE_DETECT
warning("cycle detected");
R_cycle_detected(x, y);
#endif
y = duplicate(y);
}
else if (NAMED(y) < 2) SET_NAMED(y, 2);
}
return y;
}
/* The $ subset operator.
We need to be sure to only evaluate the first argument.
The second will be a symbol that needs to be matched, not evaluated.
*/
SEXP attribute_hidden do_subset3(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP input, nlist, ans;
checkArity(op, args);
/* first translate CADR of args into a string so that we can
pass it down to DispatchorEval and have it behave correctly */
input = PROTECT(allocVector(STRSXP, 1));
nlist = CADR(args);
if (TYPEOF(nlist) == PROMSXP)
nlist = eval(nlist, env);
if(isSymbol(nlist) )
SET_STRING_ELT(input, 0, PRINTNAME(nlist));
else if(isString(nlist) )
SET_STRING_ELT(input, 0, STRING_ELT(nlist, 0));
else {
errorcall(call,_("invalid subscript type '%s'"),
type2char(TYPEOF(nlist)));
}
/* replace the second argument with a string */
/* Previously this was SETCADR(args, input); */
/* which could cause problems when nlist was */
/* ..., as in PR#8718 */
PROTECT(args = CONS(CAR(args), CONS(input, R_NilValue)));
/* If the first argument is an object and there is */
/* an approriate method, we dispatch to that method, */
/* otherwise we evaluate the arguments and fall */
/* through to the generic code below. Note that */
/* evaluation retains any missing argument indicators. */
if(R_DispatchOrEvalSP(call, op, "$", args, env, &ans)) {
UNPROTECT(2); /* input, args */
if (NAMED(ans))
SET_NAMED(ans, 2);
return(ans);
}
UNPROTECT(2); /* input, args */
return R_subset3_dflt(CAR(ans), STRING_ELT(input, 0), call);
}
/* This is a special .Internal, so has unevaluated arguments. It is
called from a closure wrapper, so X and FUN are promises.
FUN must be unevaluated for use in e.g. bquote .
*/
SEXP attribute_hidden do_lapply(SEXP call, SEXP op, SEXP args, SEXP rho)
{
PROTECT_INDEX px;
checkArity(op, args);
SEXP X, XX, FUN;
PROTECT_WITH_INDEX(X =CAR(args), &px);
XX = PROTECT(eval(CAR(args), rho));
R_xlen_t n = xlength(XX); // a vector, so will be valid.
FUN = CADR(args);
Rboolean realIndx = n > INT_MAX;
SEXP ans = PROTECT(allocVector(VECSXP, n));
SEXP names = getAttrib(XX, R_NamesSymbol);
if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);
/* Build call: FUN(XX[[<ind>]], ...) */
SEXP ind = PROTECT(allocVector(realIndx ? REALSXP : INTSXP, 1));
SEXP isym = install("i");
defineVar(isym, ind, rho);
SET_NAMED(ind, 1);
/* Notice that it is OK to have one arg to LCONS do memory
allocation and not PROTECT the result (LCONS does memory
protection of its args internally), but not both of them,
since the computation of one may destroy the other */
SEXP tmp = PROTECT(LCONS(R_Bracket2Symbol,
LCONS(X, LCONS(isym, R_NilValue))));
SEXP R_fcall = PROTECT(LCONS(FUN,
LCONS(tmp, LCONS(R_DotsSymbol, R_NilValue))));
for(R_xlen_t i = 0; i < n; i++) {
if (realIndx) REAL(ind)[0] = (double)(i + 1);
else INTEGER(ind)[0] = (int)(i + 1);
tmp = R_forceAndCall(R_fcall, 1, rho);
if (MAYBE_REFERENCED(tmp)) tmp = lazy_duplicate(tmp);
SET_VECTOR_ELT(ans, i, tmp);
}
UNPROTECT(6);
return ans;
}
SEXP attribute_hidden do_subset(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans;
/* If the first argument is an object and there is an */
/* approriate method, we dispatch to that method, */
/* otherwise we evaluate the arguments and fall through */
/* to the generic code below. Note that evaluation */
/* retains any missing argument indicators. */
if(DispatchOrEval(call, op, "[", args, rho, &ans, 0, 0)) {
/* if(DispatchAnyOrEval(call, op, "[", args, rho, &ans, 0, 0)) */
if (NAMED(ans))
SET_NAMED(ans, 2);
return(ans);
}
/* Method dispatch has failed, we now */
/* run the generic internal code. */
return do_subset_dflt(call, op, ans, rho);
}
SEXP attribute_hidden do_subset2(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans;
/* If the first argument is an object and there is */
/* an approriate method, we dispatch to that method, */
/* otherwise we evaluate the arguments and fall */
/* through to the generic code below. Note that */
/* evaluation retains any missing argument indicators. */
if(R_DispatchOrEvalSP(call, op, "[[", args, rho, &ans)) {
if (NAMED(ans))
SET_NAMED(ans, 2);
return(ans);
}
/* Method dispatch has failed. */
/* We now run the generic internal code. */
return do_subset2_dflt(call, op, ans, rho);
}
SEXP graph_bitarray_edgeSetToMatrix(SEXP nodes, SEXP bits,
SEXP _weights, SEXP _directed)
{
SEXP ans, dnms, _dim = getAttrib(bits, install("bitdim"));
unsigned char *bytes = (unsigned char *) RAW(bits);
int dim = INTEGER(_dim)[0],
num_el = dim * dim,
directed = asInteger(_directed),
linIndx = 0, wtIndx = 0;
double *weights = REAL(_weights), *ftMat;
PROTECT(ans = allocVector(REALSXP, num_el));
ftMat = REAL(ans);
memset(ftMat, 0, sizeof(double) * num_el);
while (linIndx < num_el) {
unsigned char v = bytes[linIndx / 8];
if (v == 0) {
linIndx += 8;
} else {
if (v & (1 << (linIndx % 8))) {
ftMat[linIndx] = weights[wtIndx];
if (!directed) {
ftMat[linIndx/dim + (linIndx % dim)*dim] = weights[wtIndx];
}
wtIndx++;
}
linIndx++;
}
}
SET_NAMED(_dim, 2);
setAttrib(ans, R_DimSymbol, _dim);
PROTECT(dnms = allocVector(VECSXP, 2));
/* Arguments to .Call have NAMED(x) == 2, so we can
reuse here.
*/
SET_VECTOR_ELT(dnms, 0, nodes);
SET_VECTOR_ELT(dnms, 1, nodes);
setAttrib(ans, R_DimNamesSymbol, dnms);
UNPROTECT(2);
return ans;
}
/* 'name' should be 1-element STRSXP or SYMSXP */
SEXP setAttrib(SEXP vec, SEXP name, SEXP val)
{
PROTECT(vec);
PROTECT(name);
if (isString(name))
name = install(translateChar(STRING_ELT(name, 0)));
if (val == R_NilValue) {
UNPROTECT(2);
return removeAttrib(vec, name);
}
/* We allow attempting to remove names from NULL */
if (vec == R_NilValue)
error(_("attempt to set an attribute on NULL"));
if (NAMED(val)) val = duplicate(val);
SET_NAMED(val, NAMED(val) | NAMED(vec));
UNPROTECT(2);
if (name == R_NamesSymbol)
return namesgets(vec, val);
else if (name == R_DimSymbol)
return dimgets(vec, val);
else if (name == R_DimNamesSymbol)
return dimnamesgets(vec, val);
else if (name == R_ClassSymbol)
return classgets(vec, val);
else if (name == R_TspSymbol)
return tspgets(vec, val);
else if (name == R_CommentSymbol)
return commentgets(vec, val);
else if (name == R_RowNamesSymbol)
return row_names_gets(vec, val);
else
return installAttrib(vec, name, val);
}
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;
}
SEXP attribute_hidden do_subset_dflt(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans, ax, px, x, subs;
int drop, i, nsubs, type;
/* By default we drop extents of length 1 */
/* Handle cases of extracting a single element from a simple vector
or matrix directly to improve speed for these simple cases. */
SEXP cdrArgs = CDR(args);
SEXP cddrArgs = CDR(cdrArgs);
if (cdrArgs != R_NilValue && cddrArgs == R_NilValue &&
TAG(cdrArgs) == R_NilValue) {
/* one index, not named */
SEXP x = CAR(args);
if (ATTRIB(x) == R_NilValue) {
SEXP s = CAR(cdrArgs);
R_xlen_t i = scalarIndex(s);
switch (TYPEOF(x)) {
case REALSXP:
if (i >= 1 && i <= XLENGTH(x))
return ScalarReal( REAL(x)[i-1] );
break;
case INTSXP:
if (i >= 1 && i <= XLENGTH(x))
return ScalarInteger( INTEGER(x)[i-1] );
break;
case LGLSXP:
if (i >= 1 && i <= XLENGTH(x))
return ScalarLogical( LOGICAL(x)[i-1] );
break;
// do the more rare cases as well, since we've already prepared everything:
case CPLXSXP:
if (i >= 1 && i <= XLENGTH(x))
return ScalarComplex( COMPLEX(x)[i-1] );
break;
case RAWSXP:
if (i >= 1 && i <= XLENGTH(x))
return ScalarRaw( RAW(x)[i-1] );
break;
default: break;
}
}
}
else if (cddrArgs != R_NilValue && CDR(cddrArgs) == R_NilValue &&
TAG(cdrArgs) == R_NilValue && TAG(cddrArgs) == R_NilValue) {
/* two indices, not named */
SEXP x = CAR(args);
SEXP attr = ATTRIB(x);
if (TAG(attr) == R_DimSymbol && CDR(attr) == R_NilValue) {
/* only attribute of x is 'dim' */
SEXP dim = CAR(attr);
if (TYPEOF(dim) == INTSXP && LENGTH(dim) == 2) {
/* x is a matrix */
SEXP si = CAR(cdrArgs);
SEXP sj = CAR(cddrArgs);
R_xlen_t i = scalarIndex(si);
R_xlen_t j = scalarIndex(sj);
int nrow = INTEGER(dim)[0];
int ncol = INTEGER(dim)[1];
if (i > 0 && j > 0 && i <= nrow && j <= ncol) {
/* indices are legal scalars */
R_xlen_t k = i - 1 + nrow * (j - 1);
switch (TYPEOF(x)) {
case REALSXP:
if (k < LENGTH(x))
return ScalarReal( REAL(x)[k] );
break;
case INTSXP:
if (k < LENGTH(x))
return ScalarInteger( INTEGER(x)[k] );
break;
case LGLSXP:
if (k < LENGTH(x))
return ScalarLogical( LOGICAL(x)[k] );
break;
case CPLXSXP:
if (k < LENGTH(x))
return ScalarComplex( COMPLEX(x)[k] );
break;
case RAWSXP:
if (k < LENGTH(x))
return ScalarRaw( RAW(x)[k] );
break;
default: break;
}
}
}
}
}
PROTECT(args);
drop = 1;
ExtractDropArg(args, &drop);
x = CAR(args);
/* This was intended for compatibility with S, */
/* but in fact S does not do this. */
/* FIXME: replace the test by isNull ... ? */
if (x == R_NilValue) {
UNPROTECT(1);
return x;
}
subs = CDR(args);
nsubs = length(subs); /* Will be short */
type = TYPEOF(x);
/* Here coerce pair-based objects into generic vectors. */
/* All subsetting takes place on the generic vector form. */
ax = x;
if (isVector(x))
PROTECT(ax);
else if (isPairList(x)) {
SEXP dim = getAttrib(x, R_DimSymbol);
int ndim = length(dim);
if (ndim > 1) {
PROTECT(ax = allocArray(VECSXP, dim));
setAttrib(ax, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol));
setAttrib(ax, R_NamesSymbol, getAttrib(x, R_DimNamesSymbol));
}
else {
PROTECT(ax = allocVector(VECSXP, length(x)));
setAttrib(ax, R_NamesSymbol, getAttrib(x, R_NamesSymbol));
}
for(px = x, i = 0 ; px != R_NilValue ; px = CDR(px))
SET_VECTOR_ELT(ax, i++, CAR(px));
}
else errorcall(call, R_MSG_ob_nonsub, type2char(TYPEOF(x)));
/* This is the actual subsetting code. */
/* The separation of arrays and matrices is purely an optimization. */
if(nsubs < 2) {
SEXP dim = getAttrib(x, R_DimSymbol);
int ndim = length(dim);
PROTECT(ans = VectorSubset(ax, (nsubs == 1 ? CAR(subs) : R_MissingArg),
call));
/* one-dimensional arrays went through here, and they should
have their dimensions dropped only if the result has
length one and drop == TRUE
*/
if(ndim == 1) {
SEXP attr, attrib, nattrib;
int len = length(ans);
if(!drop || len > 1) {
// must grab these before the dim is set.
SEXP nm = PROTECT(getAttrib(ans, R_NamesSymbol));
PROTECT(attr = allocVector(INTSXP, 1));
INTEGER(attr)[0] = length(ans);
setAttrib(ans, R_DimSymbol, attr);
if((attrib = getAttrib(x, R_DimNamesSymbol)) != R_NilValue) {
/* reinstate dimnames, include names of dimnames */
PROTECT(nattrib = duplicate(attrib));
SET_VECTOR_ELT(nattrib, 0, nm);
setAttrib(ans, R_DimNamesSymbol, nattrib);
setAttrib(ans, R_NamesSymbol, R_NilValue);
UNPROTECT(1);
}
UNPROTECT(2);
}
}
} else {
if (nsubs != length(getAttrib(x, R_DimSymbol)))
errorcall(call, _("incorrect number of dimensions"));
if (nsubs == 2)
ans = MatrixSubset(ax, subs, call, drop);
else
ans = ArraySubset(ax, subs, call, drop);
PROTECT(ans);
}
/* Note: we do not coerce back to pair-based lists. */
/* They are "defunct" in this version of R. */
if (type == LANGSXP) {
ax = ans;
PROTECT(ans = allocList(LENGTH(ax)));
if ( LENGTH(ax) > 0 )
SET_TYPEOF(ans, LANGSXP);
for(px = ans, i = 0 ; px != R_NilValue ; px = CDR(px))
SETCAR(px, VECTOR_ELT(ax, i++));
setAttrib(ans, R_DimSymbol, getAttrib(ax, R_DimSymbol));
setAttrib(ans, R_DimNamesSymbol, getAttrib(ax, R_DimNamesSymbol));
setAttrib(ans, R_NamesSymbol, getAttrib(ax, R_NamesSymbol));
SET_NAMED(ans, NAMED(ax)); /* PR#7924 */
}
else {
PROTECT(ans);
}
if (ATTRIB(ans) != R_NilValue) { /* remove probably erroneous attr's */
setAttrib(ans, R_TspSymbol, R_NilValue);
#ifdef _S4_subsettable
if(!IS_S4_OBJECT(x))
#endif
setAttrib(ans, R_ClassSymbol, R_NilValue);
}
UNPROTECT(4);
return ans;
}
/* This is for all cases with a single index, including 1D arrays and
matrix indexing of arrays */
static SEXP VectorSubset(SEXP x, SEXP s, SEXP call)
{
R_xlen_t n;
int mode;
R_xlen_t stretch = 1;
SEXP indx, result, attrib, nattrib;
if (s == R_MissingArg) return duplicate(x);
PROTECT(s);
attrib = getAttrib(x, R_DimSymbol);
/* Check to see if we have special matrix subscripting. */
/* If we do, make a real subscript vector and protect it. */
if (isMatrix(s) && isArray(x) && ncols(s) == length(attrib)) {
if (isString(s)) {
s = strmat2intmat(s, GetArrayDimnames(x), call);
UNPROTECT(1);
PROTECT(s);
}
if (isInteger(s) || isReal(s)) {
s = mat2indsub(attrib, s, call);
UNPROTECT(1);
PROTECT(s);
}
}
/* Convert to a vector of integer subscripts */
/* in the range 1:length(x). */
PROTECT(indx = makeSubscript(x, s, &stretch, call));
n = XLENGTH(indx);
/* Allocate the result. */
mode = TYPEOF(x);
/* No protection needed as ExtractSubset does not allocate */
result = allocVector(mode, n);
if (mode == VECSXP || mode == EXPRSXP)
/* we do not duplicate the values when extracting the subset,
so to be conservative mark the result as NAMED = 2 */
SET_NAMED(result, 2);
PROTECT(result = ExtractSubset(x, result, indx, call));
if (result != R_NilValue) {
if (
((attrib = getAttrib(x, R_NamesSymbol)) != R_NilValue) ||
( /* here we might have an array. Use row names if 1D */
isArray(x) && LENGTH(getAttrib(x, R_DimNamesSymbol)) == 1 &&
(attrib = getAttrib(x, R_DimNamesSymbol)) != R_NilValue &&
(attrib = GetRowNames(attrib)) != R_NilValue
)
) {
PROTECT(attrib);
nattrib = allocVector(TYPEOF(attrib), n);
PROTECT(nattrib); /* seems unneeded */
nattrib = ExtractSubset(attrib, nattrib, indx, call);
setAttrib(result, R_NamesSymbol, nattrib);
UNPROTECT(2); /* attrib, nattrib */
}
if ((attrib = getAttrib(x, R_SrcrefSymbol)) != R_NilValue &&
TYPEOF(attrib) == VECSXP) {
nattrib = allocVector(VECSXP, n);
PROTECT(nattrib); /* seems unneeded */
nattrib = ExtractSubset(attrib, nattrib, indx, call);
setAttrib(result, R_SrcrefSymbol, nattrib);
UNPROTECT(1);
}
/* FIXME: this is wrong, because the slots are gone, so result is an invalid object of the S4 class! JMC 3/3/09 */
#ifdef _S4_subsettable
if(IS_S4_OBJECT(x)) { /* e.g. contains = "list" */
setAttrib(result, R_ClassSymbol, getAttrib(x, R_ClassSymbol));
SET_S4_OBJECT(result);
}
#endif
}
UNPROTECT(3);
return result;
}
/* used in eval.c */
SEXP attribute_hidden R_subset3_dflt(SEXP x, SEXP input, SEXP call)
{
SEXP y, nlist;
size_t slen;
PROTECT(input);
PROTECT(x);
/* Optimisation to prevent repeated recalculation */
slen = strlen(translateChar(input));
/* The mechanism to allow a class extending "environment" */
if( IS_S4_OBJECT(x) && TYPEOF(x) == S4SXP ){
x = R_getS4DataSlot(x, ANYSXP);
if(x == R_NilValue)
errorcall(call, "$ operator not defined for this S4 class");
}
UNPROTECT(1); /* x */
PROTECT(x);
/* If this is not a list object we return NULL. */
if (isPairList(x)) {
SEXP xmatch = R_NilValue;
int havematch;
UNPROTECT(2); /* input, x */
havematch = 0;
for (y = x ; y != R_NilValue ; y = CDR(y)) {
switch(pstrmatch(TAG(y), input, slen)) {
case EXACT_MATCH:
y = CAR(y);
if (NAMED(x) > NAMED(y)) SET_NAMED(y, NAMED(x));
return y;
case PARTIAL_MATCH:
havematch++;
xmatch = y;
break;
case NO_MATCH:
break;
}
}
if (havematch == 1) { /* unique partial match */
if(R_warn_partial_match_dollar) {
const char *st = "";
SEXP target = TAG(xmatch);
switch (TYPEOF(target)) {
case SYMSXP:
st = CHAR(PRINTNAME(target));
break;
case CHARSXP:
st = translateChar(target);
break;
}
warningcall(call, _("partial match of '%s' to '%s'"),
translateChar(input), st);
}
y = CAR(xmatch);
if (NAMED(x) > NAMED(y)) SET_NAMED(y, NAMED(x));
return y;
}
return R_NilValue;
}
else if (isVectorList(x)) {
R_xlen_t i, n, imatch = -1;
int havematch;
nlist = getAttrib(x, R_NamesSymbol);
UNPROTECT(2); /* input, x */
n = xlength(nlist);
havematch = 0;
for (i = 0 ; i < n ; i = i + 1) {
switch(pstrmatch(STRING_ELT(nlist, i), input, slen)) {
case EXACT_MATCH:
y = VECTOR_ELT(x, i);
if (NAMED(x) > NAMED(y))
SET_NAMED(y, NAMED(x));
return y;
case PARTIAL_MATCH:
havematch++;
if (havematch == 1) {
/* partial matches can cause aliasing in eval.c:evalseq
This is overkill, but alternative ways to prevent
the aliasing appear to be even worse */
y = VECTOR_ELT(x,i);
SET_NAMED(y,2);
SET_VECTOR_ELT(x,i,y);
}
imatch = i;
break;
case NO_MATCH:
break;
}
}
if(havematch == 1) { /* unique partial match */
if(R_warn_partial_match_dollar) {
const char *st = "";
SEXP target = STRING_ELT(nlist, imatch);
switch (TYPEOF(target)) {
case SYMSXP:
st = CHAR(PRINTNAME(target));
break;
case CHARSXP:
st = translateChar(target);
break;
}
warningcall(call, _("partial match of '%s' to '%s'"),
translateChar(input), st);
}
y = VECTOR_ELT(x, imatch);
if (NAMED(x) > NAMED(y)) SET_NAMED(y, NAMED(x));
return y;
}
return R_NilValue;
}
else if( isEnvironment(x) ){
y = findVarInFrame(x, installTrChar(input));
if( TYPEOF(y) == PROMSXP ) {
PROTECT(y);
y = eval(y, R_GlobalEnv);
UNPROTECT(1); /* y */
}
UNPROTECT(2); /* input, x */
if( y != R_UnboundValue ) {
if (NAMED(y))
SET_NAMED(y, 2);
else if (NAMED(x) > NAMED(y))
SET_NAMED(y, NAMED(x));
return(y);
}
return R_NilValue;
}
else if( isVectorAtomic(x) ){
errorcall(call, "$ operator is invalid for atomic vectors");
}
else /* e.g. a function */
errorcall(call, R_MSG_ob_nonsub, type2char(TYPEOF(x)));
UNPROTECT(2); /* input, x */
return R_NilValue;
}
/* NOTE: For environments serialize.c calls this function to find if
there is a class attribute in order to reconstruct the object bit
if needed. This means the function cannot use OBJECT(vec) == 0 to
conclude that the class attribute is R_NilValue. If you want to
rewrite this function to use such a pre-test, be sure to adjust
serialize.c accordingly. LT */
SEXP attribute_hidden getAttrib0(SEXP vec, SEXP name)
{
SEXP s;
int len, i, any;
if (name == R_NamesSymbol) {
if(isVector(vec) || isList(vec) || isLanguage(vec)) {
s = getAttrib(vec, R_DimSymbol);
if(TYPEOF(s) == INTSXP && length(s) == 1) {
s = getAttrib(vec, R_DimNamesSymbol);
if(!isNull(s)) {
SET_NAMED(VECTOR_ELT(s, 0), 2);
return VECTOR_ELT(s, 0);
}
}
}
if (isList(vec) || isLanguage(vec)) {
len = length(vec);
PROTECT(s = allocVector(STRSXP, len));
i = 0;
any = 0;
for ( ; vec != R_NilValue; vec = CDR(vec), i++) {
if (TAG(vec) == R_NilValue)
SET_STRING_ELT(s, i, R_BlankString);
else if (isSymbol(TAG(vec))) {
any = 1;
SET_STRING_ELT(s, i, PRINTNAME(TAG(vec)));
}
else
error(_("getAttrib: invalid type (%s) for TAG"),
type2char(TYPEOF(TAG(vec))));
}
UNPROTECT(1);
if (any) {
if (!isNull(s)) SET_NAMED(s, 2);
return (s);
}
return R_NilValue;
}
}
/* This is where the old/new list adjustment happens. */
for (s = ATTRIB(vec); s != R_NilValue; s = CDR(s))
if (TAG(s) == name) {
if (name == R_DimNamesSymbol && TYPEOF(CAR(s)) == LISTSXP) {
SEXP _new, old;
int i;
_new = allocVector(VECSXP, length(CAR(s)));
old = CAR(s);
i = 0;
while (old != R_NilValue) {
SET_VECTOR_ELT(_new, i++, CAR(old));
old = CDR(old);
}
SET_NAMED(_new, 2);
return _new;
}
SET_NAMED(CAR(s), 2);
return CAR(s);
}
return R_NilValue;
}
/* Construct a string identifying some SEXP, either as a scalar value or as a pointer.
If we use its pointer, set NAMED = 2 on the pointer used.
Return that pointer, or R_NilValue. */
SEXP stringify_item(SEXP item, char *bufptr) {
int done = 0;
SEXP item_ptr = R_NilValue;
while(!done) {
switch (TYPEOF(item)) {
case PROMSXP:
/* if we have a promise, drill down. */
item = PRCODE(item);
break;
case CHARSXP:
/* interned string, represent its pointer */
item_ptr = item;
bufptr += sprintf(bufptr, "c%p", CHAR(item_ptr));
done = 1;
break;
case REALSXP:
case INTSXP:
case STRSXP:
case LGLSXP:
/* we have a code literal. represent it canonically,
and don't hold a ref to a scalar. */
if (LENGTH(item) == 0) {
switch(TYPEOF(item)) {
case REALSXP: bufptr += sprintf(bufptr, "r0"); break;
case INTSXP: bufptr += sprintf(bufptr, "i0"); break;
case LGLSXP: bufptr += sprintf(bufptr, "l0"); break;
case STRSXP: bufptr += sprintf(bufptr, "s0"); break;
default: error("Unexpected type %s (this shouldn't happen)", TYPEOF(item));
}
} else if (LENGTH(item) == 1) {
switch(TYPEOF(item)) {
case REALSXP:
bufptr += sprintf(bufptr, "r");
bufptr += sprintdouble(bufptr, REAL(item)[0]);
break;
case INTSXP: bufptr += sprintf(bufptr, "i%x", INTEGER(item)[0]); break;
case LGLSXP: bufptr += sprintf(bufptr, "l%x", LOGICAL(item)[0]); break;
case STRSXP:
item_ptr = STRING_ELT(item, 0);
bufptr += sprintf(bufptr, "s%p", CHAR(item_ptr)); break;
default: error("Unexpected type %s (this shouldn't happen)", TYPEOF(item));
}
} else {
/* for non-scalar vectors, represent the pointer */
item_ptr = item;
bufptr += sprintf(bufptr, "v%p", (void *)item_ptr);
}
done = 1;
break;
case VECSXP:
item_ptr = item;
bufptr += sprintf(bufptr, "l%p", (void *)item_ptr);
done = 1;
break;
case CLOSXP:
item_ptr = item;
bufptr += sprintf(bufptr, "c_%p/%p/%p",
(void *) FORMALS(item),
(void *) BODY(item),
(void *) CLOENV(item));
done = 1;
break;
case SYMSXP:
case LANGSXP:
case EXPRSXP:
case BCODESXP:
case BUILTINSXP:
case SPECIALSXP:
case NILSXP:
/* We have an expression-ish, represent its pointer. */
item_ptr = item;
bufptr += sprintf(bufptr, "e%p", (void *)item_ptr);
done = 1;
break;
default:
error("Unexpected type %s", type2char(TYPEOF(item)));
}
}
if (item_ptr != R_NilValue) {
SET_NAMED(item_ptr, 2);
}
return item_ptr;
}
static void fmingr(int n, double *p, double *df, void *ex)
{
SEXP s, x;
int i;
double val1, val2, eps, epsused, tmp;
OptStruct OS = (OptStruct) ex;
PROTECT_INDEX ipx;
if (!isNull(OS->R_gcall)) { /* analytical derivatives */
PROTECT(x = allocVector(REALSXP, n));
if(!isNull(OS->names)) setAttrib(x, R_NamesSymbol, OS->names);
for (i = 0; i < n; i++) {
if (!R_FINITE(p[i]))
error(_("non-finite value supplied by optim"));
REAL(x)[i] = p[i] * (OS->parscale[i]);
}
SETCADR(OS->R_gcall, x);
PROTECT_WITH_INDEX(s = eval(OS->R_gcall, OS->R_env), &ipx);
REPROTECT(s = coerceVector(s, REALSXP), ipx);
if(LENGTH(s) != n)
error(_("gradient in optim evaluated to length %d not %d"),
LENGTH(s), n);
for (i = 0; i < n; i++)
df[i] = REAL(s)[i] * (OS->parscale[i])/(OS->fnscale);
UNPROTECT(2);
} else { /* numerical derivatives */
PROTECT(x = allocVector(REALSXP, n));
setAttrib(x, R_NamesSymbol, OS->names);
SET_NAMED(x, 2); // in case f tries to change it
for (i = 0; i < n; i++) REAL(x)[i] = p[i] * (OS->parscale[i]);
SETCADR(OS->R_fcall, x);
if(OS->usebounds == 0) {
for (i = 0; i < n; i++) {
eps = OS->ndeps[i];
REAL(x)[i] = (p[i] + eps) * (OS->parscale[i]);
PROTECT_WITH_INDEX(s = eval(OS->R_fcall, OS->R_env), &ipx);
REPROTECT(s = coerceVector(s, REALSXP), ipx);
val1 = REAL(s)[0]/(OS->fnscale);
REAL(x)[i] = (p[i] - eps) * (OS->parscale[i]);
REPROTECT(s = eval(OS->R_fcall, OS->R_env), ipx);
REPROTECT(s = coerceVector(s, REALSXP), ipx);
val2 = REAL(s)[0]/(OS->fnscale);
df[i] = (val1 - val2)/(2 * eps);
if(!R_FINITE(df[i]))
error(("non-finite finite-difference value [%d]"), i+1);
REAL(x)[i] = p[i] * (OS->parscale[i]);
UNPROTECT(1);
}
} else { /* usebounds */
for (i = 0; i < n; i++) {
epsused = eps = OS->ndeps[i];
tmp = p[i] + eps;
if (tmp > OS->upper[i]) {
tmp = OS->upper[i];
epsused = tmp - p[i];
}
REAL(x)[i] = tmp * (OS->parscale[i]);
PROTECT_WITH_INDEX(s = eval(OS->R_fcall, OS->R_env), &ipx);
REPROTECT(s = coerceVector(s, REALSXP), ipx);
val1 = REAL(s)[0]/(OS->fnscale);
tmp = p[i] - eps;
if (tmp < OS->lower[i]) {
tmp = OS->lower[i];
eps = p[i] - tmp;
}
REAL(x)[i] = tmp * (OS->parscale[i]);
REPROTECT(s = eval(OS->R_fcall, OS->R_env), ipx);
REPROTECT(s = coerceVector(s, REALSXP), ipx);
val2 = REAL(s)[0]/(OS->fnscale);
df[i] = (val1 - val2)/(epsused + eps);
if(!R_FINITE(df[i]))
error(("non-finite finite-difference value [%d]"), i+1);
REAL(x)[i] = p[i] * (OS->parscale[i]);
UNPROTECT(1);
}
}
UNPROTECT(1); /* x */
}
}
/* rep.int(x, times) for a vector times */
static SEXP rep2(SEXP s, SEXP ncopy)
{
R_xlen_t i, na, nc, n;
int j;
SEXP a, t;
PROTECT(t = coerceVector(ncopy, INTSXP));
nc = xlength(ncopy);
na = 0;
for (i = 0; i < nc; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
if (INTEGER(t)[i] == NA_INTEGER || INTEGER(t)[i] < 0)
error(_("invalid '%s' value"), "times");
na += INTEGER(t)[i];
}
/* R_xlen_t ni = NINTERRUPT, ratio;
if(nc > 0) {
ratio = na/nc; // average no of replications
if (ratio > 1000U) ni = 1000U;
} */
PROTECT(a = allocVector(TYPEOF(s), na));
n = 0;
switch (TYPEOF(s)) {
case LGLSXP:
for (i = 0; i < nc; i++) {
// if ((i+1) % ni == 0) R_CheckUserInterrupt();
for (j = 0; j < INTEGER(t)[i]; j++)
LOGICAL(a)[n++] = LOGICAL(s)[i];
}
break;
case INTSXP:
for (i = 0; i < nc; i++) {
// if ((i+1) % ni == 0) R_CheckUserInterrupt();
for (j = 0; j < INTEGER(t)[i]; j++)
INTEGER(a)[n++] = INTEGER(s)[i];
}
break;
case REALSXP:
for (i = 0; i < nc; i++) {
// if ((i+1) % ni == 0) R_CheckUserInterrupt();
for (j = 0; j < INTEGER(t)[i]; j++)
REAL(a)[n++] = REAL(s)[i];
}
break;
case CPLXSXP:
for (i = 0; i < nc; i++) {
// if ((i+1) % ni == 0) R_CheckUserInterrupt();
for (j = 0; j < INTEGER(t)[i]; j++)
COMPLEX(a)[n++] = COMPLEX(s)[i];
}
break;
case STRSXP:
for (i = 0; i < nc; i++) {
// if ((i+1) % ni == 0) R_CheckUserInterrupt();
for (j = 0; j < INTEGER(t)[i]; j++)
SET_STRING_ELT(a, n++, STRING_ELT(s, i));
}
break;
case VECSXP:
case EXPRSXP:
for (i = 0; i < nc; i++) {
// if ((i+1) % ni == 0) R_CheckUserInterrupt();
SEXP elt = lazy_duplicate(VECTOR_ELT(s, i));
for (j = 0; j < INTEGER(t)[i]; j++)
SET_VECTOR_ELT(a, n++, elt);
if (j > 1) SET_NAMED(elt, 2);
}
break;
case RAWSXP:
for (i = 0; i < nc; i++) {
// if ((i+1) % ni == 0) R_CheckUserInterrupt();
for (j = 0; j < INTEGER(t)[i]; j++)
RAW(a)[n++] = RAW(s)[i];
}
break;
default:
UNIMPLEMENTED_TYPE("rep2", s);
}
UNPROTECT(2);
return a;
}
SEXP setnamed(SEXP x, SEXP value)
{
if (!isInteger(value) || LENGTH(value)!=1) error("Second argument to setnamed must a length 1 integer vector");
SET_NAMED(x,INTEGER(value)[0]);
return(x);
}
/* This is a special .Internal */
SEXP attribute_hidden do_vapply(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP R_fcall, ans, names = R_NilValue, rowNames = R_NilValue,
X, XX, FUN, value, dim_v;
R_xlen_t i, n;
int commonLen;
int useNames, rnk_v = -1; // = array_rank(value) := length(dim(value))
Rboolean array_value;
SEXPTYPE commonType;
PROTECT_INDEX index = 0; /* initialize to avoid a warning */
checkArity(op, args);
PROTECT(X = CAR(args));
PROTECT(XX = eval(CAR(args), rho));
FUN = CADR(args); /* must be unevaluated for use in e.g. bquote */
PROTECT(value = eval(CADDR(args), rho));
if (!isVector(value)) error(_("'FUN.VALUE' must be a vector"));
useNames = asLogical(eval(CADDDR(args), rho));
if (useNames == NA_LOGICAL) error(_("invalid '%s' value"), "USE.NAMES");
n = xlength(XX);
if (n == NA_INTEGER) error(_("invalid length"));
Rboolean realIndx = n > INT_MAX;
commonLen = length(value);
if (commonLen > 1 && n > INT_MAX)
error(_("long vectors are not supported for matrix/array results"));
commonType = TYPEOF(value);
// check once here
if (commonType != CPLXSXP && commonType != REALSXP &&
commonType != INTSXP && commonType != LGLSXP &&
commonType != RAWSXP && commonType != STRSXP &&
commonType != VECSXP)
error(_("type '%s' is not supported"), type2char(commonType));
dim_v = getAttrib(value, R_DimSymbol);
array_value = (TYPEOF(dim_v) == INTSXP && LENGTH(dim_v) >= 1);
PROTECT(ans = allocVector(commonType, n*commonLen));
if (useNames) {
PROTECT(names = getAttrib(XX, R_NamesSymbol));
if (isNull(names) && TYPEOF(XX) == STRSXP) {
UNPROTECT(1);
PROTECT(names = XX);
}
PROTECT_WITH_INDEX(rowNames = getAttrib(value,
array_value ? R_DimNamesSymbol
: R_NamesSymbol),
&index);
}
/* The R level code has ensured that XX is a vector.
If it is atomic we can speed things up slightly by
using the evaluated version.
*/
{
SEXP ind, tmp;
/* Build call: FUN(XX[[<ind>]], ...) */
SEXP isym = install("i");
PROTECT(ind = allocVector(realIndx ? REALSXP : INTSXP, 1));
defineVar(isym, ind, rho);
SET_NAMED(ind, 1);
/* Notice that it is OK to have one arg to LCONS do memory
allocation and not PROTECT the result (LCONS does memory
protection of its args internally), but not both of them,
since the computation of one may destroy the other */
PROTECT(tmp = LCONS(R_Bracket2Symbol,
LCONS(X, LCONS(isym, R_NilValue))));
PROTECT(R_fcall = LCONS(FUN,
LCONS(tmp, LCONS(R_DotsSymbol, R_NilValue))));
int common_len_offset = 0;
for(i = 0; i < n; i++) {
SEXP val; SEXPTYPE valType;
PROTECT_INDEX indx;
if (realIndx) REAL(ind)[0] = (double)(i + 1);
else INTEGER(ind)[0] = (int)(i + 1);
val = R_forceAndCall(R_fcall, 1, rho);
if (MAYBE_REFERENCED(val))
val = lazy_duplicate(val); // Need to duplicate? Copying again anyway
PROTECT_WITH_INDEX(val, &indx);
if (length(val) != commonLen)
error(_("values must be length %d,\n but FUN(X[[%d]]) result is length %d"),
commonLen, i+1, length(val));
valType = TYPEOF(val);
if (valType != commonType) {
Rboolean okay = FALSE;
switch (commonType) {
case CPLXSXP: okay = (valType == REALSXP) || (valType == INTSXP)
|| (valType == LGLSXP); break;
case REALSXP: okay = (valType == INTSXP) || (valType == LGLSXP); break;
case INTSXP: okay = (valType == LGLSXP); break;
}
if (!okay)
error(_("values must be type '%s',\n but FUN(X[[%d]]) result is type '%s'"),
type2char(commonType), i+1, type2char(valType));
REPROTECT(val = coerceVector(val, commonType), indx);
}
/* Take row names from the first result only */
if (i == 0 && useNames && isNull(rowNames))
REPROTECT(rowNames = getAttrib(val,
array_value ? R_DimNamesSymbol : R_NamesSymbol),
index);
// two cases - only for efficiency
if(commonLen == 1) { // common case
switch (commonType) {
case CPLXSXP: COMPLEX(ans)[i] = COMPLEX(val)[0]; break;
case REALSXP: REAL(ans) [i] = REAL (val)[0]; break;
case INTSXP: INTEGER(ans)[i] = INTEGER(val)[0]; break;
case LGLSXP: LOGICAL(ans)[i] = LOGICAL(val)[0]; break;
case RAWSXP: RAW(ans) [i] = RAW (val)[0]; break;
case STRSXP: SET_STRING_ELT(ans, i, STRING_ELT(val, 0)); break;
case VECSXP: SET_VECTOR_ELT(ans, i, VECTOR_ELT(val, 0)); break;
}
} else { // commonLen > 1 (typically, or == 0) :
switch (commonType) {
case REALSXP:
memcpy(REAL(ans) + common_len_offset,
REAL(val), commonLen * sizeof(double)); break;
case INTSXP:
memcpy(INTEGER(ans) + common_len_offset,
INTEGER(val), commonLen * sizeof(int)); break;
case LGLSXP:
memcpy(LOGICAL(ans) + common_len_offset,
LOGICAL(val), commonLen * sizeof(int)); break;
case RAWSXP:
memcpy(RAW(ans) + common_len_offset,
RAW(val), commonLen * sizeof(Rbyte)); break;
case CPLXSXP:
memcpy(COMPLEX(ans) + common_len_offset,
COMPLEX(val), commonLen * sizeof(Rcomplex)); break;
case STRSXP:
for (int j = 0; j < commonLen; j++)
SET_STRING_ELT(ans, common_len_offset + j, STRING_ELT(val, j));
break;
case VECSXP:
for (int j = 0; j < commonLen; j++)
SET_VECTOR_ELT(ans, common_len_offset + j, VECTOR_ELT(val, j));
break;
}
common_len_offset += commonLen;
}
UNPROTECT(1);
}
UNPROTECT(3);
}
if (commonLen != 1) {
SEXP dim;
rnk_v = array_value ? LENGTH(dim_v) : 1;
PROTECT(dim = allocVector(INTSXP, rnk_v+1));
if(array_value)
for(int j = 0; j < rnk_v; j++)
INTEGER(dim)[j] = INTEGER(dim_v)[j];
else
INTEGER(dim)[0] = commonLen;
INTEGER(dim)[rnk_v] = (int) n; // checked above
setAttrib(ans, R_DimSymbol, dim);
UNPROTECT(1);
}
if (useNames) {
if (commonLen == 1) {
if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);
} else {
if (!isNull(names) || !isNull(rowNames)) {
SEXP dimnames;
PROTECT(dimnames = allocVector(VECSXP, rnk_v+1));
if(array_value && !isNull(rowNames)) {
if(TYPEOF(rowNames) != VECSXP || LENGTH(rowNames) != rnk_v)
// should never happen ..
error(_("dimnames(<value>) is neither NULL nor list of length %d"),
rnk_v);
for(int j = 0; j < rnk_v; j++)
SET_VECTOR_ELT(dimnames, j, VECTOR_ELT(rowNames, j));
} else
SET_VECTOR_ELT(dimnames, 0, rowNames);
SET_VECTOR_ELT(dimnames, rnk_v, names);
setAttrib(ans, R_DimNamesSymbol, dimnames);
UNPROTECT(1);
}
}
}
UNPROTECT(useNames ? 6 : 4); /* X, XX, value, ans, and maybe names and rowNames */
return ans;
}
SEXP nlm(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP value, names, v, R_gradientSymbol, R_hessianSymbol;
double *x, *typsiz, fscale, gradtl, stepmx,
steptol, *xpls, *gpls, fpls, *a, *wrk, dlt;
int code, i, j, k, itnlim, method, iexp, omsg, msg,
n, ndigit, iagflg, iahflg, want_hessian, itncnt;
/* .Internal(
* nlm(function(x) f(x, ...), p, hessian, typsize, fscale,
* msg, ndigit, gradtol, stepmax, steptol, iterlim)
*/
function_info *state;
args = CDR(args);
PrintDefaults();
state = (function_info *) R_alloc(1, sizeof(function_info));
/* the function to be minimized */
v = CAR(args);
if (!isFunction(v))
error(_("attempt to minimize non-function"));
PROTECT(state->R_fcall = lang2(v, R_NilValue));
args = CDR(args);
/* `p' : inital parameter value */
n = 0;
x = fixparam(CAR(args), &n);
args = CDR(args);
/* `hessian' : H. required? */
want_hessian = asLogical(CAR(args));
if (want_hessian == NA_LOGICAL) want_hessian = 0;
args = CDR(args);
/* `typsize' : typical size of parameter elements */
typsiz = fixparam(CAR(args), &n);
args = CDR(args);
/* `fscale' : expected function size */
fscale = asReal(CAR(args));
if (ISNA(fscale)) error(_("invalid NA value in parameter"));
args = CDR(args);
/* `msg' (bit pattern) */
omsg = msg = asInteger(CAR(args));
if (msg == NA_INTEGER) error(_("invalid NA value in parameter"));
args = CDR(args);
ndigit = asInteger(CAR(args));
if (ndigit == NA_INTEGER) error(_("invalid NA value in parameter"));
args = CDR(args);
gradtl = asReal(CAR(args));
if (ISNA(gradtl)) error(_("invalid NA value in parameter"));
args = CDR(args);
stepmx = asReal(CAR(args));
if (ISNA(stepmx)) error(_("invalid NA value in parameter"));
args = CDR(args);
steptol = asReal(CAR(args));
if (ISNA(steptol)) error(_("invalid NA value in parameter"));
args = CDR(args);
/* `iterlim' (def. 100) */
itnlim = asInteger(CAR(args));
if (itnlim == NA_INTEGER) error(_("invalid NA value in parameter"));
state->R_env = rho;
/* force one evaluation to check for the gradient and hessian */
iagflg = 0; /* No analytic gradient */
iahflg = 0; /* No analytic hessian */
state->have_gradient = 0;
state->have_hessian = 0;
R_gradientSymbol = install("gradient");
R_hessianSymbol = install("hessian");
/* This vector is shared with all subsequent calls */
v = allocVector(REALSXP, n);
for (i = 0; i < n; i++) REAL(v)[i] = x[i];
SETCADR(state->R_fcall, v);
SET_NAMED(v, 2); // in case the functions try to alter it
value = eval(state->R_fcall, state->R_env);
v = getAttrib(value, R_gradientSymbol);
if (v != R_NilValue) {
if (LENGTH(v) == n && (isReal(v) || isInteger(v))) {
iagflg = 1;
state->have_gradient = 1;
v = getAttrib(value, R_hessianSymbol);
if (v != R_NilValue) {
if (LENGTH(v) == (n * n) && (isReal(v) || isInteger(v))) {
iahflg = 1;
state->have_hessian = 1;
} else {
warning(_("hessian supplied is of the wrong length or mode, so ignored"));
}
}
} else {
warning(_("gradient supplied is of the wrong length or mode, so ignored"));
}
}
if (((msg/4) % 2) && !iahflg) { /* skip check of analytic Hessian */
msg -= 4;
}
if (((msg/2) % 2) && !iagflg) { /* skip check of analytic gradient */
msg -= 2;
}
FT_init(n, FT_SIZE, state);
/* Plug in the call to the optimizer here */
method = 1; /* Line Search */
iexp = iahflg ? 0 : 1; /* Function calls are expensive */
dlt = 1.0;
xpls = (double*)R_alloc(n, sizeof(double));
gpls = (double*)R_alloc(n, sizeof(double));
a = (double*)R_alloc(n*n, sizeof(double));
wrk = (double*)R_alloc(8*n, sizeof(double));
/*
* Dennis + Schnabel Minimizer
*
* SUBROUTINE OPTIF9(NR,N,X,FCN,D1FCN,D2FCN,TYPSIZ,FSCALE,
* + METHOD,IEXP,MSG,NDIGIT,ITNLIM,IAGFLG,IAHFLG,IPR,
* + DLT,GRADTL,STEPMX,STEPTOL,
* + XPLS,FPLS,GPLS,ITRMCD,A,WRK)
*
*
* Note: I have figured out what msg does.
* It is actually a sum of bit flags as follows
* 1 = don't check/warn for 1-d problems
* 2 = don't check analytic gradients
* 4 = don't check analytic hessians
* 8 = don't print start and end info
* 16 = print at every iteration
* Using msg=9 is absolutely minimal
* I think we always check gradients and hessians
*/
optif9(n, n, x, (fcn_p) fcn, (fcn_p) Cd1fcn, (d2fcn_p) Cd2fcn,
state, typsiz, fscale, method, iexp, &msg, ndigit, itnlim,
iagflg, iahflg, dlt, gradtl, stepmx, steptol, xpls, &fpls,
gpls, &code, a, wrk, &itncnt);
if (msg < 0)
opterror(msg);
if (code != 0 && (omsg&8) == 0)
optcode(code);
if (want_hessian) {
PROTECT(value = allocVector(VECSXP, 6));
PROTECT(names = allocVector(STRSXP, 6));
fdhess(n, xpls, fpls, (fcn_p) fcn, state, a, n, &wrk[0], &wrk[n],
ndigit, typsiz);
for (i = 0; i < n; i++)
for (j = 0; j < i; j++)
a[i + j * n] = a[j + i * n];
}
else {
PROTECT(value = allocVector(VECSXP, 5));
PROTECT(names = allocVector(STRSXP, 5));
}
k = 0;
SET_STRING_ELT(names, k, mkChar("minimum"));
SET_VECTOR_ELT(value, k, ScalarReal(fpls));
k++;
SET_STRING_ELT(names, k, mkChar("estimate"));
SET_VECTOR_ELT(value, k, allocVector(REALSXP, n));
for (i = 0; i < n; i++)
REAL(VECTOR_ELT(value, k))[i] = xpls[i];
k++;
SET_STRING_ELT(names, k, mkChar("gradient"));
SET_VECTOR_ELT(value, k, allocVector(REALSXP, n));
for (i = 0; i < n; i++)
REAL(VECTOR_ELT(value, k))[i] = gpls[i];
k++;
if (want_hessian) {
SET_STRING_ELT(names, k, mkChar("hessian"));
SET_VECTOR_ELT(value, k, allocMatrix(REALSXP, n, n));
for (i = 0; i < n * n; i++)
REAL(VECTOR_ELT(value, k))[i] = a[i];
k++;
}
SET_STRING_ELT(names, k, mkChar("code"));
SET_VECTOR_ELT(value, k, allocVector(INTSXP, 1));
INTEGER(VECTOR_ELT(value, k))[0] = code;
k++;
/* added by Jim K Lindsey */
SET_STRING_ELT(names, k, mkChar("iterations"));
SET_VECTOR_ELT(value, k, allocVector(INTSXP, 1));
INTEGER(VECTOR_ELT(value, k))[0] = itncnt;
k++;
setAttrib(value, R_NamesSymbol, names);
UNPROTECT(3);
return value;
}
