static SEXP CreateGrad(SEXP names)
{
SEXP p, q, data, dim, dimnames;
int i, n;
n = length(names);
PROTECT(dimnames = lang3(R_NilValue, R_NilValue, R_NilValue));
SETCAR(dimnames, install("list"));
p = install("c");
PROTECT(q = allocList(n));
SETCADDR(dimnames, LCONS(p, q));
UNPROTECT(1);
for(i = 0 ; i < n ; i++) {
SETCAR(q, ScalarString(STRING_ELT(names, i)));
q = CDR(q);
}
PROTECT(dim = lang3(R_NilValue, R_NilValue, R_NilValue));
SETCAR(dim, install("c"));
SETCADR(dim, lang2(install("length"), install(".value")));
SETCADDR(dim, ScalarInteger(length(names))); /* was real? */
PROTECT(data = ScalarReal(0.));
PROTECT(p = lang4(install("array"), data, dim, dimnames));
p = lang3(install("<-"), install(".grad"), p);
UNPROTECT(4);
return p;
}
static SEXP AddHess(void)
{
SEXP ans;
PROTECT(ans = mkString("hessian"));
PROTECT(ans = lang3(install("attr"), install(".value"), ans));
ans = lang3(install("<-"), ans, install(".hessian"));
UNPROTECT(2);
return ans;
}
static SEXP AddGrad(void)
{
SEXP ans;
PROTECT(ans = mkString("gradient"));
PROTECT(ans = lang3(install("attr"), install(".value"), ans));
ans = lang3(install("<-"), ans, install(".grad"));
UNPROTECT(2);
return ans;
}
static SEXP HessAssign2(SEXP name1, SEXP name2, SEXP expr)
{
SEXP ans, newname1, newname2, tmp1, tmp2, tmp3;
PROTECT(newname1 = ScalarString(name1));
PROTECT(newname2 = ScalarString(name2));
/* this is overkill, but PR#14772 found an issue */
PROTECT(tmp1 = lang5(R_BracketSymbol, install(".hessian"), R_MissingArg,
newname1, newname2));
PROTECT(tmp2 = lang5(R_BracketSymbol, install(".hessian"), R_MissingArg,
newname2, newname1));
PROTECT(tmp3 = lang3(install("<-"), tmp2, expr));
ans = lang3(install("<-"), tmp1, tmp3);
UNPROTECT(5);
return ans;
}
static void RAPHAEL_NewPage(const pGEcontext gc, pDevDesc dev) {
DOCDesc *pd = (DOCDesc *) dev->deviceSpecific;
if (pd->pageNumber > 0) {
eval( lang2(install("triggerPostCommand"), pd->env ), R_GlobalEnv);
closeFile(pd->dmlFilePointer);
}
int which = pd->pageNumber % pd->maxplot;
pd->pageNumber++;
pd->canvas_id++;
dev->right = pd->width[which];
dev->bottom = pd->height[which];
dev->left = 0;
dev->top = 0;
dev->clipLeft = 0;
dev->clipRight = dev->right;
dev->clipBottom = dev->bottom;
dev->clipTop = 0;
pd->clippedx0 = dev->clipLeft;
pd->clippedy0 = dev->clipTop;
pd->clippedx1 = dev->clipRight;
pd->clippedy1 = dev->clipBottom;
pd->offx = pd->x[which];
pd->offy = pd->y[which];
pd->extx = pd->width[which];
pd->exty = pd->height[which];
char *filename={0};
filename = get_raphael_filename(pd->filename, pd->pageNumber);
pd->dmlFilePointer = (FILE *) fopen(filename, "w");
char *canvasname={0};
canvasname = get_raphael_canvasname(pd->canvas_id);
if (pd->dmlFilePointer == NULL) {
Rf_error("error while opening %s\n", filename);
}
updateFontInfo(dev, gc);
pd->objectname = get_raphael_jsobject_name(pd->filename, pd->canvas_id);
fprintf(pd->dmlFilePointer, "var %s = new Raphael(document.getElementById('%s'), %.0f, %.0f);\n"
, pd->objectname, canvasname, dev->right, dev->bottom);
SEXP cmdSexp = PROTECT(allocVector(STRSXP, 3));
SET_STRING_ELT(cmdSexp, 0, mkChar(filename));
SET_STRING_ELT(cmdSexp, 1, mkChar(pd->objectname));
SET_STRING_ELT(cmdSexp, 2, mkChar(canvasname));
eval( lang3(install("registerRaphaelGraph")
, cmdSexp, pd->env
), R_GlobalEnv);
UNPROTECT(1);
free(filename);
free(canvasname);
}
double run_fun(SEXP Rfun, SEXP Rvect1, SEXP Rvect2) {
SEXP e, result;
PROTECT(e = lang3(Rfun, Rvect1, Rvect2));
result = eval(e, R_GlobalEnv);
UNPROTECT(1);
return (REAL(result)[0]);
}
static SEXP DerivAssign(SEXP name, SEXP expr)
{
SEXP ans, newname;
PROTECT(ans = lang3(install("<-"), R_NilValue, expr));
PROTECT(newname = ScalarString(name));
SETCADR(ans, lang4(R_BracketSymbol, install(".grad"), R_MissingArg, newname));
UNPROTECT(2);
return ans;
}
SEXP rzmq_serialize(SEXP data, SEXP rho) {
static SEXP R_serialize_fun = findVar(install("serialize"), R_GlobalEnv);
SEXP R_fcall, ans;
if(!isEnvironment(rho)) error("'rho' should be an environment");
PROTECT(R_fcall = lang3(R_serialize_fun, data, R_NilValue));
PROTECT(ans = eval(R_fcall, rho));
UNPROTECT(2);
return ans;
}
/*
Helper fun for `attr(dimnames(), x)`
Returns wrap object, length 2 VECSXP containing wrap call and pointer
to element to substiute
*/
SEXP ALIKEC_compare_dimnames_wrap(const char * name) {
SEXP wrap = PROTECT(allocVector(VECSXP, 2));
SET_VECTOR_ELT(
wrap, 0, lang3(
ALIKEC_SYM_attr, lang2(R_DimNamesSymbol, R_NilValue),
mkString(name)
) );
SET_VECTOR_ELT(wrap, 1, CDDR(VECTOR_ELT(wrap, 0)));
UNPROTECT(1);
return(wrap);
}
static void C_event_func (int *n, double *t, double *y) {
int i;
SEXP R_fcall, Time, ans;
for (i = 0; i < *n; i++) REAL(Y)[i] = y[i];
PROTECT(Time = ScalarReal(*t)); incr_N_Protect();
PROTECT(R_fcall = lang3(R_event_func,Time,Y)); incr_N_Protect();
PROTECT(ans = eval(R_fcall, R_envir)); incr_N_Protect();
for (i = 0; i < *n; i++) y[i] = REAL(ans)[i];
my_unprotect(3);
}
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);
}
SEXP getPatches(SEXP sa, SEXP sb, SEXP snbond, SEXP snvert)
{
int *a = INTEGER(sa);
int *b = INTEGER(sb);
int n1 = asInteger(snbond);
int n2 = asInteger(snvert);
SEXP val, vertex;
PROTECT( val = allocVector(INTSXP, n2));
PROTECT( vertex = allocVector(INTSXP, n2));
int *f = INTEGER(val);
int *v = INTEGER(vertex);
int i, p0, q0, p1, q1;
for(i = 0; i < n2; i++){
f[i] = i;
v[i] = i;
}
for(i = 0; i < n1; i++){
p0 = a[i];
q0 = b[i];
p1 = f[p0];
q1 = f[q0];
while(p1 != q1){
if(q1 < p1){
f[p0] = q1;
p0 = p1;
p1 = f[p1];
}
else{
f[q0] = p1;
q0 = q1;
q1 = f[q1];
}
}
}
for(i = 0; i < n2; i++){
f[i] = f[f[i]];
}
SEXP patches;
PROTECT(patches = eval(lang3(install("split"), vertex, val),R_BaseEnv));
UNPROTECT(3);
return patches;
}
SEXP R_exec3 (const char* command, SEXP structure1, SEXP structure2) {
SEXP e;
SEXP val = NILSXP;
int errorOccurred;
PROTECT(e = lang3(install((char*) command), structure1, structure2));
val = R_tryEval(e, R_GlobalEnv, &errorOccurred);
UNPROTECT(1);
if (!errorOccurred) {
return(val);
}
else {
return(NILSXP);
}
}
static void C_jac_func_gb (int *neq, double *t, double *y, int *ml,
int *mu, double *pd, int *nrowpd, double *yout, int *iout)
{
int i;
SEXP R_fcall, Time, ans;
for (i = 0; i < *neq; i++) REAL(Y)[i] = y[i];
PROTECT(Time = ScalarReal(*t)); incr_N_Protect();
PROTECT(R_fcall = lang3(R_jac_func,Time,Y)); incr_N_Protect();
PROTECT(ans = eval(R_fcall, R_envir)); incr_N_Protect();
for (i = 0; i < *neq * *nrowpd; i++) pd[i] = REAL(ans)[i];
my_unprotect(3);
}
static void C_zderiv_func (int *neq, double *t, Rcomplex *y,
Rcomplex *ydot, Rcomplex *yout, int *iout)
{
int i;
SEXP R_fcall, Time, ans;
for (i = 0; i < *neq; i++) COMPLEX(cY)[i] = y[i];
PROTECT(Time = ScalarReal(*t)); incr_N_Protect();
PROTECT(R_fcall = lang3(R_zderiv_func,Time,cY)) ;incr_N_Protect();
PROTECT(ans = eval(R_fcall, R_vode_envir)) ;incr_N_Protect();
for (i = 0; i < *neq; i++) ydot[i] = COMPLEX(VECTOR_ELT(ans,0))[i];
my_unprotect(3);
}
static void C_zjac_func (int *neq, double *t, Rcomplex *y, int *ml,
int *mu, Rcomplex *pd, int *nrowpd, Rcomplex *yout, int *iout)
{
int i;
SEXP R_fcall, Time, ans;
for (i = 0; i < *neq; i++) COMPLEX(cY)[i] = y[i];
PROTECT(Time = ScalarReal(*t)); incr_N_Protect();
PROTECT(R_fcall = lang3(R_zjac_func,Time,cY)); incr_N_Protect();
PROTECT(ans = eval(R_fcall, R_vode_envir)); incr_N_Protect();
for (i = 0; i < *neq * *nrowpd; i++) pd[i ] = COMPLEX(ans)[i ];
my_unprotect(3);
}
static void C_deriv_func_gb (int *neq, double *t, double *y,
double *ydot, double *yout, int *iout)
{
int i;
SEXP R_fcall, Time, ans;
for (i = 0; i < *neq; i++) REAL(Y)[i] = y[i];
PROTECT(Time = ScalarReal(*t)); incr_N_Protect();
PROTECT(R_fcall = lang3(R_deriv_func,Time,Y)); incr_N_Protect();
PROTECT(ans = eval(R_fcall, R_envir)); incr_N_Protect();
for (i = 0; i < *neq; i++) ydot[i] = REAL(ans)[i];
my_unprotect(3);
}
static void C_stsparse_derivs (int *neq, double *t, double *y, double *ydot,
double *yout, int *iout)
{
int i;
SEXP R_fcall, ans;
REAL(Time)[0] = *t;
for (i = 0; i < *neq; i++) REAL(Y)[i] = y[i];
PROTECT(R_fcall = lang3(stsparse_deriv_func,Time,Y)) ;incr_N_Protect();
PROTECT(ans = eval(R_fcall, stsparse_envir)) ;incr_N_Protect();
for (i = 0; i < *neq; i++) ydot[i] = REAL(VECTOR_ELT(ans,0))[i];
my_unprotect(2);
}
char *oc_register(SEXP what, char *dst, int len, const char *name) {
SEXP x;
if (len <= MAX_OC_TOKEN_LEN) return NULL;
if (!oc_env) {
SEXP env = eval(PROTECT(lang3(install("new.env"), ScalarLogical(TRUE), R_EmptyEnv)), R_GlobalEnv);
UNPROTECT(1);
if (TYPEOF(env) != ENVSXP) return NULL;
oc_env = env;
R_PreserveObject(oc_env);
}
x = PROTECT(CONS(what, R_NilValue));
if (name) SET_TAG(x, install(name));
oc_new(dst);
Rf_defineVar(install(dst), x, oc_env);
UNPROTECT(1);
return dst;
}
/*
Compare time series attribute; some day will have to actually get an error
display that can handle floats
*/
struct ALIKEC_res_sub ALIKEC_compare_ts(
SEXP target, SEXP current, struct ALIKEC_settings set
) {
SEXPTYPE tar_type = TYPEOF(target);
struct ALIKEC_res_sub res = ALIKEC_res_sub_def();
if(
tar_type == REALSXP && TYPEOF(current) == tar_type &&
XLENGTH(target) == 3 && XLENGTH(current) == 3
) {
double * tar_real = REAL(target), * cur_real = REAL(current);
for(R_xlen_t i = 0; i < 3; i++) {
if(tar_real[i] != 0 && tar_real[i] != cur_real[i]) {
res.success = 0;
char * tar_num = R_alloc(21, sizeof(char));
char * cur_num = R_alloc(21, sizeof(char));
snprintf(tar_num, 20, "%g", tar_real[i]);
snprintf(cur_num, 20, "%g", cur_real[i]);
res.message = PROTECT(
ALIKEC_res_msg_def(
"be",
CSR_smprintf4(
ALIKEC_MAX_CHAR, "%s", tar_num, "", "", ""
),
"is",
CSR_smprintf4(
ALIKEC_MAX_CHAR, "%s", cur_num, "", "", ""
)
) );
SEXP wrap = PROTECT(allocVector(VECSXP, 2));
SET_VECTOR_ELT(
wrap, 0, lang3(
R_BracketSymbol, lang2(R_TspSymbol, R_NilValue),
ScalarReal(i + 1)
) );
SET_VECTOR_ELT(wrap, 1, CDR(CADR(VECTOR_ELT(wrap, 0))));
SET_VECTOR_ELT(res.message, 1, wrap);
UNPROTECT(2);
return res;
} }
} else {
return ALIKEC_alike_attr(target, current, R_TspSymbol, set, 0);
}
return res;
}
SEXP xts_period_apply(SEXP _data, SEXP _index, SEXP _function, SEXP _env)
{
if (!isInteger(_index)) {
error("index must be integer");
}
int i;
R_xlen_t n = xlength(_index);
SEXP _result = PROTECT(allocVector(VECSXP, n));
SEXP _j = PROTECT(allocVector(INTSXP, ncols(_data)));
SEXP _drop = PROTECT(ScalarLogical(0));
int *index = INTEGER(_index);
for (i = 0; i < ncols(_data); i++)
INTEGER(_j)[i] = i + 1;
SEXP _idx0 = PROTECT(ScalarInteger(0));
SEXP _idx1 = PROTECT(ScalarInteger(0));
int *idx0 = INTEGER(_idx0);
int *idx1 = INTEGER(_idx1);
/* reprotect the subset object */
SEXP _xsubset;
PROTECT_INDEX px;
PROTECT_WITH_INDEX(_xsubset = R_NilValue, &px);
/* subset object name */
SEXP _subsym = install("_.*crazy*._.*name*._");
defineVar(_subsym, _xsubset, _env);
/* function call on subset */
SEXP _subcall = PROTECT(lang3(_function, _subsym, R_DotsSymbol));
int N = n - 1;
for (i = 0; i < N; i++) {
idx0[0] = index[i] + 1;
idx1[0] = index[i + 1];
REPROTECT(_xsubset = extract_col(_data, _j, _drop, _idx0, _idx1), px);
defineVar(_subsym, _xsubset, _env);
SET_VECTOR_ELT(_result, i, eval(_subcall, _env));
}
UNPROTECT(7);
return _result;
}
/* the mass matrix function */
static void C_mas_func (int *neq, double *am, int *lmas,
double *yout, int *iout)
{
int i;
SEXP NEQ, LM, R_fcall, ans;
PROTECT(NEQ = NEW_INTEGER(1)); incr_N_Protect();
PROTECT(LM = NEW_INTEGER(1)); incr_N_Protect();
INTEGER(NEQ)[0] = *neq;
INTEGER(LM) [0] = *lmas;
PROTECT(R_fcall = lang3(R_mas_func,NEQ,LM)); incr_N_Protect();
PROTECT(ans = eval(R_fcall, R_envir)); incr_N_Protect();
for (i = 0; i <*lmas * *neq; i++) am[i] = REAL(ans)[i];
my_unprotect(4);
}
void updateFontInfo(pDevDesc dev, R_GE_gcontext *gc) {
DOCDesc *pd = (DOCDesc *) dev->deviceSpecific;
SEXP out;
char *fontname;
if( gc->fontface == 5 ) {
fontname = strdup("Symbol");
} else if( strlen( gc->fontfamily ) > 0 ) {
fontname = strdup(gc->fontfamily);
} else if( pd->fi->isinit > 0 ) {
fontname = strdup(pd->fi->fontname);
} else {
fontname = strdup(pd->fontname);
}
int fonsize = (int)getFontSize(gc->cex, gc->ps, gc->lineheight);
if (pd->fi->isinit < 1 || strcmp(pd->fi->fontname, fontname) != 0 || pd->fi->fontsize != fonsize) {
pd->fi->fontsize = fonsize;
pd->fi->fontname = fontname;
pd->fi->isinit = 1;
out = eval(
lang3(install("FontMetric"), mkString(fontname),
ScalarInteger(pd->fi->fontsize)), R_GlobalEnv);
int *fm = INTEGER(VECTOR_ELT(out, 0));
int *widthstemp = INTEGER(VECTOR_ELT(out, 1));
int f = 0;
int i = 0;
for (f = 0; f < 4; f++) {
pd->fi->ascent[f] = fm[f * 3 + 0];
pd->fi->descent[f] = fm[f * 3 + 1];
pd->fi->height[f] = fm[f * 3 + 2];
}
for (i = 0; i < 1024; i++)
pd->fi->widths[i] = widthstemp[i];
}
}
static SEXP do_one(SEXP X, SEXP FUN, SEXP classes, SEXP deflt,
Rboolean replace, SEXP rho)
{
SEXP ans, names, klass, R_fcall;
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);
PROTECT(ans = allocVector(VECSXP, n));
names = getAttrib(X, R_NamesSymbol);
/* or copy attributes if replace = TRUE? */
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) {
/* PROTECT(R_fcall = lang2(FUN, X)); */
PROTECT(R_fcall = lang3(FUN, X, R_DotsSymbol));
ans = eval(R_fcall, rho);
if (NAMED(ans))
ans = duplicate(ans);
UNPROTECT(1);
return(ans);
} else if(replace) return duplicate(X);
else return duplicate(deflt);
}
int inla_R_funcall2(int *n_out, double **x_out, const char *function, const char *tag, int n, double *x)
{
/*
* Call function(tag,x), where x is a double vector of length n. output is 'x_out' with length 'n_out'
*/
inla_R_init();
#pragma omp critical
{
if (R_debug)
fprintf(stderr, "R-interface[%1d]: funcall2: function [%s] tag [%s] n [%1d]\n",
omp_get_thread_num(), function, tag, n);
int error, i;
SEXP yy, xx, result, e;
PROTECT(yy = mkString((tag ? tag : "<<<NoTag>>>")));
PROTECT(xx = allocVector(REALSXP, n));
for(i=0; i<n; i++) {
REAL(xx)[i] = x[i];
}
if (tag) {
PROTECT(e = lang3(install(function), yy, xx));
} else {
PROTECT(e = lang2(install(function), xx));
}
PROTECT(result = R_tryEval(e, R_GlobalEnv, &error));
if (error){
fprintf(stderr, "\n *** ERROR *** Calling R-function [%s] with tag [%s] and [%1d] arguments\n",
function, tag, n);
exit(1);
}
*n_out = (int) XLENGTH(result);
*x_out = (double *) calloc((size_t) *n_out, sizeof(double)); /* otherwise I'' use the R-version... */
for(i = 0; i< *n_out; i++) {
(*x_out)[i] = REAL(result)[i];
}
UNPROTECT(4);
}
return INLA_OK;
}
/*
Utility function to make a wrap sexp like `names(call)` when none exists
already; uses the symbol if it is one known to have an accessor function,
otherwise `attr(call, "x")`.
*/
SEXP ALIKEC_attr_wrap(SEXP tag, SEXP call) {
if(TYPEOF(tag) != SYMSXP) error("attr_wrap only valid with tags");
SEXP wrap = PROTECT(allocVector(VECSXP, 2));
// Tags with accessor functions
if(
tag == R_NamesSymbol || tag == R_ClassSymbol || tag == R_TspSymbol ||
tag == R_RowNamesSymbol || tag == R_DimNamesSymbol || tag == R_DimSymbol ||
tag == R_LevelsSymbol
) {
SET_VECTOR_ELT(wrap, 0, lang2(tag, call));
} else {
SEXP tag_name = PROTECT(allocVector(STRSXP, 1));
SET_STRING_ELT(tag_name, 0, PRINTNAME(tag));
SET_VECTOR_ELT(wrap, 0, lang3(ALIKEC_SYM_attr, call, tag_name));
UNPROTECT(1);
}
SET_VECTOR_ELT(wrap, 1, CDR(VECTOR_ELT(wrap, 0)));
UNPROTECT(1);
return wrap;
}
static void fftn_c2r(const Rcomplex *z, R_len_t rank, const R_len_t *N,
double *res) {
SEXP rTrue, cA, dim, Res;
R_len_t n = prod(rank, N), i;
rTrue = PROTECT(allocVector(LGLSXP, 1));
LOGICAL(rTrue)[0] = 1;
cA = PROTECT(allocVector(CPLXSXP, n));
memcpy(COMPLEX(cA), z, sizeof(Rcomplex) * n);
dim = PROTECT(allocVector(INTSXP, rank));
memcpy(INTEGER(dim), N, sizeof(R_len_t) * rank);
setAttrib(cA, R_DimSymbol, dim);
Res = PROTECT(eval(lang3(install("fft"), cA, rTrue), R_GlobalEnv));
/* Return result */
for (i = 0; i < n; ++i)
res[i] = COMPLEX(Res)[i].r;
/* Unprotect all */
UNPROTECT(4);
}
SEXP attribute_hidden
do_mapply(SEXP f, SEXP varyingArgs, SEXP constantArgs, SEXP rho)
{
int i, j, m, *lengths, *counters, named, longest = 0, zero = 0;
SEXP vnames, fcall = R_NilValue, mindex, nindex, tmp1, tmp2, ans;
m = length(varyingArgs);
vnames = PROTECT(getAttrib(varyingArgs, R_NamesSymbol));
named = vnames != R_NilValue;
lengths = (int *) R_alloc(m, sizeof(int));
for(i = 0; i < m; i++){
lengths[i] = length(VECTOR_ELT(varyingArgs, i));
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 = (int *) R_alloc(m, sizeof(int));
for(i = 0; i < m; counters[i++] = 0);
mindex = PROTECT(allocVector(VECSXP, m));
nindex = PROTECT(allocVector(VECSXP, m));
/* build a call like
f(dots[[1]][[4]], dots[[2]][[4]], dots[[3]][[4]], d=7)
*/
if (constantArgs == R_NilValue)
PROTECT(fcall = R_NilValue);
else if(isVectorList(constantArgs))
PROTECT(fcall = VectorToPairList(constantArgs));
else
error(_("argument 'MoreArgs' of 'mapply' is not a list"));
for(j = m - 1; j >= 0; j--) {
SET_VECTOR_ELT(mindex, j, ScalarInteger(j + 1));
SET_VECTOR_ELT(nindex, j, allocVector(INTSXP, 1));
PROTECT(tmp1 = lang3(R_Bracket2Symbol,
install("dots"),
VECTOR_ELT(mindex, j)));
PROTECT(tmp2 = lang3(R_Bracket2Symbol,
tmp1,
VECTOR_ELT(nindex, j)));
UNPROTECT(3);
PROTECT(fcall = LCONS(tmp2, fcall));
if (named && CHAR(STRING_ELT(vnames, j))[0] != '\0')
SET_TAG(fcall, install(translateChar(STRING_ELT(vnames, j))));
}
UNPROTECT(1);
PROTECT(fcall = LCONS(f, fcall));
PROTECT(ans = allocVector(VECSXP, longest));
for(i = 0; i < longest; i++) {
for(j = 0; j < m; j++) {
counters[j] = (++counters[j] > lengths[j]) ? 1 : counters[j];
INTEGER(VECTOR_ELT(nindex, j))[0] = counters[j];
}
SET_VECTOR_ELT(ans, i, eval(fcall, rho));
}
for(j = 0; j < m; j++) {
if (counters[j] != lengths[j])
warning(_("longer argument not a multiple of length of shorter"));
}
UNPROTECT(5);
return(ans);
}
SEXP do_edit(SEXP call, SEXP op, SEXP args, SEXP rho)
{
int i, rc;
ParseStatus status;
SEXP x, fn, envir, ed, src, srcfile, Rfn;
char *filename, *editcmd;
const char *cmd;
const void *vmaxsave;
FILE *fp;
#ifdef Win32
SEXP ti;
char *title;
#endif
checkArity(op, args);
vmaxsave = vmaxget();
x = CAR(args); args = CDR(args);
if (TYPEOF(x) == CLOSXP) envir = CLOENV(x);
else envir = R_NilValue;
PROTECT(envir);
fn = CAR(args); args = CDR(args);
if (!isString(fn))
error(_("invalid argument to edit()"));
if (LENGTH(STRING_ELT(fn, 0)) > 0) {
const char *ss = translateChar(STRING_ELT(fn, 0));
filename = R_alloc(strlen(ss), sizeof(char));
strcpy(filename, ss);
}
else filename = DefaultFileName;
if (x != R_NilValue) {
if((fp=R_fopen(R_ExpandFileName(filename), "w")) == NULL)
errorcall(call, _("unable to open file"));
if (LENGTH(STRING_ELT(fn, 0)) == 0) EdFileUsed++;
if (TYPEOF(x) != CLOSXP || isNull(src = getAttrib(x, R_SourceSymbol)))
src = deparse1(x, CXXRFALSE, FORSOURCING); /* deparse for sourcing, not for display */
for (i = 0; i < LENGTH(src); i++)
fprintf(fp, "%s\n", translateChar(STRING_ELT(src, i)));
fclose(fp);
}
#ifdef Win32
ti = CAR(args);
#endif
args = CDR(args);
ed = CAR(args);
if (!isString(ed)) errorcall(call, _("argument 'editor' type not valid"));
cmd = translateChar(STRING_ELT(ed, 0));
if (strlen(cmd) == 0) errorcall(call, _("argument 'editor' is not set"));
editcmd = R_alloc(strlen(cmd) + strlen(filename) + 6, sizeof(char));
#ifdef Win32
if (!strcmp(cmd,"internal")) {
if (!isString(ti))
error(_("'title' must be a string"));
if (LENGTH(STRING_ELT(ti, 0)) > 0) {
title = R_alloc(strlen(CHAR(STRING_ELT(ti, 0)))+1, sizeof(char));
strcpy(title, CHAR(STRING_ELT(ti, 0)));
} else {
title = R_alloc(strlen(filename)+1, sizeof(char));
strcpy(title, filename);
}
Rgui_Edit(filename, CE_NATIVE, title, 1);
}
else {
/* Quote path if necessary */
if(cmd[0] != '"' && Rf_strchr(cmd, ' '))
sprintf(editcmd, "\"%s\" \"%s\"", cmd, filename);
else
sprintf(editcmd, "%s \"%s\"", cmd, filename);
rc = runcmd(editcmd, CE_NATIVE, 1, 1, NULL, NULL, NULL);
if (rc == NOLAUNCH)
errorcall(call, _("unable to run editor '%s'"), cmd);
if (rc != 0)
warningcall(call, _("editor ran but returned error status"));
}
#else
if (ptr_R_EditFile)
rc = ptr_R_EditFile(filename);
else {
sprintf(editcmd, "'%s' '%s'", cmd, filename); // allow for spaces
rc = R_system(editcmd);
}
if (rc != 0)
errorcall(call, _("problem with running editor %s"), cmd);
#endif
if (asLogical(GetOption1(install("keep.source")))) {
PROTECT(Rfn = findFun(install("readLines"), R_BaseEnv));
PROTECT(src = lang2(Rfn, ScalarString(mkChar(R_ExpandFileName(filename)))));
PROTECT(src = eval(src, R_BaseEnv));
PROTECT(Rfn = findFun(install("srcfilecopy"), R_BaseEnv));
PROTECT(srcfile = lang3(Rfn, ScalarString(mkChar("<tmp>")), src));
srcfile = eval(srcfile, R_BaseEnv);
UNPROTECT(5);
} else
srcfile = R_NilValue;
PROTECT(srcfile);
/* <FIXME> setup a context to close the file, and parse and eval
line by line */
if((fp = R_fopen(R_ExpandFileName(filename), "r")) == NULL)
errorcall(call, _("unable to open file to read"));
x = PROTECT(R_ParseFile(fp, -1, &status, srcfile));
fclose(fp);
if (status != PARSE_OK)
errorcall(call,
_("%s occurred on line %d\n use a command like\n x <- edit()\n to recover"), R_ParseErrorMsg, R_ParseError);
R_ResetConsole();
{ /* can't just eval(x) here */
int j, n;
SEXP tmp = R_NilValue;
n = LENGTH(x);
for (j = 0 ; j < n ; j++)
tmp = eval(XVECTOR_ELT(x, j), R_GlobalEnv);
x = tmp;
}
if (TYPEOF(x) == CLOSXP && envir != R_NilValue)
SET_CLOENV(x, envir);
UNPROTECT(3);
vmaxset(vmaxsave);
return x;
}
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;
}