SEXP do_palette(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP val, ans;
unsigned int color[COLOR_TABLE_SIZE];
int i, n;
checkArity(op,args);
/* Record the current palette */
PROTECT(ans = allocVector(STRSXP, R_ColorTableSize));
for (i = 0; i < R_ColorTableSize; i++)
SET_STRING_ELT(ans, i, mkChar(col2name(R_ColorTable[i])));
val = CAR(args);
if (!isString(val)) errorcall(call, _("invalid argument type"));
if ((n=length(val)) == 1) {
if (StrMatch("default", CHAR(STRING_ELT(val, 0))))
setpalette(DefaultPalette);
else errorcall(call, _("unknown palette (need >= 2 colors)"));
}
else if (n > 1) {
if (n > COLOR_TABLE_SIZE)
errorcall(call, _("maximum number of colors exceeded"));
for (i = 0; i < n; i++)
color[i] = char2col(CHAR(STRING_ELT(val, i)));
for (i = 0; i < n; i++)
R_ColorTable[i] = color[i];
R_ColorTableSize = n;
}
UNPROTECT(1);
return ans;
}
SEXP attribute_hidden do_colon(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP s1, s2;
double n1, n2;
checkArity(op, args);
if (inheritsCharSXP(CAR(args), R_FactorCharSXP) && inheritsCharSXP(CADR(args), R_FactorCharSXP))
return(cross_colon(call, CAR(args), CADR(args)));
s1 = CAR(args);
s2 = CADR(args);
n1 = length(s1);
n2 = length(s2);
if (n1 == 0 || n2 == 0)
errorcall(call, _("argument of length 0"));
if (n1 > 1)
warningcall(call,
ngettext("numerical expression has %d element: only the first used",
"numerical expression has %d elements: only the first used",
(int) n1), (int) n1);
if (n2 > 1)
warningcall(call,
ngettext("numerical expression has %d element: only the first used",
"numerical expression has %d elements: only the first used",
(int) n2), (int) n2);
n1 = asReal(s1);
n2 = asReal(s2);
if (ISNAN(n1) || ISNAN(n2))
errorcall(call, _("NA/NaN argument"));
return seq_colon(n1, n2, call);
}
void attribute_hidden Rstd_savehistory(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP sfile;
char file[PATH_MAX];
const char *p;
sfile = CAR(args);
if (!isString(sfile) || LENGTH(sfile) < 1)
errorcall(call, _("invalid '%s' argument"), "file");
p = R_ExpandFileName(translateChar(STRING_ELT(sfile, 0)));
if(strlen(p) > PATH_MAX - 1)
errorcall(call, _("'file' argument is too long"));
strcpy(file, p);
#if defined(HAVE_LIBREADLINE) && defined(HAVE_READLINE_HISTORY_H)
if(R_Interactive && UsingReadline) {
int err;
err = write_history(file);
if(err) error(_("problem in saving the history file '%s'"), file);
/* Note that q() uses stifle_history, but here we do not want
* to truncate the active history when saving during a session */
#ifdef HAVE_HISTORY_TRUNCATE_FILE
R_setupHistory(); /* re-read the history size */
err = history_truncate_file(file, R_HistorySize);
if(err) warning(_("problem in truncating the history file"));
#endif
} else errorcall(call, _("no history available to save"));
#else
errorcall(call, _("no history available to save"));
#endif
}
SEXP attribute_hidden do_tracemem(SEXP call, SEXP op, SEXP args, SEXP rho)
{
#ifdef R_MEMORY_PROFILING
SEXP object;
char buffer[21];
checkArity(op, args);
check1arg(args, call, "x");
object = CAR(args);
if (TYPEOF(object) == CLOSXP ||
TYPEOF(object) == BUILTINSXP ||
TYPEOF(object) == SPECIALSXP)
errorcall(call, _("argument must not be a function"));
if(object == R_NilValue)
errorcall(call, _("cannot trace NULL"));
if(TYPEOF(object) == ENVSXP || TYPEOF(object) == PROMSXP)
errorcall(call,
_("'tracemem' is not useful for promise and environment objects"));
if(TYPEOF(object) == EXTPTRSXP || TYPEOF(object) == WEAKREFSXP)
errorcall(call,
_("'tracemem' is not useful for weak reference or external pointer objects"));
SET_RTRACE(object, 1);
snprintf(buffer, 21, "<%p>", (void *) object);
return mkString(buffer);
#else
errorcall(call, _("R was not compiled with support for memory profiling"));
return R_NilValue;
#endif
}
SEXP winMenuDel(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP smenu, sitem;
int res;
char errmsg[50];
args = CDR(args);
if (CharacterMode != RGui)
errorcall(call, _("menu functions can only be used in the GUI"));
smenu = CAR(args);
if(!isString(smenu) || length(smenu) != 1)
error(_("invalid '%s' argument"), "menuname");
sitem = CADR(args);
if (isNull(sitem)) { /* delete a menu */
res = windelmenu (translateChar(STRING_ELT(smenu, 0)), errmsg);
if (res > 0)
errorcall(call, _("menu does not exist"));
} else { /* delete an item */
if(!isString(sitem) || length(sitem) != 1)
error(_("invalid '%s' argument"), "itemname");
res = windelmenuitem (translateChar(STRING_ELT(sitem, 0)),
translateChar(STRING_ELT(smenu, 0)), errmsg);
if (res > 0) {
sprintf(msgbuf, _("unable to delete menu item (%s)"), errmsg);
errorcall(call, msgbuf);
}
}
return (R_NilValue);
}
SEXP attribute_hidden do_delayed(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP name = R_NilValue /* -Wall */, expr, eenv, aenv;
checkArity(op, args);
if (!isString(CAR(args)) || length(CAR(args)) == 0)
error(_("invalid first argument"));
else
name = installTrChar(STRING_ELT(CAR(args), 0));
args = CDR(args);
expr = CAR(args);
args = CDR(args);
eenv = CAR(args);
if (isNull(eenv)) {
error(_("use of NULL environment is defunct"));
eenv = R_BaseEnv;
} else
if (!isEnvironment(eenv))
errorcall(call, _("invalid '%s' argument"), "eval.env");
args = CDR(args);
aenv = CAR(args);
if (isNull(aenv)) {
error(_("use of NULL environment is defunct"));
aenv = R_BaseEnv;
} else
if (!isEnvironment(aenv))
errorcall(call, _("invalid '%s' argument"), "assign.env");
defineVar(name, mkPROMISE(expr, eenv), aenv);
return R_NilValue;
}
SEXP attribute_hidden R_sysframe(int n, RCNTXT *cptr)
{
if (n == 0)
return(R_GlobalEnv);
if (n > 0)
n = framedepth(cptr) - n;
else
n = -n;
if(n < 0)
errorcall(R_GlobalContext->call,
_("not that many frames on the stack"));
while (cptr->nextcontext != NULL) {
if (cptr->callflag & CTXT_FUNCTION ) {
if (n == 0) { /* we need to detach the enclosing env */
return cptr->cloenv;
}
else
n--;
}
cptr = cptr->nextcontext;
}
if(n == 0 && cptr->nextcontext == NULL)
return R_GlobalEnv;
else
errorcall(R_GlobalContext->call,
_("not that many frames on the stack"));
return R_NilValue; /* just for -Wall */
}
SEXP do_getGraphicsEvent(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP prompt, onMouseDown, onMouseMove, onMouseUp, onKeybd;
GEDevDesc *dd;
NewDevDesc *nd;
checkArity(op, args);
dd = GEcurrentDevice();
nd = dd->dev;
if (!nd->newDevStruct || !nd->getEvent)
errorcall(call, _("graphics device does not support graphics events"));
prompt = CAR(args);
if (!isString(prompt)) errorcall(call, _("invalid prompt"));
args = CDR(args);
onMouseDown = CAR(args);
if (TYPEOF(onMouseDown) == NILSXP) onMouseDown = NULL;
else if (!nd->canGenMouseDown)
errorcall(call, _("'onMouseDown' not supported"));
else if (TYPEOF(onMouseDown) != CLOSXP ||
TYPEOF(onMouseDown) != RCC_CLOSXP)
errorcall(call, _("invalid 'onMouseDown' callback"));
args = CDR(args);
onMouseMove = CAR(args);
if (TYPEOF(onMouseMove) == NILSXP) onMouseMove = NULL;
else if (!nd->canGenMouseMove)
errorcall(call, _("'onMouseMove' not supported"));
else if (TYPEOF(onMouseMove) != CLOSXP ||
TYPEOF(onMouseDown) != RCC_CLOSXP)
errorcall(call, _("invalid 'onMouseMove' callback"));
args = CDR(args);
onMouseUp = CAR(args);
if (TYPEOF(onMouseUp) == NILSXP) onMouseUp = NULL;
else if (!nd->canGenMouseUp)
errorcall(call, _("'onMouseUp' not supported"));
else if (TYPEOF(onMouseUp) != CLOSXP ||
TYPEOF(onMouseDown) != RCC_CLOSXP)
errorcall(call, _("invalid 'onMouseUp' callback"));
args = CDR(args);
onKeybd = CAR(args);
if (TYPEOF(onKeybd) == NILSXP) onKeybd = NULL;
else if (!nd->canGenKeybd)
errorcall(call, _("'onKeybd' not supported"));
else if (TYPEOF(onKeybd) != CLOSXP ||
TYPEOF(onMouseDown) != RCC_CLOSXP)
errorcall(call, _("invalid 'onKeybd' callback"));
/* NB: cleanup of event handlers must be done by driver in onExit handler */
return(nd->getEvent(env, CHAR(STRING_ELT(prompt,0))));
}
SEXP do_cum(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP s, t, ans;
int i;
checkArity(op, args);
if (DispatchGroup("Math", call, op, args, env, &ans))
return ans;
if (isComplex(CAR(args))) {
t = CAR(args);
s = allocVector(CPLXSXP, LENGTH(t));
setAttrib(s, R_NamesSymbol, getAttrib(t, R_NamesSymbol));
for (i = 0 ; i < length(t) ; i++) {
COMPLEX(s)[i].r = NA_REAL;
COMPLEX(s)[i].i = NA_REAL;
}
switch (PRIMVAL(op) ) {
case 1: /* cumsum */
return ccumsum(t, s);
break;
case 2: /* cumprod */
return ccumprod(t, s);
break;
case 3: /* cummax */
case 4: /* cummin */
errorcall(call, _("min/max not defined for complex numbers"));
break;
default:
errorcall(call, _("unknown cumxxx function"));
}
}
else { /* Non-Complex: here, (sh|c)ould differentiate real / int */
PROTECT(t = coerceVector(CAR(args), REALSXP));
s = allocVector(REALSXP, LENGTH(t));
setAttrib(s, R_NamesSymbol, getAttrib(t, R_NamesSymbol));
for(i = 0 ; i < length(t) ; i++)
REAL(s)[i] = NA_REAL;
UNPROTECT(1);
switch (PRIMVAL(op) ) {
case 1: /* cumsum */
return cumsum(t,s);
break;
case 2: /* cumprod */
return cumprod(t,s);
break;
case 3: /* cummax */
return cummax(t,s);
break;
case 4: /* cummin */
return cummin(t,s);
break;
default:
errorcall(call, _("unknown cumxxx function"));
}
}
return R_NilValue; /* for -Wall */
}
/* 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 do_system(SEXP call, SEXP op, SEXP args, SEXP rho)
{
FILE *fp;
char *x = "r", buf[INTERN_BUFSIZE];
int read=0, i, j;
SEXP tlist = R_NilValue, tchar, rval;
checkArity(op, args);
if (!isValidStringF(CAR(args)))
errorcall(call, _("non-empty character argument expected"));
if (isLogical(CADR(args)))
read = INTEGER(CADR(args))[0];
if (read) {
#ifdef HAVE_POPEN
PROTECT(tlist);
fp = R_popen(CHAR(STRING_ELT(CAR(args), 0)), x);
for (i = 0; fgets(buf, INTERN_BUFSIZE, fp); i++) {
read = strlen(buf);
if (read > 0 && buf[read-1] == '\n')
buf[read - 1] = '\0'; /* chop final CR */
tchar = mkChar(buf);
UNPROTECT(1);
PROTECT(tlist = CONS(tchar, tlist));
}
pclose(fp);
rval = allocVector(STRSXP, i);;
for (j = (i - 1); j >= 0; j--) {
SET_STRING_ELT(rval, j, CAR(tlist));
tlist = CDR(tlist);
}
UNPROTECT(1);
return (rval);
#else /* not HAVE_POPEN */
errorcall(call, _("intern=TRUE is not implemented on this platform"));
return R_NilValue;
#endif /* not HAVE_POPEN */
}
else {
#ifdef HAVE_AQUA
R_Busy(1);
#endif
tlist = allocVector(INTSXP, 1);
fflush(stdout);
INTEGER(tlist)[0] = R_system(CHAR(STRING_ELT(CAR(args), 0)));
#ifdef HAVE_AQUA
R_Busy(0);
#endif
R_Visible = 0;
return tlist;
}
}
SEXP attribute_hidden do_retracemem(SEXP call, SEXP op, SEXP args, SEXP rho)
{
#ifdef R_MEMORY_PROFILING
SEXP object, previous, ans, argList;
char buffer[21];
static SEXP do_retracemem_formals = NULL;
if (do_retracemem_formals == NULL)
do_retracemem_formals = allocFormalsList2(install("x"),
R_PreviousSymbol);
PROTECT(argList = matchArgs(do_retracemem_formals, args, call));
if(CAR(argList) == R_MissingArg) SETCAR(argList, R_NilValue);
if(CADR(argList) == R_MissingArg) SETCAR(CDR(argList), R_NilValue);
object = CAR(argList);
if (TYPEOF(object) == CLOSXP ||
TYPEOF(object) == BUILTINSXP ||
TYPEOF(object) == SPECIALSXP)
errorcall(call, _("argument must not be a function"));
previous = CADR(argList);
if(!isNull(previous) && !isString(previous))
errorcall(call, _("invalid '%s' argument"), "previous");
if (RTRACE(object)) {
snprintf(buffer, 21, "<%p>", (void *) object);
ans = mkString(buffer);
} else {
R_Visible = 0;
ans = R_NilValue;
}
if (previous != R_NilValue){
SET_RTRACE(object, 1);
if (R_current_trace_state()) {
/* FIXME: previous will have <0x....> whereas other values are
without the < > */
Rprintf("tracemem[%s -> %p]: ",
translateChar(STRING_ELT(previous, 0)), (void *) object);
memtrace_stack_dump();
}
}
UNPROTECT(1);
return ans;
#else
R_Visible = 0; /* for consistency with other case */
return R_NilValue;
#endif
}
/* winProgressBar(width, title, label, min, max, initial) */
SEXP winProgressBar(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP tmp, ptr;
int width, iv;
double d;
const char *title, *label;
winprogressbar *pbar;
Rboolean haveLabel;
args = CDR(args);
pbar = Calloc(1, winprogressbar);
width = asInteger(CAR(args)); args = CDR(args);
if(width == NA_INTEGER || width < 0) width = 200;
tmp = CAR(args); args = CDR(args);
if(!isString(tmp) || length(tmp) < 1 || STRING_ELT(tmp, 0) == NA_STRING)
errorcall(call, "invalid '%s' argument", "title");
title = translateChar(STRING_ELT(tmp, 0));
tmp = CAR(args); args = CDR(args);
if(!isString(tmp) || length(tmp) < 1 || STRING_ELT(tmp, 0) == NA_STRING)
errorcall(call, "invalid '%s' argument", "Label");
label = translateChar(STRING_ELT(tmp, 0));
haveLabel = strlen(label) > 0;
d = asReal(CAR(args)); args = CDR(args);
if (!R_FINITE(d)) errorcall(call, "invalid '%s' argument", "min");
pbar->min = d;
d = asReal(CAR(args)); args = CDR(args);
if (!R_FINITE(d)) errorcall(call, "invalid '%s' argument", "max");
pbar->max = d;
d = asReal(CAR(args)); args = CDR(args);
if (!R_FINITE(d)) errorcall(call, "invalid '%s' argument", "initial");
pbar->val = d;
pbar->width = width;
pbar->wprog = newwindow(title, rect(0, 0, width+40, haveLabel ? 100: 80),
Titlebar | Centered);
setbackground(pbar->wprog, dialog_bg());
if(haveLabel)
pbar->lab = newlabel(label, rect(10, 15, width+20, 25), AlignCenter);
pbar->pb = newprogressbar(rect(20, haveLabel ? 50 : 30, width, 20),
0, width, 1, 1);
iv = pbar->width * (pbar->val - pbar->min)/(pbar->max - pbar->min);
setprogressbar(pbar->pb, iv);
show(pbar->wprog);
ptr = R_MakeExternalPtr(pbar, install("winProgressBar"), R_NilValue);
R_RegisterCFinalizerEx(ptr, pbarFinalizer, TRUE);
return ptr;
}
SEXP attribute_hidden strmat2intmat(SEXP s, SEXP dnamelist, SEXP call)
{
/* XXX: assumes all args are protected */
int nr = nrows(s), i, j, v;
R_xlen_t idx, NR = nr;
SEXP dnames, snames, si, sicol, s_elt;
PROTECT(snames = allocVector(STRSXP, nr));
PROTECT(si = allocVector(INTSXP, xlength(s)));
dimgets(si, getAttrib(s, R_DimSymbol));
for (i = 0; i < length(dnamelist); i++) {
dnames = VECTOR_ELT(dnamelist, i);
for (j = 0; j < nr; j++)
SET_STRING_ELT(snames, j, STRING_ELT(s, j + (i * NR)));
PROTECT(sicol = match(dnames, snames, 0));
for (j = 0; j < nr; j++) {
v = INTEGER(sicol)[j];
idx = j + (i * NR);
s_elt = STRING_ELT(s, idx);
if (s_elt == NA_STRING) v = NA_INTEGER;
if (!CHAR(s_elt)[0]) v = 0; /* disallow "" match */
if (v == 0) errorcall(call, _("subscript out of bounds"));
INTEGER(si)[idx] = v;
}
UNPROTECT(1);
}
UNPROTECT(2);
return si;
}
SEXP do_aqua_custom_print(SEXP call, SEXP op, SEXP args, SEXP env)
{
const void *vm;
const char *ct;
int cpr;
SEXP rv, objType, obj;
if (!ptr_Raqua_CustomPrint) return R_NilValue;
checkArity(op, args);
vm = vmaxget();
objType = CAR(args); args = CDR(args);
obj = CAR(args);
if (!isString(objType) || LENGTH(objType)<1)
errorcall(call, "invalid arguments");
ct=CHAR(STRING_ELT(objType,0));
cpr=ptr_Raqua_CustomPrint(ct, obj);
/* FIXME: trying to store a pointer in an integer is wrong */
PROTECT(rv=allocVector(INTSXP, 1));
INTEGER(rv)[0]=cpr;
vmaxset(vm);
UNPROTECT(1);
return rv;
}
SEXP winDialog(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP message;
const char * type;
int res=YES;
args = CDR(args);
type = translateChar(STRING_ELT(CAR(args), 0));
message = CADR(args);
if(!isString(message) || length(message) != 1 ||
strlen(translateChar(STRING_ELT(message, 0))) > 255)
error(_("invalid '%s' argument"), "message");
if (strcmp(type, "ok") == 0) {
askok(translateChar(STRING_ELT(message, 0)));
res = 10;
} else if (strcmp(type, "okcancel") == 0) {
res = askokcancel(translateChar(STRING_ELT(message, 0)));
if(res == YES) res = 2;
} else if (strcmp(type, "yesno") == 0) {
res = askyesno(translateChar(STRING_ELT(message, 0)));
} else if (strcmp(type, "yesnocancel") == 0) {
res = askyesnocancel(translateChar(STRING_ELT(message, 0)));
} else
errorcall(call, _("unknown type"));
return ScalarInteger(res);
}
SEXP loadhistory(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP sfile;
args = CDR(args);
sfile = CAR(args);
if (!isString(sfile) || LENGTH(sfile) < 1)
errorcall(call, _("invalid '%s' argument"), "file");
if (CharacterMode == RGui)
wgl_loadhistoryW(filenameToWchar(STRING_ELT(sfile, 0), 0));
else if (R_Interactive && CharacterMode == RTerm)
gl_loadhistory(translateChar(STRING_ELT(sfile, 0)));
else
errorcall(call, _("'loadhistory' can only be used in Rgui and Rterm"));
return R_NilValue;
}
int attribute_hidden R_sysparent(int n, RCNTXT *cptr)
{
int j;
SEXP s;
if(n <= 0)
errorcall(R_ToplevelContext->call,
_("only positive values of 'n' are allowed"));
while (cptr->nextcontext != NULL && n > 1) {
if (cptr->callflag & CTXT_FUNCTION )
n--;
cptr = cptr->nextcontext;
}
/* make sure we're looking at a return context */
while (cptr->nextcontext != NULL && !(cptr->callflag & CTXT_FUNCTION) )
cptr = cptr->nextcontext;
s = cptr->sysparent;
if(s == R_GlobalEnv)
return 0;
j = 0;
while (cptr != NULL ) {
if (cptr->callflag & CTXT_FUNCTION) {
j++;
if( cptr->cloenv == s )
n=j;
}
cptr = cptr->nextcontext;
}
n = j - n + 1;
if (n < 0)
n = 0;
return n;
}
SEXP attribute_hidden do_debug(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans = R_NilValue;
checkArity(op,args);
#define find_char_fun \
if (isValidString(CAR(args))) { \
SEXP s; \
PROTECT(s = installTrChar(STRING_ELT(CAR(args), 0))); \
SETCAR(args, findFun(s, rho)); \
UNPROTECT(1); \
}
find_char_fun
if (TYPEOF(CAR(args)) != CLOSXP && TYPEOF(CAR(args)) != SPECIALSXP
&& TYPEOF(CAR(args)) != BUILTINSXP )
errorcall(call, _("argument must be a closure"));
switch(PRIMVAL(op)) {
case 0:
SET_RDEBUG(CAR(args), 1);
break;
case 1:
if( RDEBUG(CAR(args)) != 1 )
warningcall(call, "argument is not being debugged");
SET_RDEBUG(CAR(args), 0);
break;
case 2:
ans = ScalarLogical(RDEBUG(CAR(args)));
break;
case 3:
SET_RSTEP(CAR(args), 1);
break;
}
return ans;
}
/* 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;
}
static SEXP lunary(SEXP call, SEXP op, SEXP arg)
{
SEXP x, dim, dimnames, names;
R_xlen_t i, len;
len = XLENGTH(arg);
if (!isLogical(arg) && !isNumber(arg) && !isRaw(arg)) {
/* For back-compatibility */
if (!len) return allocVector(LGLSXP, 0);
errorcall(call, _("invalid argument type"));
}
PROTECT(names = getAttrib(arg, R_NamesSymbol));
PROTECT(dim = getAttrib(arg, R_DimSymbol));
PROTECT(dimnames = getAttrib(arg, R_DimNamesSymbol));
PROTECT(x = allocVector(isRaw(arg) ? RAWSXP : LGLSXP, len));
switch(TYPEOF(arg)) {
case LGLSXP:
for (i = 0; i < len; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
LOGICAL(x)[i] = (LOGICAL(arg)[i] == NA_LOGICAL) ?
NA_LOGICAL : LOGICAL(arg)[i] == 0;
}
break;
case INTSXP:
for (i = 0; i < len; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
LOGICAL(x)[i] = (INTEGER(arg)[i] == NA_INTEGER) ?
NA_LOGICAL : INTEGER(arg)[i] == 0;
}
break;
case REALSXP:
for (i = 0; i < len; i++){
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
LOGICAL(x)[i] = ISNAN(REAL(arg)[i]) ?
NA_LOGICAL : REAL(arg)[i] == 0;
}
break;
case CPLXSXP:
for (i = 0; i < len; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
LOGICAL(x)[i] = (ISNAN(COMPLEX(arg)[i].r) || ISNAN(COMPLEX(arg)[i].i))
? NA_LOGICAL : (COMPLEX(arg)[i].r == 0. && COMPLEX(arg)[i].i == 0.);
}
break;
case RAWSXP:
for (i = 0; i < len; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
RAW(x)[i] = 0xFF ^ RAW(arg)[i];
}
break;
default:
UNIMPLEMENTED_TYPE("lunary", arg);
}
if(names != R_NilValue) setAttrib(x, R_NamesSymbol, names);
if(dim != R_NilValue) setAttrib(x, R_DimSymbol, dim);
if(dimnames != R_NilValue) setAttrib(x, R_DimNamesSymbol, dimnames);
UNPROTECT(4);
return x;
}
SEXP attribute_hidden do_nchar(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP d, s, x, stype;
int nargs = length(args);
#ifdef R_version_3_4_or_so
checkArity(op, args);
#else
// will work also for code byte-compiled *before* 'keepNA' was introduced
if (nargs < 3 || nargs > 4)
errorcall(call,
ngettext("%d argument passed to '%s' which requires %d to %d",
"%d arguments passed to '%s' which requires %d to %d",
(unsigned long) nargs),
nargs, PRIMNAME(op), 3, 4);
#endif
if (isFactor(CAR(args)))
error(_("'%s' requires a character vector"), "nchar()");
PROTECT(x = coerceVector(CAR(args), STRSXP));
if (!isString(x))
error(_("'%s' requires a character vector"), "nchar()");
R_xlen_t len = XLENGTH(x);
stype = CADR(args);
if (!isString(stype) || LENGTH(stype) != 1)
error(_("invalid '%s' argument"), "type");
const char *type = CHAR(STRING_ELT(stype, 0)); /* always ASCII */
size_t ntype = strlen(type);
if (ntype == 0) error(_("invalid '%s' argument"), "type");
nchar_type type_;
if (strncmp(type, "bytes", ntype) == 0) type_ = Bytes;
else if (strncmp(type, "chars", ntype) == 0) type_ = Chars;
else if (strncmp(type, "width", ntype) == 0) type_ = Width;
else error(_("invalid '%s' argument"), "type");
int allowNA = asLogical(CADDR(args));
if (allowNA == NA_LOGICAL) allowNA = 0;
int keepNA;
if(nargs >= 4) {
keepNA = asLogical(CADDDR(args));
if (keepNA == NA_LOGICAL) // default
keepNA = (type_ == Width) ? FALSE : TRUE;
} else keepNA = FALSE; // default
PROTECT(s = allocVector(INTSXP, len));
int *s_ = INTEGER(s);
for (R_xlen_t i = 0; i < len; i++) {
SEXP sxi = STRING_ELT(x, i);
char msg_i[20]; sprintf(msg_i, "element %ld", (long)i+1);
s_[i] = R_nchar(sxi, type_, allowNA, keepNA, msg_i);
}
R_FreeStringBufferL(&cbuff);
if ((d = getAttrib(x, R_NamesSymbol)) != R_NilValue)
setAttrib(s, R_NamesSymbol, d);
if ((d = getAttrib(x, R_DimSymbol)) != R_NilValue)
setAttrib(s, R_DimSymbol, d);
if ((d = getAttrib(x, R_DimNamesSymbol)) != R_NilValue)
setAttrib(s, R_DimNamesSymbol, d);
UNPROTECT(2);
return s;
}
// onestep transition probability density for use in 'onestep.dens' plug-in
// transition from x to z as time goes from t1 to t2
void ou2_pdf (double *f,
double *x, double *z, double t1, double t2, const double *p,
const int *stateindex, const int *parindex, const int *covindex,
int ncovars, const double *covars)
{
if (t2-t1 != 1)
errorcall(R_NilValue,"ou2_pdf error: transitions must be consecutive");
f[0] = dens_ou2(x[X1],x[X2],z[X1],z[X2],ALPHA1,ALPHA2,ALPHA3,ALPHA4,SIGMA1,SIGMA2,SIGMA3,1);
}
static SEXP
seq(SEXP call, SEXP s1, SEXP s2)
{
int i, n, in1;
double n1, n2, r;
SEXP ans;
Rboolean useInt;
n1 = length(s1);
if( n1 > 1 )
warningcall(call,
_("numerical expression has %d elements: only the first used"), (int) n1);
n2 = length(s2);
if( n2 > 1 )
warningcall(call, _("numerical expression has %d elements: only the first used"), (int) n2);
n1 = asReal(s1);
n2 = asReal(s2);
if (ISNAN(n1) || ISNAN(n2))
errorcall(call, _("NA/NaN argument"));
in1 = (int)(n1);
useInt = (n1 == in1);
if (n1 <= INT_MIN || n2 <= INT_MIN || n1 > INT_MAX || n2 > INT_MAX)
useInt = FALSE;
r = fabs(n2 - n1);
if(r >= INT_MAX) errorcall(call, _("result would be too long a vector"));
n = r + 1 + FLT_EPSILON;
if (useInt) {
ans = allocVector(INTSXP, n);
if (n1 <= n2)
for (i = 0; i < n; i++) INTEGER(ans)[i] = in1 + i;
else
for (i = 0; i < n; i++) INTEGER(ans)[i] = in1 - i;
} else {
ans = allocVector(REALSXP, n);
if (n1 <= n2)
for (i = 0; i < n; i++) REAL(ans)[i] = n1 + i;
else
for (i = 0; i < n; i++) REAL(ans)[i] = n1 - i;
}
return ans;
}
SEXP do_seq(SEXP call, SEXP op, SEXP args, SEXP rho)
{
checkArity(op, args);
if (isFactor(CAR(args)) && isFactor(CADR(args))) {
if (length(CAR(args)) != length(CADR(args)))
errorcall(call, _("unequal factor lengths"));
return(cross(CAR(args), CADR(args)));
}
return seq(call, CAR(args), CADR(args));
}
/*
* R : A Computer Language for Statistical Data Analysis
* Copyright (C) 2000-2013 The R Core Team
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, a copy is available at
* https://www.R-project.org/Licenses/
*/
#ifdef HAVE_CONFIG_H
#include <config.h>
#endif
#include <Defn.h> /* for checkArity */
#include <Internal.h>
#undef _
#ifdef ENABLE_NLS
#include <libintl.h>
#define _(String) dgettext ("utils", String)
#else
#define _(String) (String)
#endif
#ifdef Win32
# include "Startup.h"
# include "getline/getline.h" /* for gl_load/savehistory */
# include "getline/wc_history.h" /* for wgl_load/savehistory */
SEXP savehistory(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP sfile;
args = CDR(args);
sfile = CAR(args);
if (!isString(sfile) || LENGTH(sfile) < 1)
errorcall(call, _("invalid '%s' argument"), "file");
if (CharacterMode == RGui) {
R_setupHistory(); /* re-read the history size */
wgl_savehistoryW(filenameToWchar(STRING_ELT(sfile, 0), 0),
R_HistorySize);
} else if (R_Interactive && CharacterMode == RTerm) {
R_setupHistory(); /* re-read the history size */
gl_savehistory(translateChar(STRING_ELT(sfile, 0)), R_HistorySize);
} else
errorcall(call, _("'savehistory' can only be used in Rgui and Rterm"));
return R_NilValue;
}
SEXP attribute_hidden do_seq_len(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans;
R_xlen_t len;
checkArity(op, args);
check1argSymbol(args, call, R_LengthOutSymbol);
if(length(CAR(args)) != 1)
warningcall(call, _("first element used of '%s' argument"),
"length.out");
#ifdef LONG_VECTOR_SUPPORT
double dlen = asReal(CAR(args));
if(!R_FINITE(dlen) || dlen < 0)
errorcall(call, _("argument must be coercible to non-negative integer"));
len = (R_xlen_t) dlen;
#else
len = asInteger(CAR(args));
if(len == NA_INTEGER || len < 0)
errorcall(call, _("argument must be coercible to non-negative integer"));
#endif
#ifdef LONG_VECTOR_SUPPORT
if (len > INT_MAX) {
ans = allocVector(REALSXP, len);
double *p = REAL(ans);
for(R_xlen_t i = 0; i < len; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
p[i] = (double) (i+1);
}
} else
#endif
{
ans = allocVector(INTSXP, len);
int *p = INTEGER(ans);
for(int i = 0; i < len; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
p[i] = i+1;
}
}
return ans;
}
SEXP attribute_hidden do_quit(SEXP call, SEXP op, SEXP args, SEXP rho)
{
const char *tmp;
SA_TYPE ask=SA_DEFAULT;
int status, runLast;
/* if there are any browser contexts active don't quit */
if(countContexts(CTXT_BROWSER, 1)) {
warning(_("cannot quit from browser"));
return R_NilValue;
}
if( !isString(CAR(args)) )
errorcall(call, _("one of \"yes\", \"no\", \"ask\" or \"default\" expected."));
tmp = CHAR(STRING_ELT(CAR(args), 0)); /* ASCII */
if( !strcmp(tmp, "ask") ) {
ask = SA_SAVEASK;
if(!R_Interactive)
warning(_("save=\"ask\" in non-interactive use: command-line default will be used"));
} else if( !strcmp(tmp, "no") )
ask = SA_NOSAVE;
else if( !strcmp(tmp, "yes") )
ask = SA_SAVE;
else if( !strcmp(tmp, "default") )
ask = SA_DEFAULT;
else
errorcall(call, _("unrecognized value of 'save'"));
status = asInteger(CADR(args));
if (status == NA_INTEGER) {
warning(_("invalid 'status', 0 assumed"));
runLast = 0;
}
runLast = asLogical(CADDR(args));
if (runLast == NA_LOGICAL) {
warning(_("invalid 'runLast', FALSE assumed"));
runLast = 0;
}
/* run the .Last function. If it gives an error, will drop back to main
loop. */
R_CleanUp(ask, status, runLast);
exit(0);
/*NOTREACHED*/
}
/* This is a primitive SPECIALSXP */
SEXP attribute_hidden do_onexit(SEXP call, SEXP op, SEXP args, SEXP rho)
{
RCNTXT *ctxt;
SEXP code, oldcode, tmp, argList;
int addit = 0;
static SEXP do_onexit_formals = NULL;
if (do_onexit_formals == NULL)
do_onexit_formals = allocFormalsList2(install("expr"), install("add"));
PROTECT(argList = matchArgs(do_onexit_formals, args, call));
if (CAR(argList) == R_MissingArg) code = R_NilValue;
else code = CAR(argList);
if (CADR(argList) != R_MissingArg) {
addit = asLogical(eval(CADR(args), rho));
if (addit == NA_INTEGER)
errorcall(call, _("invalid '%s' argument"), "add");
}
ctxt = R_GlobalContext;
/* Search for the context to which the on.exit action is to be
attached. Lexical scoping is implemented by searching for the
first closure call context with an environment matching the
expression evaluation environment. */
while (ctxt != R_ToplevelContext &&
!((ctxt->callflag & CTXT_FUNCTION) && ctxt->cloenv == rho) )
ctxt = ctxt->nextcontext;
if (ctxt->callflag & CTXT_FUNCTION)
{
if (addit && (oldcode = ctxt->conexit) != R_NilValue ) {
if ( CAR(oldcode) != R_BraceSymbol )
{
PROTECT(tmp = allocList(3));
SETCAR(tmp, R_BraceSymbol);
SETCADR(tmp, oldcode);
SETCADDR(tmp, code);
SET_TYPEOF(tmp, LANGSXP);
ctxt->conexit = tmp;
UNPROTECT(1);
}
else
{
PROTECT(tmp = allocList(1));
SETCAR(tmp, code);
ctxt->conexit = listAppend(duplicate(oldcode),tmp);
UNPROTECT(1);
}
}
else
ctxt->conexit = code;
}
UNPROTECT(1);
return R_NilValue;
}
SEXP do_shellexec(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP file;
checkArity(op, args);
file = CAR(args);
if (!isString(file) || length(file) != 1)
errorcall(call, _("invalid '%s' argument"), "file");
internal_shellexecW(filenameToWchar(STRING_ELT(file, 0), FALSE), FALSE);
return R_NilValue;
}
