/* This is a primitive SPECIALSXP */
SEXP attribute_hidden do_expression(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP a, ans, nms;
int i, n, named;
named = 0;
n = length(args);
PROTECT(ans = allocVector(EXPRSXP, n));
a = args;
for (i = 0; i < n; i++) {
if(MAYBE_REFERENCED(CAR(a)))
SET_VECTOR_ELT(ans, i, duplicate(CAR(a)));
else
SET_VECTOR_ELT(ans, i, CAR(a));
if (TAG(a) != R_NilValue) named = 1;
a = CDR(a);
}
if (named) {
PROTECT(nms = allocVector(STRSXP, n));
a = args;
for (i = 0; i < n; i++) {
if (TAG(a) != R_NilValue)
SET_STRING_ELT(nms, i, PRINTNAME(TAG(a)));
else
SET_STRING_ELT(nms, i, R_BlankString);
a = CDR(a);
}
setAttrib(ans, R_NamesSymbol, nms);
UNPROTECT(1);
}
UNPROTECT(1);
return ans;
}
static SEXP do_one(SEXP X, SEXP FUN, SEXP classes, SEXP deflt,
Rboolean replace, SEXP rho)
{
SEXP ans, names, klass;
int i, j, n;
Rboolean matched = FALSE;
/* if X is a list, recurse. Otherwise if it matches classes call f */
if(isNewList(X)) {
n = length(X);
if (replace) {
PROTECT(ans = shallow_duplicate(X));
} else {
PROTECT(ans = allocVector(VECSXP, n));
names = getAttrib(X, R_NamesSymbol);
if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);
}
for(i = 0; i < n; i++)
SET_VECTOR_ELT(ans, i, do_one(VECTOR_ELT(X, i), FUN, classes,
deflt, replace, rho));
UNPROTECT(1);
return ans;
}
if(strcmp(CHAR(STRING_ELT(classes, 0)), "ANY") == 0) /* ASCII */
matched = TRUE;
else {
PROTECT(klass = R_data_class(X, FALSE));
for(i = 0; i < LENGTH(klass); i++)
for(j = 0; j < length(classes); j++)
if(Seql(STRING_ELT(klass, i), STRING_ELT(classes, j)))
matched = TRUE;
UNPROTECT(1);
}
if(matched) {
/* This stores value to which the function is to be applied in
a variable X in the environment of the rapply closure call
that calls into the rapply .Internal. */
SEXP R_fcall; /* could allocate once and preserve for re-use */
SEXP Xsym = install("X");
defineVar(Xsym, X, rho);
INCREMENT_NAMED(X);
/* PROTECT(R_fcall = lang2(FUN, Xsym)); */
PROTECT(R_fcall = lang3(FUN, Xsym, R_DotsSymbol));
ans = R_forceAndCall(R_fcall, 1, rho);
if (MAYBE_REFERENCED(ans))
ans = lazy_duplicate(ans);
UNPROTECT(1);
return(ans);
} else if(replace) return lazy_duplicate(X);
else return lazy_duplicate(deflt);
}
/* 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;
}
SEXP attribute_hidden do_earg_drop(SEXP call, SEXP op, SEXP arg_x, SEXP rho)
{
SEXP x, xdims;
int i, n, shorten;
x = arg_x;
if ((xdims = getDimAttrib(x)) != R_NilValue) {
n = LENGTH(xdims);
shorten = 0;
for (i = 0; i < n; i++)
if (INTEGER(xdims)[i] == 1) shorten = 1;
if (shorten) {
if (MAYBE_REFERENCED(x)) x = duplicate(x);
x = DropDims(x);
}
}
return x;
}
/* 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_drop(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP x, xdims;
int i, n, shorten;
checkArity(op, args);
x = CAR(args);
if ((xdims = getAttrib(x, R_DimSymbol)) != R_NilValue) {
n = LENGTH(xdims);
shorten = 0;
for (i = 0; i < n; i++)
if (INTEGER(xdims)[i] == 1) shorten = 1;
if (shorten) {
if (MAYBE_REFERENCED(x)) x = duplicate(x);
x = DropDims(x);
}
}
return x;
}
SEXP Rmultinom(SEXP args)
{
SEXP prob, ans, nms;
int n, size, k, i, ik;
args = CDR(args);
n = asInteger(CAR(args)); args = CDR(args);/* n= #{samples} */
size = asInteger(CAR(args)); args = CDR(args);/* X ~ Multi(size, prob) */
if (n == NA_INTEGER || n < 0)
error(_("invalid first argument 'n'"));
if (size == NA_INTEGER || size < 0)
error(_("invalid second argument 'size'"));
prob = CAR(args);
prob = coerceVector(prob, REALSXP);
k = length(prob);/* k = #{components or classes} = X-vector length */
if (MAYBE_REFERENCED(prob)) prob = duplicate(prob);/*as `do_sample' -- need this line? */
PROTECT(prob);
/* check and make sum = 1: */
FixupProb(REAL(prob), k, /*require_k = */ 0, TRUE);
GetRNGstate();
PROTECT(ans = allocMatrix(INTSXP, k, n));/* k x n : natural for columnwise store */
for(i=ik = 0; i < n; i++, ik += k) {
// if ((i+1) % NINTERRUPT) R_CheckUserInterrupt();
rmultinom(size, REAL(prob), k, &INTEGER(ans)[ik]);
}
PutRNGstate();
if(!isNull(nms = getAttrib(prob, R_NamesSymbol))) {
SEXP dimnms;
PROTECT(nms);
PROTECT(dimnms = allocVector(VECSXP, 2));
SET_VECTOR_ELT(dimnms, 0, nms);
setAttrib(ans, R_DimNamesSymbol, dimnms);
UNPROTECT(2);
}
UNPROTECT(2);
return ans;
}
/* 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 R_point_in_polygon_sp(const SEXP px, const SEXP py, const SEXP polx,
const SEXP poly) {
int i, pc=0;
PLOT_POINT p;
POLYGON pol;
SEXP ret, px1, py1, polx1, poly1;
if (MAYBE_REFERENCED(px)) {
PROTECT(px1 = duplicate(px));
pc++;
} else
px1 = px;
if (MAYBE_REFERENCED(py)) {
PROTECT(py1 = duplicate(py));
pc++;
} else
py1 = py;
if (MAYBE_REFERENCED(polx)) {
PROTECT(polx1 = duplicate(polx));
pc++;
} else
polx1 = polx;
if (MAYBE_REFERENCED(poly)) {
PROTECT(poly1 = duplicate(poly));
pc++;
} else
poly1 = poly;
pol.lines = LENGTH(polx); /* check later that first == last */
pol.p = (PLOT_POINT *) R_alloc((size_t) pol.lines, sizeof(PLOT_POINT));
/* transient; will be freed by R; freed by R on user interrupt */
for (i = 0; i < LENGTH(polx); i++) {
pol.p[i].x = NUMERIC_POINTER(polx)[i];
pol.p[i].y = NUMERIC_POINTER(poly)[i];
}
pol.close = (pol.p[0].x == pol.p[pol.lines - 1].x &&
pol.p[0].y == pol.p[pol.lines - 1].y);
setup_poly_minmax(&pol);
PROTECT(ret = NEW_INTEGER(LENGTH(px))); pc++;
for (i = 0; i < LENGTH(px); i++) {
p.x = NUMERIC_POINTER(px)[i];
p.y = NUMERIC_POINTER(py)[i];
/*
For each query point q, InPoly returns one of four char's:
i : q is strictly interior to P
o : q is strictly exterior to P
v : q is a vertex of P
e : q lies on the relative interior of an edge of P
*/
switch (InPoly(p, &pol)) {
case 'i': INTEGER_POINTER(ret)[i] = 1; break;
case 'o': INTEGER_POINTER(ret)[i] = 0; break;
case 'v': INTEGER_POINTER(ret)[i] = 3; break;
case 'e': INTEGER_POINTER(ret)[i] = 2; break;
default: INTEGER_POINTER(ret)[i] = -1; break;
}
}
UNPROTECT(pc);
return(ret);
}
SEXP hc_to_be_added(SEXP arcs, SEXP blacklist, SEXP whitelist, SEXP nparents,
SEXP maxp, SEXP nodes, SEXP convert) {
int i = 0, j = 0, narcs = 0, dims = length(nodes);
int *a = NULL, *coords = NULL;
double *mp = REAL(maxp), *np = NULL;
short int referenced = 0;
SEXP try, result = R_NilValue, result2;
/* transform the arc set into an adjacency matrix, if it's not one already. */
if (isInteger(arcs)) {
if ((referenced = MAYBE_REFERENCED(arcs)))
PROTECT(result = duplicate(arcs));
}/*THEN*/
else {
PROTECT(result = arcs2amat(arcs, nodes));
}/*ELSE*/
/* dereference the adjacency matrix once and for all. */
a = INTEGER(result);
/* compute the number the parents of each node, unless provided. */
if (nparents == R_NilValue) {
np = Calloc1D(dims, sizeof(double));
for (i = 0; i < dims; i++)
for (j = 0; j < dims; j++)
np[j] = a[CMC(i, j, dims)];
}/*THEN*/
else {
np = REAL(nparents);
}/*ELSE*/
/* flip all the nondiagonal cells. */
for (j = 0; j < dims; j++) {
for (i = 0; i < dims; i++) {
/* diagonal elements are always equal to zero, skip them. */
if (i == j)
continue;
a[CMC(i, j, dims)] = 1 - a[CMC(i, j, dims)];
}/*FOR*/
}/*FOR*/
/* if an arc is present in the graph in one direction, you cannot add it in
* the other direction (it would be a reversal); flip both in the adjacency
* matrix. */
for (j = 0; j < dims; j++)
for (i = j + 1; i < dims; i++)
a[CMC(j, i, dims)] = a[CMC(i, j, dims)] = a[CMC(i, j, dims)] * a[CMC(j, i, dims)];
/* if a node has already reached its maximum number parents, do not add
* more arcs pointing to that node. */
for (j = 0; j < dims; j++)
if (np[j] >= *mp)
memset(a + j * dims, '\0', dims * sizeof(int));
#define FLIP_FROM_LIST(list, value) \
if (!isNull(list)) { \
if (!isInteger(list)) { \
PROTECT(try = match(nodes, list, 0)); \
coords = INTEGER(try); \
narcs = length(try)/2; \
for (i = 0; i < narcs; i++) \
a[CMC(coords[i] - 1, coords[i + narcs] - 1, dims)] = value; \
UNPROTECT(1); \
}/*THEN*/ \
else { \
coords = INTEGER(list); \
for (i = 0; i < dims * dims; i ++) \
if (coords[i] == 1) \
a[i] = value; \
}/*ELSE*/ \
}/*THEN*/
/* now the blacklist gets involved. */
FLIP_FROM_LIST(blacklist, 0);
/* and, last but not least, the whitelist gets involved. */
FLIP_FROM_LIST(whitelist, 1);
if (nparents == R_NilValue)
Free1D(np);
/* return either the adjacency matrix or the arc set. */
if (isTRUE(convert)) {
PROTECT(result2 = amat2arcs(result, nodes));
if (referenced || !isInteger(arcs))
UNPROTECT(2);
else
UNPROTECT(1);
return result2;
}/*THEN*/
else {
if (referenced || !isInteger(arcs))
UNPROTECT(1);
return result;
}/*ELSE*/
}/*HC_TO_BE_ADDED*/
SEXP attribute_hidden
do_mapply(SEXP call, SEXP op, SEXP args, SEXP rho)
{
checkArity(op, args);
SEXP f = CAR(args), varyingArgs = CADR(args), constantArgs = CADDR(args);
int m, zero = 0;
R_xlen_t *lengths, *counters, longest = 0;
m = length(varyingArgs);
SEXP vnames = PROTECT(getAttrib(varyingArgs, R_NamesSymbol));
Rboolean named = vnames != R_NilValue;
lengths = (R_xlen_t *) R_alloc(m, sizeof(R_xlen_t));
for (int i = 0; i < m; i++) {
SEXP tmp1 = VECTOR_ELT(varyingArgs, i);
lengths[i] = xlength(tmp1);
if (isObject(tmp1)) { // possibly dispatch on length()
/* Cache the .Primitive: unclear caching is worthwhile. */
static SEXP length_op = NULL;
if (length_op == NULL) length_op = R_Primitive("length");
// DispatchOrEval() needs 'args' to be a pairlist
SEXP ans, tmp2 = PROTECT(list1(tmp1));
if (DispatchOrEval(call, length_op, "length", tmp2, rho, &ans, 0, 1))
lengths[i] = (R_xlen_t) (TYPEOF(ans) == REALSXP ?
REAL(ans)[0] : asInteger(ans));
UNPROTECT(1);
}
if (lengths[i] == 0) zero++;
if (lengths[i] > longest) longest = lengths[i];
}
if (zero && longest)
error(_("zero-length inputs cannot be mixed with those of non-zero length"));
counters = (R_xlen_t *) R_alloc(m, sizeof(R_xlen_t));
memset(counters, 0, m * sizeof(R_xlen_t));
SEXP mindex = PROTECT(allocVector(VECSXP, m));
SEXP nindex = PROTECT(allocVector(VECSXP, m));
/* build a call like
f(dots[[1]][[4]], dots[[2]][[4]], dots[[3]][[4]], d=7)
*/
SEXP fcall = R_NilValue; // -Wall
if (constantArgs == R_NilValue)
;
else if (isVectorList(constantArgs))
fcall = VectorToPairList(constantArgs);
else
error(_("argument 'MoreArgs' of 'mapply' is not a list"));
PROTECT_INDEX fi;
PROTECT_WITH_INDEX(fcall, &fi);
Rboolean realIndx = longest > INT_MAX;
SEXP Dots = install("dots");
for (int j = m - 1; j >= 0; j--) {
SET_VECTOR_ELT(mindex, j, ScalarInteger(j + 1));
SET_VECTOR_ELT(nindex, j, allocVector(realIndx ? REALSXP : INTSXP, 1));
SEXP tmp1 = PROTECT(lang3(R_Bracket2Symbol, Dots, VECTOR_ELT(mindex, j)));
SEXP tmp2 = PROTECT(lang3(R_Bracket2Symbol, tmp1, VECTOR_ELT(nindex, j)));
REPROTECT(fcall = LCONS(tmp2, fcall), fi);
UNPROTECT(2);
if (named && CHAR(STRING_ELT(vnames, j))[0] != '\0')
SET_TAG(fcall, installTrChar(STRING_ELT(vnames, j)));
}
REPROTECT(fcall = LCONS(f, fcall), fi);
SEXP ans = PROTECT(allocVector(VECSXP, longest));
for (int i = 0; i < longest; i++) {
for (int j = 0; j < m; j++) {
counters[j] = (++counters[j] > lengths[j]) ? 1 : counters[j];
if (realIndx)
REAL(VECTOR_ELT(nindex, j))[0] = (double) counters[j];
else
INTEGER(VECTOR_ELT(nindex, j))[0] = (int) counters[j];
}
SEXP tmp = eval(fcall, rho);
if (MAYBE_REFERENCED(tmp))
tmp = duplicate(tmp);
SET_VECTOR_ELT(ans, i, tmp);
}
for (int j = 0; j < m; j++)
if (counters[j] != lengths[j])
warning(_("longer argument not a multiple of length of shorter"));
UNPROTECT(5);
return ans;
}
/* par fn gr method options */
SEXP optim(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP par, fn, gr, method, options, tmp, slower, supper;
SEXP res, value, counts, conv;
int i, npar=0, *mask, trace, maxit, fncount = 0, grcount = 0, nREPORT, tmax;
int ifail = 0;
double *dpar, *opar, val = 0.0, abstol, reltol, temp;
const char *tn;
OptStruct OS;
PROTECT_INDEX par_index;
args = CDR(args);
OS = (OptStruct) R_alloc(1, sizeof(opt_struct));
OS->usebounds = 0;
OS->R_env = rho;
par = CAR(args);
OS->names = getAttrib(par, R_NamesSymbol);
args = CDR(args); fn = CAR(args);
if (!isFunction(fn)) error(_("'fn' is not a function"));
args = CDR(args); gr = CAR(args);
args = CDR(args); method = CAR(args);
if (!isString(method)|| LENGTH(method) != 1)
error(_("invalid '%s' argument"), "method");
tn = CHAR(STRING_ELT(method, 0));
args = CDR(args); options = CAR(args);
PROTECT(OS->R_fcall = lang2(fn, R_NilValue));
PROTECT_WITH_INDEX(par = coerceVector(par, REALSXP), &par_index);
if (MAYBE_REFERENCED(par))
REPROTECT(par = duplicate(par), par_index);
npar = LENGTH(par);
dpar = vect(npar);
opar = vect(npar);
trace = asInteger(getListElement(options, "trace"));
OS->fnscale = asReal(getListElement(options, "fnscale"));
tmp = getListElement(options, "parscale");
if (LENGTH(tmp) != npar)
error(_("'parscale' is of the wrong length"));
PROTECT(tmp = coerceVector(tmp, REALSXP));
OS->parscale = vect(npar);
for (i = 0; i < npar; i++) OS->parscale[i] = REAL(tmp)[i];
UNPROTECT(1);
for (i = 0; i < npar; i++)
dpar[i] = REAL(par)[i] / (OS->parscale[i]);
PROTECT(res = allocVector(VECSXP, 5));
SEXP names;
PROTECT(names = allocVector(STRSXP, 5));
SET_STRING_ELT(names, 0, mkChar("par"));
SET_STRING_ELT(names, 1, mkChar("value"));
SET_STRING_ELT(names, 2, mkChar("counts"));
SET_STRING_ELT(names, 3, mkChar("convergence"));
SET_STRING_ELT(names, 4, mkChar("message"));
setAttrib(res, R_NamesSymbol, names);
UNPROTECT(1);
PROTECT(value = allocVector(REALSXP, 1));
PROTECT(counts = allocVector(INTSXP, 2));
SEXP countnames;
PROTECT(countnames = allocVector(STRSXP, 2));
SET_STRING_ELT(countnames, 0, mkChar("function"));
SET_STRING_ELT(countnames, 1, mkChar("gradient"));
setAttrib(counts, R_NamesSymbol, countnames);
UNPROTECT(1);
PROTECT(conv = allocVector(INTSXP, 1));
abstol = asReal(getListElement(options, "abstol"));
reltol = asReal(getListElement(options, "reltol"));
maxit = asInteger(getListElement(options, "maxit"));
if (maxit == NA_INTEGER) error(_("'maxit' is not an integer"));
if (strcmp(tn, "Nelder-Mead") == 0) {
double alpha, beta, gamm;
alpha = asReal(getListElement(options, "alpha"));
beta = asReal(getListElement(options, "beta"));
gamm = asReal(getListElement(options, "gamma"));
nmmin(npar, dpar, opar, &val, fminfn, &ifail, abstol, reltol,
(void *)OS, alpha, beta, gamm, trace, &fncount, maxit);
for (i = 0; i < npar; i++)
REAL(par)[i] = opar[i] * (OS->parscale[i]);
grcount = NA_INTEGER;
}
else if (strcmp(tn, "SANN") == 0) {
tmax = asInteger(getListElement(options, "tmax"));
temp = asReal(getListElement(options, "temp"));
if (trace) trace = asInteger(getListElement(options, "REPORT"));
if (tmax == NA_INTEGER || tmax < 1) // PR#15194
error(_("'tmax' is not a positive integer"));
if (!isNull(gr)) {
if (!isFunction(gr)) error(_("'gr' is not a function"));
PROTECT(OS->R_gcall = lang2(gr, R_NilValue));
} else {
PROTECT(OS->R_gcall = R_NilValue); /* for balance */
}
samin (npar, dpar, &val, fminfn, maxit, tmax, temp, trace, (void *)OS);
for (i = 0; i < npar; i++)
REAL(par)[i] = dpar[i] * (OS->parscale[i]);
fncount = npar > 0 ? maxit : 1;
grcount = NA_INTEGER;
UNPROTECT(1); /* OS->R_gcall */
} else if (strcmp(tn, "BFGS") == 0) {
SEXP ndeps;
nREPORT = asInteger(getListElement(options, "REPORT"));
if (!isNull(gr)) {
if (!isFunction(gr)) error(_("'gr' is not a function"));
PROTECT(OS->R_gcall = lang2(gr, R_NilValue));
} else {
PROTECT(OS->R_gcall = R_NilValue); /* for balance */
ndeps = getListElement(options, "ndeps");
if (LENGTH(ndeps) != npar)
error(_("'ndeps' is of the wrong length"));
OS->ndeps = vect(npar);
PROTECT(ndeps = coerceVector(ndeps, REALSXP));
for (i = 0; i < npar; i++) OS->ndeps[i] = REAL(ndeps)[i];
UNPROTECT(1);
}
mask = (int *) R_alloc(npar, sizeof(int));
for (i = 0; i < npar; i++) mask[i] = 1;
vmmin(npar, dpar, &val, fminfn, fmingr, maxit, trace, mask, abstol,
reltol, nREPORT, (void *)OS, &fncount, &grcount, &ifail);
for (i = 0; i < npar; i++)
REAL(par)[i] = dpar[i] * (OS->parscale[i]);
UNPROTECT(1); /* OS->R_gcall */
} else if (strcmp(tn, "CG") == 0) {
int type;
SEXP ndeps;
type = asInteger(getListElement(options, "type"));
if (!isNull(gr)) {
if (!isFunction(gr)) error(_("'gr' is not a function"));
PROTECT(OS->R_gcall = lang2(gr, R_NilValue));
} else {
PROTECT(OS->R_gcall = R_NilValue); /* for balance */
ndeps = getListElement(options, "ndeps");
if (LENGTH(ndeps) != npar)
error(_("'ndeps' is of the wrong length"));
OS->ndeps = vect(npar);
PROTECT(ndeps = coerceVector(ndeps, REALSXP));
for (i = 0; i < npar; i++) OS->ndeps[i] = REAL(ndeps)[i];
UNPROTECT(1);
}
cgmin(npar, dpar, opar, &val, fminfn, fmingr, &ifail, abstol,
reltol, (void *)OS, type, trace, &fncount, &grcount, maxit);
for (i = 0; i < npar; i++)
REAL(par)[i] = opar[i] * (OS->parscale[i]);
UNPROTECT(1); /* OS->R_gcall */
} else if (strcmp(tn, "L-BFGS-B") == 0) {
SEXP ndeps, smsg;
double *lower = vect(npar), *upper = vect(npar);
int lmm, *nbd = (int *) R_alloc(npar, sizeof(int));
double factr, pgtol;
char msg[60];
nREPORT = asInteger(getListElement(options, "REPORT"));
factr = asReal(getListElement(options, "factr"));
pgtol = asReal(getListElement(options, "pgtol"));
lmm = asInteger(getListElement(options, "lmm"));
if (!isNull(gr)) {
if (!isFunction(gr)) error(_("'gr' is not a function"));
PROTECT(OS->R_gcall = lang2(gr, R_NilValue));
} else {
PROTECT(OS->R_gcall = R_NilValue); /* for balance */
ndeps = getListElement(options, "ndeps");
if (LENGTH(ndeps) != npar)
error(_("'ndeps' is of the wrong length"));
OS->ndeps = vect(npar);
PROTECT(ndeps = coerceVector(ndeps, REALSXP));
for (i = 0; i < npar; i++) OS->ndeps[i] = REAL(ndeps)[i];
UNPROTECT(1);
}
args = CDR(args); slower = CAR(args); /* coerce in calling code */
args = CDR(args); supper = CAR(args);
for (i = 0; i < npar; i++) {
lower[i] = REAL(slower)[i] / (OS->parscale[i]);
upper[i] = REAL(supper)[i] / (OS->parscale[i]);
if (!R_FINITE(lower[i])) {
if (!R_FINITE(upper[i])) nbd[i] = 0; else nbd[i] = 3;
} else {
if (!R_FINITE(upper[i])) nbd[i] = 1; else nbd[i] = 2;
}
}
OS->usebounds = 1;
OS->lower = lower;
OS->upper = upper;
lbfgsb(npar, lmm, dpar, lower, upper, nbd, &val, fminfn, fmingr,
&ifail, (void *)OS, factr, pgtol, &fncount, &grcount,
maxit, msg, trace, nREPORT);
for (i = 0; i < npar; i++)
REAL(par)[i] = dpar[i] * (OS->parscale[i]);
UNPROTECT(1); /* OS->R_gcall */
PROTECT(smsg = mkString(msg));
SET_VECTOR_ELT(res, 4, smsg);
UNPROTECT(1);
} else
error(_("unknown 'method'"));
if(!isNull(OS->names)) setAttrib(par, R_NamesSymbol, OS->names);
REAL(value)[0] = val * (OS->fnscale);
SET_VECTOR_ELT(res, 0, par); SET_VECTOR_ELT(res, 1, value);
INTEGER(counts)[0] = fncount; INTEGER(counts)[1] = grcount;
SET_VECTOR_ELT(res, 2, counts);
INTEGER(conv)[0] = ifail;
SET_VECTOR_ELT(res, 3, conv);
UNPROTECT(6);
return res;
}