SEXP initialize_rextmat(SEXP f, SEXP tf, SEXP n, SEXP m, SEXP rho) {
ext_matrix *e;
rext_matrix *re;
SEXP emat;
/* Allocate memory */
re = Calloc(1, rext_matrix);
re->n = asInteger(n);
re->m = asInteger(m);
/* Create external matrix envelope */
e = Calloc(1, ext_matrix);
e->type = "external matrix from R";
e->mulfn = rextmat_matmul;
e->tmulfn = rextmat_tmatmul;
e->ncol = rextmat_ncol;
e->nrow = rextmat_nrow;
e->matrix = re;
/* Make an external pointer envelope */
PROTECT(emat = R_MakeExternalPtr(e, install("external matrix"), R_NilValue));
/* Attach the fields */
PROTECT(re->fcall = R_MakeWeakRef(emat, lang2(f, R_NilValue), R_NilValue, 1));
PROTECT(re->tfcall = R_MakeWeakRef(emat, lang2(tf, R_NilValue), R_NilValue, 1));
PROTECT(re->rho = R_MakeWeakRef(emat, rho, R_NilValue, 1));
R_RegisterCFinalizer(emat, rextmat_finalizer);
UNPROTECT(4);
return emat;
}
/* it's really stupid becasue R has R_GetTraceback() but we have to
jump through eval() just because it's hidden so we can't access it ... */
static SEXP R_GetTraceback(int skip) {
SEXP d_int = install(".Internal"), tb = install("traceback"), sSkip = PROTECT(ScalarInteger(skip));
SEXP what = PROTECT(lang2(d_int, lang2(tb, sSkip)));
SEXP res = eval(what, R_GlobalEnv);
UNPROTECT(2);
return res;
}
SEXP COMM_PRINT(SEXP x)
{
SEXP mpiPackage;
SEXP Rmsg;
SEXP ret;
PROTECT(mpiPackage);
mpiPackage = eval( lang2( install("getNamespace"), ScalarString(mkChar("pbdMPI")) ), R_GlobalEnv );
ret = eval( lang2( install("comm.print"), x ), mpiPackage );
UNPROTECT(2);
return ret;
}
SEXP bcplm_metrop_rw(SEXP n, SEXP m, SEXP sd, SEXP lb, SEXP rb,
SEXP fun, SEXP rho){
mh_str *da;
SEXP ans, acc;
double sm; /* the mean used in each iteration */
int ns = INTEGER(n)[0];
if (!isFunction(fun)) error(("'fun' is not a function"));
if (!isEnvironment(rho)) error(("'rho'is not an environment"));
/* construct the mh_str object */
da = (mh_str *) R_alloc(1, sizeof(mh_str));
PROTECT(da->R_fcall = lang2(fun, R_NilValue));
da->R_env = rho;
/* run the random walk metropolis algorithm */
PROTECT(ans = allocVector(REALSXP, ns));
PROTECT(acc = allocVector(INTSXP, 1));
INTEGER(acc)[0] = 0;
GetRNGstate();
for (int i = 0; i < ns; i++){
sm = (i) ? REAL(ans)[i - 1] : REAL(m)[0];
INTEGER(acc)[0] += metrop_tnorm_rw(sm, REAL(sd)[0], REAL(lb)[0], REAL(rb)[0],
REAL(ans) + i, R_fun, da);
}
setAttrib(ans, install("accept"), acc);
UNPROTECT(3);
PutRNGstate();
return ans;
}
SEXP doKeybd(SEXP eventRho, NewDevDesc *dd, R_KeyName rkey, char *keyname)
{
SEXP handler, skey, temp, result;
dd->gettingEvent = FALSE; /* avoid recursive calls */
handler = findVar(install("onKeybd"), eventRho);
if (TYPEOF(handler) == PROMSXP)
handler = eval(handler, eventRho);
result = NULL;
if (handler != R_UnboundValue && handler != R_NilValue) {
PROTECT(skey = allocVector(STRSXP, 1));
if (keyname) SET_STRING_ELT(skey, 0, mkChar(keyname));
else SET_STRING_ELT(skey, 0, mkChar(keynames[rkey]));
PROTECT(temp = lang2(handler, skey));
PROTECT(result = eval(temp, eventRho));
R_FlushConsole();
UNPROTECT(3);
}
dd->gettingEvent = TRUE;
return result;
}
/**
* Wrapper for R function add1, defined in func.R.
*/
void R_add1(int alen, int a[])
{
// Allocate an R vector and copy the C array into it.
SEXP arg;
PROTECT(arg = allocVector(INTSXP, alen));
memcpy(INTEGER(arg), a, alen * sizeof(int));
// Setup a call to the R function
SEXP add1_call;
PROTECT(add1_call = lang2(install("add1"), arg));
// Execute the function
int errorOccurred;
SEXP ret = R_tryEval(add1_call, R_GlobalEnv, &errorOccurred);
if (!errorOccurred)
{
printf("R returned: ");
double *val = REAL(ret);
for (int i = 0; i < LENGTH(ret); i++)
printf("%0.1f, ", val[i]);
printf("\n");
}
else
{
printf("Error occurred calling R\n");
}
UNPROTECT(2);
}
void TestLanguage::testReadWrite() {
QString fname("language.dat");
{
Language lang1(::LANGUAGE_RUSSIAN);
QVERIFY(lang1.isValid());
QFile file(fname);
file.open(QIODevice::WriteOnly);
QDataStream out(&file);
out << lang1;
}
{
Language lang2(10000);
QVERIFY(!lang2.isValid());
QFile file(fname);
file.open(QIODevice::ReadOnly);
QDataStream in(&file);
in >> lang2;
QVERIFY(lang2.isValid());
QCOMPARE(lang2.code(), (int) ::LANGUAGE_RUSSIAN);
QCOMPARE(lang2.name(), QString("Russian"));
}
}
/* used in devWindows.c and cairoDevice */
void doKeybd(pDevDesc dd, R_KeyName rkey,
const char *keyname)
{
SEXP handler, skey, temp, result;
dd->gettingEvent = FALSE; /* avoid recursive calls */
PROTECT(handler = findVar(install(keybdHandler), dd->eventEnv));
if (TYPEOF(handler) == PROMSXP) {
handler = eval(handler, dd->eventEnv);
UNPROTECT(1); /* handler */
PROTECT(handler);
}
if (TYPEOF(handler) == CLOSXP) {
SEXP s_which = install("which");
defineVar(s_which, ScalarInteger(ndevNumber(dd)+1), dd->eventEnv);
PROTECT(skey = mkString(keyname ? keyname : keynames[rkey]));
PROTECT(temp = lang2(handler, skey));
PROTECT(result = eval(temp, dd->eventEnv));
defineVar(install("result"), result, dd->eventEnv);
UNPROTECT(3);
R_FlushConsole();
}
UNPROTECT(1); /* handler */
dd->gettingEvent = TRUE;
return;
}
static SEXP CreateHess(SEXP names)
{
SEXP p, q, data, dim, dimnames;
int i, n;
n = length(names);
PROTECT(dimnames = lang4(R_NilValue, 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);
}
SETCADDDR(dimnames, duplicate(CADDR(dimnames)));
PROTECT(dim = lang4(R_NilValue, R_NilValue, R_NilValue,R_NilValue));
SETCAR(dim, install("c"));
SETCADR(dim, lang2(install("length"), install(".value")));
SETCADDR(dim, ScalarInteger(length(names)));
SETCADDDR(dim, ScalarInteger(length(names)));
PROTECT(data = ScalarReal(0.));
PROTECT(p = lang4(install("array"), data, dim, dimnames));
p = lang3(install("<-"), install(".hessian"), p);
UNPROTECT(4);
return p;
}
double genoud_optim(SEXP fn_optim, SEXP rho, double *X, long parameters)
{
SEXP ans, R_fcall, x;
double fit;
long i;
PROTECT(x = allocVector(REALSXP, parameters));
for (i=0; i<parameters; i++)
{
REAL(x)[i] = X[i];
}
PROTECT(R_fcall = lang2(fn_optim, R_NilValue));
SETCADR(R_fcall, x);
ans = eval(R_fcall, rho);
fit = REAL(ans)[0];
for(i=0; i<parameters; i++)
{
X[i] = REAL(ans)[i+1];
}
UNPROTECT(2);
return(fit);
} // end of genoud_optim()
int inla_R_source(const char *filename)
{
if (!filename)
return INLA_OK;
inla_R_init();
#pragma omp critical
{
SEXP e, result;
int error;
if (R_debug)
fprintf(stderr, "R-interface: source file [%s]\n", filename);
PROTECT(e = lang2(install("source"), mkString(filename)));
PROTECT(result = R_tryEval(e, R_GlobalEnv, &error));
if (error){
fprintf(stderr, "\n *** ERROR ***: source R-file [%s] failed.\n", filename);
exit(1);
}
UNPROTECT(2);
}
return INLA_OK;
}
double perfunc(SEXP myldens, ENVELOPE *env, double x, SEXP rho)
/* to evaluate log density and increment count of evaluations */
/* myldens : R function to evaluate log density */
/* *env : envelope attributes */
/* x : point at which to evaluate log density */
/* rho : R environment in which the logdensity is evaluated */
{
double y;
SEXP R_fcall, arg;
/* evaluate logdensity function */
PROTECT(R_fcall = lang2(myldens, R_NilValue));
PROTECT(arg = NEW_NUMERIC(1));
NUMERIC_POINTER(arg)[0] = x;
SETCADR(R_fcall, arg);
y = REAL(eval(R_fcall, rho))[0];
UNPROTECT(2);
/* increment count of function evaluations */
(*(env->neval))++;
return y;
}
/**
* Invokes the command source("foo.R").
*/
void source(const char *name)
{
SEXP e;
PROTECT(e = lang2(install("source"), mkString(name)));
R_tryEval(e, R_GlobalEnv, NULL);
UNPROTECT(1);
}
SEXP COMM_STOP(char *msg)
{
SEXP mpiPackage;
SEXP Rmsg;
SEXP ret;
PROTECT(mpiPackage);
mpiPackage = eval( lang2( install("getNamespace"), ScalarString(mkChar("pbdMPI")) ), R_GlobalEnv );
PROTECT(Rmsg = allocVector(STRSXP, 1));
SET_STRING_ELT(Rmsg, 0, mkChar(msg));
ret = eval( lang2( install("comm.stop"), Rmsg ), mpiPackage );
UNPROTECT(2);
return ret;
}
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);
}
SEXP
makeTextNode(SEXP val)
{
SEXP e, ans;
PROTECT(e = lang2(Rf_install("xmlTextNode"), val));
ans = Rf_eval(e, R_GlobalEnv);
UNPROTECT(1);
return(ans);
}
/* zeroin2(f, ax, bx, f.ax, f.bx, tol, maxiter) */
SEXP zeroin2(SEXP call, SEXP op, SEXP args, SEXP rho)
{
double f_ax, f_bx;
double xmin, xmax, tol;
int iter;
SEXP v, res;
struct callinfo info;
args = CDR(args);
PrintDefaults();
/* the function to be minimized */
v = CAR(args);
if (!isFunction(v)) error(_("attempt to minimize non-function"));
args = CDR(args);
/* xmin */
xmin = asReal(CAR(args));
if (!R_FINITE(xmin)) error(_("invalid '%s' value"), "xmin");
args = CDR(args);
/* xmax */
xmax = asReal(CAR(args));
if (!R_FINITE(xmax)) error(_("invalid '%s' value"), "xmax");
if (xmin >= xmax) error(_("'xmin' not less than 'xmax'"));
args = CDR(args);
/* f(ax) = f(xmin) */
f_ax = asReal(CAR(args));
if (ISNA(f_ax)) error(_("NA value for '%s' is not allowed"), "f.lower");
args = CDR(args);
/* f(bx) = f(xmax) */
f_bx = asReal(CAR(args));
if (ISNA(f_bx)) error(_("NA value for '%s' is not allowed"), "f.upper");
args = CDR(args);
/* tol */
tol = asReal(CAR(args));
if (!R_FINITE(tol) || tol <= 0.0) error(_("invalid '%s' value"), "tol");
args = CDR(args);
/* maxiter */
iter = asInteger(CAR(args));
if (iter <= 0) error(_("'maxiter' must be positive"));
info.R_env = rho;
PROTECT(info.R_fcall = lang2(v, R_NilValue)); /* the info used in fcn2() */
PROTECT(res = allocVector(REALSXP, 3));
REAL(res)[0] =
R_zeroin2(xmin, xmax, f_ax, f_bx, (double (*)(double, void*)) fcn2,
(void *) &info, &tol, &iter);
REAL(res)[1] = (double)iter;
REAL(res)[2] = tol;
UNPROTECT(2);
return res;
}
/* zeroin(f, xmin, xmax, tol, maxiter) */
SEXP do_zeroin(SEXP call, SEXP op, SEXP args, SEXP rho)
{
double xmin, xmax, tol;
int iter;
SEXP v, res;
struct callinfo info;
checkArity(op, args);
PrintDefaults(rho);
/* the function to be minimized */
v = CAR(args);
if (!isFunction(v))
errorcall(call, _("attempt to minimize non-function"));
args = CDR(args);
/* xmin */
xmin = asReal(CAR(args));
if (!R_FINITE(xmin))
errorcall(call, _("invalid 'xmin' value"));
args = CDR(args);
/* xmax */
xmax = asReal(CAR(args));
if (!R_FINITE(xmax))
errorcall(call, _("invalid 'xmax' value"));
if (xmin >= xmax)
errorcall(call, _("'xmin' not less than 'xmax'"));
args = CDR(args);
/* tol */
tol = asReal(CAR(args));
if (!R_FINITE(tol) || tol <= 0.0)
errorcall(call, _("invalid 'tol' value"));
args = CDR(args);
/* maxiter */
iter = asInteger(CAR(args));
if (iter <= 0)
errorcall(call, _("'maxiter' must be positive"));
info.R_env = rho;
PROTECT(info.R_fcall = lang2(v, R_NilValue)); /* the info used in fcn2() */
SETCADR(info.R_fcall, allocVector(REALSXP, 1));
PROTECT(res = allocVector(REALSXP, 3));
REAL(res)[0] =
R_zeroin(xmin, xmax, (double (*)(double, void*)) fcn2,
(void *) &info, &tol, &iter);
REAL(res)[1] = (double)iter;
REAL(res)[2] = tol;
UNPROTECT(2);
return res;
}
SEXP rzmq_unserialize(SEXP data, SEXP rho) {
static SEXP R_unserialize_fun = findVar(install("unserialize"), R_GlobalEnv);
SEXP R_fcall, ans;
if(!isEnvironment(rho)) error("'rho' should be an environment");
PROTECT(R_fcall = lang2(R_unserialize_fun, data));
PROTECT(ans = eval(R_fcall, rho));
UNPROTECT(2);
return ans;
}
static void callback_set_seed(void *unused, uli_t seed) {
// call R's set.seed using equivalent of parse(text="set.seed(seed)")
SEXP call = PROTECT(lang2(install("set.seed"), ScalarInteger(seed)));
int evalError;
SEXP result = R_tryEval(call, R_GlobalEnv, &evalError);
UNPROTECT(1);
if (evalError) error("Failed to eval 'set.seed(%d)'", seed);
if (! quiet) Rprintf("\nSet seed to %u\n", seed);
return;
}
/*
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);
}
SEXP bfork_fork(SEXP fn) {
SEXP res;
pid_t pid;
if((pid = fork()) == 0) {
PROTECT(res = eval(lang1(fn), R_GlobalEnv));
PROTECT(res = eval(lang2(install("q"), mkString("no")), R_GlobalEnv));
UNPROTECT(2);
}
return ScalarInteger(pid);
}
static SEXP AddParens(SEXP expr)
{
SEXP e;
if (TYPEOF(expr) == LANGSXP) {
e = CDR(expr);
while(e != R_NilValue) {
SETCAR(e, AddParens(CAR(e)));
e = CDR(e);
}
}
if (isPlusForm(expr)) {
if (isPlusForm(CADDR(expr))) {
SETCADDR(expr, lang2(ParenSymbol, CADDR(expr)));
}
}
else if (isMinusForm(expr)) {
if (isPlusForm(CADDR(expr)) || isMinusForm(CADDR(expr))) {
SETCADDR(expr, lang2(ParenSymbol, CADDR(expr)));
}
}
else if (isTimesForm(expr)) {
if (isPlusForm(CADDR(expr)) || isMinusForm(CADDR(expr))
|| isTimesForm(CADDR(expr)) || isDivideForm(CADDR(expr))) {
SETCADDR(expr, lang2(ParenSymbol, CADDR(expr)));
}
if (isPlusForm(CADR(expr)) || isMinusForm(CADR(expr))) {
SETCADR(expr, lang2(ParenSymbol, CADR(expr)));
}
}
else if (isDivideForm(expr)) {
if (isPlusForm(CADDR(expr)) || isMinusForm(CADDR(expr))
|| isTimesForm(CADDR(expr)) || isDivideForm(CADDR(expr))) {
SETCADDR(expr, lang2(ParenSymbol, CADDR(expr)));
}
if (isPlusForm(CADR(expr)) || isMinusForm(CADR(expr))) {
SETCADR(expr, lang2(ParenSymbol, CADR(expr)));
}
}
else if (isPowerForm(expr)) {
if (isPowerForm(CADR(expr))) {
SETCADR(expr, lang2(ParenSymbol, CADR(expr)));
}
if (isPlusForm(CADDR(expr)) || isMinusForm(CADDR(expr))
|| isTimesForm(CADDR(expr)) || isDivideForm(CADDR(expr))) {
SETCADDR(expr, lang2(ParenSymbol, CADDR(expr)));
}
}
return expr;
}
SEXP as_output_vector(SEXP sVector, SEXP sNsep, SEXP sNamesFlag, SEXP sConn) {
R_xlen_t len = XLENGTH(sVector), i;
int key_flag = asInteger(sNamesFlag), mod = 0;
if (TYPEOF(sNsep) != STRSXP || LENGTH(sNsep) != 1)
Rf_error("nsep must be a single string");
char nsep = CHAR(STRING_ELT(sNsep, 0))[0];
char lend = '\n';
SEXP sRnames = Rf_getAttrib(sVector, R_NamesSymbol);
if (requires_as_character(sVector)) {
SEXP as_character = Rf_install("as.character");
SEXP asc = PROTECT(lang2(as_character, sVector));
sVector = eval(asc, R_GlobalEnv);
UNPROTECT(1);
PROTECT(sVector);
mod = 1;
/* since as.character() drops names, we want re-use original names, but that
means we have to check if it is actually meaningful. We do NOT perform
re-cycling since mismatches are unlikely intentional. */
if (key_flag && TYPEOF(sRnames) == STRSXP &&
(TYPEOF(sVector) != STRSXP || XLENGTH(sVector) != XLENGTH(sRnames))) {
Rf_warning("coersion of named object using as.character() yields different length (%ld) than original names (%ld), dropping names", (long) XLENGTH(sVector), (long) XLENGTH(sRnames));
sRnames = R_NilValue;
}
}
SEXPTYPE what = TYPEOF(sVector);
int isConn = inherits(sConn, "connection");
if (isNull(sRnames)) sRnames = 0;
unsigned long row_len = ((unsigned long) guess_size(what));
if (key_flag) row_len += 8;
SEXP buf = dybuf_alloc(isConn ? DEFAULT_CONN_BUFFER_SIZE : row_len, sConn);
for (i = 0; i < len; i++) {
if (key_flag) {
if (sRnames) {
const char *c = CHAR(STRING_ELT(sRnames, i));
dybuf_add(buf, c, strlen(c));
}
dybuf_add1(buf, nsep);
}
store(buf, sVector, i);
dybuf_add1(buf, lend);
}
SEXP res = dybuf_collect(buf);
UNPROTECT(1 + mod);
return res;
}
SEXP R_exec (const char* command, SEXP structure) {
SEXP e;
SEXP val = NILSXP;
int errorOccurred;
PROTECT(e = lang2(install((char*) command), structure));
val = R_tryEval(e, R_GlobalEnv, &errorOccurred);
UNPROTECT(1);
if (!errorOccurred) {
return(val);
}
else {
return(NILSXP);
}
}
SEXP bfork_wait(SEXP child_pid) {
int npid;
switch(TYPEOF(child_pid)) {
case INTSXP:
npid = *(INTEGER(child_pid));
break;
case REALSXP:
npid = *(REAL(child_pid));
break;
default:
PROTECT(eval(lang2(install("q"), mkString("no")), R_GlobalEnv));
UNPROTECT(1);
}
pid_t retpid = waitpid(npid, NULL, 0);
return ScalarInteger(retpid);
}
/* fmin(f, xmin, xmax tol) */
SEXP do_fmin(SEXP call, SEXP op, SEXP args, SEXP rho)
{
double xmin, xmax, tol;
SEXP v, res;
struct callinfo info;
checkArity(op, args);
PrintDefaults(rho);
/* the function to be minimized */
v = CAR(args);
if (!isFunction(v))
errorcall(call, _("attempt to minimize non-function"));
args = CDR(args);
/* xmin */
xmin = asReal(CAR(args));
if (!R_FINITE(xmin))
errorcall(call, _("invalid 'xmin' value"));
args = CDR(args);
/* xmax */
xmax = asReal(CAR(args));
if (!R_FINITE(xmax))
errorcall(call, _("invalid 'xmax' value"));
if (xmin >= xmax)
errorcall(call, _("'xmin' not less than 'xmax'"));
args = CDR(args);
/* tol */
tol = asReal(CAR(args));
if (!R_FINITE(tol) || tol <= 0.0)
errorcall(call, _("invalid 'tol' value"));
info.R_env = rho;
PROTECT(info.R_fcall = lang2(v, R_NilValue));
PROTECT(res = allocVector(REALSXP, 1));
SETCADR(info.R_fcall, allocVector(REALSXP, 1));
REAL(res)[0] = Brent_fmin(xmin, xmax,
(double (*)(double, void*)) fcn1, &info, tol);
UNPROTECT(2);
return res;
}
QuartzFunctions_t *getQuartzFunctions(void) {
if (qfn) return qfn;
{
QuartzFunctions_t *(*fn)(void);
fn = (QuartzFunctions_t *(*)(void)) R_FindSymbol("getQuartzAPI", "grDevices", NULL);
if (!fn) {
/* we need to load grDevices - not sure if this is the best way, though ... */
SEXP call = lang2(install("library"), install("grDevices"));
PROTECT(call);
eval(call, R_GlobalEnv);
UNPROTECT(1);
fn = (QuartzFunctions_t *(*)(void)) R_FindSymbol("getQuartzAPI", "grDevices", NULL);
if (!fn) error(_("unable to load Quartz"));
}
return fn();
}
}
/*
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 lapply2(SEXP list, SEXP fn, SEXP rho)
{
int i, n = length(list);
SEXP R_fcall, ans;
if(!isNewList(list)) error("`list' must be a list");
if(!isFunction(fn)) error("`fn' must be a function");
if(!isEnvironment(rho)) error("`rho' should be an environment");
PROTECT(R_fcall = lang2(fn, R_NilValue));
PROTECT(ans = allocVector(VECSXP, n));
for(i = 0; i < n; i++) {
SETCADR(R_fcall, VECTOR_ELT(list, i));
SET_VECTOR_ELT(ans, i, eval(R_fcall, rho));
}
setAttrib(ans, R_NamesSymbol, getAttrib(list, R_NamesSymbol));
UNPROTECT(2);
return(ans);
}