/* x = array of double values
* y = array of double values
* length = length of y
* output = array of double values (new y values)
*/
SEXP C_lowerConvexHull(SEXP x, SEXP y) {
SEXP output;
/* TODO: replace by R_xlen_t in R 3.0.0 */
R_xlen_t n, i, j, k=0;
int* nodes;
double m, c;
PROTECT(x=coerceVector(x, REALSXP));
PROTECT(y=coerceVector(y, REALSXP));
n=XLENGTH(x);
PROTECT(output=allocVector(REALSXP, n));
/* TODO: replace by R_xlen_t in R 3.0.0 */
/* allocate vector - error handling is done by R */
nodes=(int*) Calloc((size_t) n, int);
double* xx=REAL(x);
double* xy=REAL(y);
double* xo=REAL(output);
/* find lower convex hull */
for (i=0; i<n; ++i) {
while (k > 1 && !left(xx[nodes[k-2]], xy[nodes[k-2]],
xx[nodes[k-1]], xy[nodes[k-1]], xx[i], xy[i])) {
k-=1;
}
nodes[k]=i;
k+=1;
}
/* build linear function y=mx+c to calculate values between nodes */
for (i=0; i<k; ++i) {
m=(xy[nodes[i+1]]-xy[nodes[i]])/(xx[nodes[i+1]]-xx[nodes[i]]);
c=xy[nodes[i]]-m*xx[nodes[i]];
for (j=nodes[i]; j<nodes[i+1]; ++j) {
xo[j]=m*xx[j]+c;
}
}
xo[n-1]=xy[n-1];
Free(nodes);
UNPROTECT(3);
return(output);
}
void printVector(SEXP x, int indx, int quote)
{
/* print R vector x[]; if(indx) print indices; if(quote) quote strings */
R_xlen_t n;
if ((n = XLENGTH(x)) != 0) {
R_xlen_t n_pr = (n <= R_print.max +1) ? n : R_print.max;
/* '...max +1' ==> will omit at least 2 ==> plural in msg below */
switch (TYPEOF(x)) {
case LGLSXP:
printLogicalVector(LOGICAL(x), n_pr, indx);
break;
case INTSXP:
printIntegerVector(INTEGER(x), n_pr, indx);
break;
case REALSXP:
printRealVector(REAL(x), n_pr, indx);
break;
case STRSXP:
if (quote)
printStringVector(STRING_PTR(x), n_pr, '"', indx);
else
printStringVector(STRING_PTR(x), n_pr, 0, indx);
break;
case CPLXSXP:
printComplexVector(COMPLEX(x), n_pr, indx);
break;
case RAWSXP:
printRawVector(RAW(x), n_pr, indx);
break;
}
if(n_pr < n)
Rprintf(" [ reached getOption(\"max.print\") -- omitted %d entries ]\n",
n - n_pr);
}
else
#define PRINT_V_0 \
switch (TYPEOF(x)) { \
case LGLSXP: Rprintf("logical(0)\n"); break; \
case INTSXP: Rprintf("integer(0)\n"); break; \
case REALSXP: Rprintf("numeric(0)\n"); break; \
case CPLXSXP: Rprintf("complex(0)\n"); break; \
case STRSXP: Rprintf("character(0)\n"); break; \
case RAWSXP: Rprintf("raw(0)\n"); break; \
}
PRINT_V_0;
}
void copyMatrix(SEXP s, SEXP t, Rboolean byrow)
{
int nr = nrows(s), nc = ncols(s);
R_xlen_t nt = XLENGTH(t);
if (byrow) {
switch (TYPEOF(s)) {
case STRSXP:
FILL_MATRIX_BYROW_ITERATE(0, nr, nc, nt)
SET_STRING_ELT(s, didx, STRING_ELT(t, sidx));
break;
case LGLSXP:
FILL_MATRIX_BYROW_ITERATE(0, nr, nc, nt)
LOGICAL(s)[didx] = LOGICAL(t)[sidx];
break;
case INTSXP:
FILL_MATRIX_BYROW_ITERATE(0, nr, nc, nt)
INTEGER(s)[didx] = INTEGER(t)[sidx];
break;
case REALSXP:
FILL_MATRIX_BYROW_ITERATE(0, nr, nc, nt)
REAL(s)[didx] = REAL(t)[sidx];
break;
case CPLXSXP:
FILL_MATRIX_BYROW_ITERATE(0, nr, nc, nt)
COMPLEX(s)[didx] = COMPLEX(t)[sidx];
break;
case EXPRSXP:
case VECSXP:
FILL_MATRIX_BYROW_ITERATE(0, nr, nc, nt)
SET_VECTOR_ELT(s, didx, VECTOR_ELT(t, sidx));
break;
case RAWSXP:
FILL_MATRIX_BYROW_ITERATE(0, nr, nc, nt)
RAW(s)[didx] = RAW(t)[sidx];
break;
default:
UNIMPLEMENTED_TYPE("copyMatrix", s);
}
}
else
copyVector(s, t);
}
/* primitive */
SEXP attribute_hidden do_nzchar(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP x, ans;
R_xlen_t i, len;
checkArity(op, args);
check1argX(args, call);
if (isFactor(CAR(args)))
error(_("'%s' requires a character vector"), "nzchar()");
PROTECT(x = coerceVector(CAR(args), STRSXP));
if (!isString(x))
error(_("'%s' requires a character vector"), "nzchar()");
len = XLENGTH(x);
PROTECT(ans = allocVector(LGLSXP, len));
for (i = 0; i < len; i++)
LOGICAL(ans)[i] = LENGTH(STRING_ELT(x, i)) > 0;
UNPROTECT(2);
return ans;
}
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;
}
SEXP attribute_hidden do_abbrev(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP x, ans;
R_xlen_t i, len;
int minlen;
Rboolean warn = FALSE;
const char *s;
const void *vmax;
checkArity(op,args);
x = CAR(args);
if (!isString(x))
error(_("the first argument must be a character vector"));
len = XLENGTH(x);
PROTECT(ans = allocVector(STRSXP, len));
minlen = asInteger(CADR(args));
vmax = vmaxget();
for (i = 0 ; i < len ; i++) {
if (STRING_ELT(x, i) == NA_STRING)
SET_STRING_ELT(ans, i, NA_STRING);
else {
s = translateChar(STRING_ELT(x, i));
if(strlen(s) > minlen) {
warn = warn | !strIsASCII(s);
R_AllocStringBuffer(strlen(s), &cbuff);
SET_STRING_ELT(ans, i, stripchars(s, minlen));
} else SET_STRING_ELT(ans, i, mkChar(s));
}
vmaxset(vmax);
}
if (warn) warning(_("abbreviate used with non-ASCII chars"));
DUPLICATE_ATTRIB(ans, x);
/* This copied the class, if any */
R_FreeStringBufferL(&cbuff);
UNPROTECT(1);
return(ans);
}
SEXP attribute_hidden complex_unary(ARITHOP_TYPE code, SEXP s1, SEXP call)
{
R_xlen_t i, n;
SEXP ans;
switch(code) {
case PLUSOP:
return s1;
case MINUSOP:
ans = NO_REFERENCES(s1) ? s1 : duplicate(s1);
n = XLENGTH(s1);
for (i = 0; i < n; i++) {
Rcomplex x = COMPLEX(s1)[i];
COMPLEX(ans)[i].r = -x.r;
COMPLEX(ans)[i].i = -x.i;
}
return ans;
default:
errorcall(call, _("invalid complex unary operator"));
}
return R_NilValue; /* -Wall */
}
static void namewalk(SEXP s, NameWalkData *d)
{
SEXP name;
switch(TYPEOF(s)) {
case SYMSXP:
name = PRINTNAME(s);
/* skip blank symbols */
if(CHAR(name)[0] == '\0') goto ignore;
if(d->ItemCounts < d->MaxCount) {
if(d->StoreValues) {
if(d->UniqueNames) {
for(int j = 0 ; j < d->ItemCounts ; j++) {
if(STRING_ELT(d->ans, j) == name)
goto ignore;
}
}
SET_STRING_ELT(d->ans, d->ItemCounts, name);
}
d->ItemCounts++;
}
ignore:
break;
case LANGSXP:
if(!d->IncludeFunctions) s = CDR(s);
while(s != R_NilValue) {
namewalk(CAR(s), d);
s = CDR(s);
}
break;
case EXPRSXP:
for(R_xlen_t i = 0 ; i < XLENGTH(s) ; i++)
namewalk(XVECTOR_ELT(s, i), d);
break;
default:
/* it seems the intention is to do nothing here! */
break;
}
}
SEXP mc_send_child_stdin(SEXP sPid, SEXP what)
{
int pid = asInteger(sPid);
if (!is_master)
error(_("only the master process can send data to a child process"));
if (TYPEOF(what) != RAWSXP) error("what must be a raw vector");
child_info_t *ci = children;
while (ci) {
if (ci->pid == pid) break;
ci = ci -> next;
}
if (!ci) error(_("child %d does not exist"), pid);
R_xlen_t len = XLENGTH(what);
unsigned char *b = RAW(what);
unsigned int fd = ci -> sifd;
for (R_xlen_t i = 0; i < len;) {
ssize_t n = write(fd, b + i, len - i);
if (n < 1) error(_("write error"));
i += n;
}
return ScalarLogical(1);
}
/* primitive */
SEXP attribute_hidden do_nzchar(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP x, ans;
int nargs = length(args);
// checkArity(op, args); .Primitive() & may have 1 or 2 args now
if (nargs < 1 || nargs > 2)
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), 1, 2);
check1arg(args, call, "x");
if (isFactor(CAR(args)))
error(_("'%s' requires a character vector"), "nzchar()");
PROTECT(x = coerceVector(CAR(args), STRSXP));
if (!isString(x))
error(_("'%s' requires a character vector"), "nzchar()");
int keepNA = FALSE; // the default
if(nargs > 1) {
keepNA = asLogical(CADR(args));
if (keepNA == NA_LOGICAL) keepNA = FALSE;
}
R_xlen_t i, len = XLENGTH(x);
PROTECT(ans = allocVector(LGLSXP, len));
if (keepNA)
for (i = 0; i < len; i++) {
SEXP sxi = STRING_ELT(x, i);
LOGICAL(ans)[i] = (sxi == NA_STRING) ? NA_LOGICAL : LENGTH(sxi) > 0;
}
else
for (i = 0; i < len; i++)
LOGICAL(ans)[i] = LENGTH(STRING_ELT(x, i)) > 0;
UNPROTECT(2);
return ans;
}
SEXP attribute_hidden do_earg_matrix(SEXP call, SEXP op, SEXP arg_vals, SEXP arg_snr, SEXP arg_snc, SEXP arg_byrow,
SEXP arg_dimnames, SEXP arg_miss_nr, SEXP arg_miss_nc, SEXP rho)
{
SEXP vals, ans, snr, snc, dimnames;
int nr = 1, nc = 1, byrow, miss_nr, miss_nc;
R_xlen_t lendat;
vals = arg_vals;
switch(TYPEOF(vals)) {
case LGLSXP:
case INTSXP:
case REALSXP:
case CPLXSXP:
case STRSXP:
case RAWSXP:
case EXPRSXP:
case VECSXP:
break;
default:
error(_("'data' must be of a vector type, was '%s'"),
type2char(TYPEOF(vals)));
}
lendat = XLENGTH(vals);
snr = arg_snr;
snc = arg_snc;
byrow = asLogical(arg_byrow);
if (byrow == NA_INTEGER)
error(_("invalid '%s' argument"), "byrow");
dimnames = arg_dimnames;
miss_nr = asLogical(arg_miss_nr);
miss_nc = asLogical(arg_miss_nc);
if (!miss_nr) {
if (!isNumeric(snr)) error(_("non-numeric matrix extent"));
nr = asInteger(snr);
if (nr == NA_INTEGER)
error(_("invalid 'nrow' value (too large or NA)"));
if (nr < 0)
error(_("invalid 'nrow' value (< 0)"));
}
if (!miss_nc) {
if (!isNumeric(snc)) error(_("non-numeric matrix extent"));
nc = asInteger(snc);
if (nc == NA_INTEGER)
error(_("invalid 'ncol' value (too large or NA)"));
if (nc < 0)
error(_("invalid 'ncol' value (< 0)"));
}
if (miss_nr && miss_nc) {
if (lendat > INT_MAX) error("data is too long");
nr = (int) lendat;
} else if (miss_nr) {
if (lendat > (double) nc * INT_MAX) error("data is too long");
// avoid division by zero
if (nc == 0) {
if (lendat) error(_("nc = 0 for non-null data"));
else nr = 0;
} else
nr = (int) ceil((double) lendat / (double) nc);
} else if (miss_nc) {
if (lendat > (double) nr * INT_MAX) error("data is too long");
// avoid division by zero
if (nr == 0) {
if (lendat) error(_("nr = 0 for non-null data"));
else nc = 0;
} else
nc = (int) ceil((double) lendat / (double) nr);
}
if(lendat > 0) {
R_xlen_t nrc = (R_xlen_t) nr * nc;
if (lendat > 1 && nrc % lendat != 0) {
if (((lendat > nr) && (lendat / nr) * nr != lendat) ||
((lendat < nr) && (nr / lendat) * lendat != nr))
warning(_("data length [%d] is not a sub-multiple or multiple of the number of rows [%d]"), lendat, nr);
else if (((lendat > nc) && (lendat / nc) * nc != lendat) ||
((lendat < nc) && (nc / lendat) * lendat != nc))
warning(_("data length [%d] is not a sub-multiple or multiple of the number of columns [%d]"), lendat, nc);
}
else if ((lendat > 1) && (nrc == 0)){
warning(_("data length exceeds size of matrix"));
}
}
#ifndef LONG_VECTOR_SUPPORT
if ((double)nr * (double)nc > INT_MAX)
error(_("too many elements specified"));
#endif
PROTECT(ans = allocMatrix(TYPEOF(vals), nr, nc));
if(lendat) {
if (isVector(vals))
copyMatrix(ans, vals, byrow);
else
copyListMatrix(ans, vals, byrow);
} else if (isVector(vals)) { /* fill with NAs */
R_xlen_t N = (R_xlen_t) nr * nc, i;
switch(TYPEOF(vals)) {
case STRSXP:
for (i = 0; i < N; i++)
SET_STRING_ELT(ans, i, NA_STRING);
break;
case LGLSXP:
for (i = 0; i < N; i++)
LOGICAL(ans)[i] = NA_LOGICAL;
break;
case INTSXP:
for (i = 0; i < N; i++)
INTEGER(ans)[i] = NA_INTEGER;
break;
case REALSXP:
for (i = 0; i < N; i++)
REAL(ans)[i] = NA_REAL;
break;
case CPLXSXP:
{
Rcomplex na_cmplx;
na_cmplx.r = NA_REAL;
na_cmplx.i = 0;
for (i = 0; i < N; i++)
COMPLEX(ans)[i] = na_cmplx;
}
break;
case RAWSXP:
memset(RAW(ans), 0, N);
break;
default:
/* don't fill with anything */
;
}
}
if(!isNull(dimnames)&& length(dimnames) > 0)
ans = dimnamesgets(ans, dimnames);
UNPROTECT(1);
return ans;
}
/* This is a primitive SPECIALSXP with internal argument matching */
SEXP attribute_hidden do_rep(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans, x, times = R_NilValue /* -Wall */;
int each = 1, nprotect = 3;
R_xlen_t i, lx, len = NA_INTEGER, nt;
static SEXP do_rep_formals = NULL;
/* includes factors, POSIX[cl]t, Date */
if (DispatchOrEval(call, op, R_RepCharSXP, args, rho, &ans, 0, 0))
return(ans);
/* This has evaluated all the non-missing arguments into ans */
PROTECT(args = ans);
/* This is a primitive, and we have not dispatched to a method
so we manage the argument matching ourselves. We pretend this is
rep(x, times, length.out, each, ...)
*/
if (do_rep_formals == NULL) {
do_rep_formals = CONS(R_NilValue, list4(R_NilValue, R_NilValue, R_NilValue, R_NilValue));
R_PreserveObject(do_rep_formals);
SET_TAG(do_rep_formals, R_XSymbol);
SET_TAG(CDR(do_rep_formals), install("times"));
SET_TAG(CDDR(do_rep_formals), R_LengthOutSymbol);
SET_TAG(CDR(CDDR(do_rep_formals)), install("each"));
SET_TAG(CDDR(CDDR(do_rep_formals)), R_DotsSymbol);
}
PROTECT(args = matchArgs(do_rep_formals, args, call));
x = CAR(args);
/* supported in R 2.15.x */
if (TYPEOF(x) == LISTSXP)
errorcall(call, "replication of pairlists is defunct");
lx = xlength(x);
double slen = asReal(CADDR(args));
if (R_FINITE(slen)) {
if(slen < 0)
errorcall(call, _("invalid '%s' argument"), "length.out");
len = (R_xlen_t) slen;
} else {
len = asInteger(CADDR(args));
if(len != NA_INTEGER && len < 0)
errorcall(call, _("invalid '%s' argument"), "length.out");
}
if(length(CADDR(args)) != 1)
warningcall(call, _("first element used of '%s' argument"),
"length.out");
each = asInteger(CADDDR(args));
if(each != NA_INTEGER && each < 0)
errorcall(call, _("invalid '%s' argument"), "each");
if(length(CADDDR(args)) != 1)
warningcall(call, _("first element used of '%s' argument"), "each");
if(each == NA_INTEGER) each = 1;
if(lx == 0) {
if(len > 0 && x == R_NilValue)
warningcall(call, "'x' is NULL so the result will be NULL");
SEXP a;
PROTECT(a = duplicate(x));
if(len != NA_INTEGER && len > 0) a = xlengthgets(a, len);
UNPROTECT(3);
return a;
}
if (!isVector(x))
errorcall(call, "attempt to replicate an object of type '%s'",
type2char(TYPEOF(x)));
/* So now we know x is a vector of positive length. We need to
replicate it, and its names if it has them. */
/* First find the final length using 'times' and 'each' */
if(len != NA_INTEGER) { /* takes precedence over times */
nt = 1;
} else {
R_xlen_t sum = 0;
if(CADR(args) == R_MissingArg) PROTECT(times = ScalarInteger(1));
else PROTECT(times = coerceVector(CADR(args), INTSXP));
nprotect++;
nt = XLENGTH(times);
if(nt != 1 && nt != lx * each)
errorcall(call, _("invalid '%s' argument"), "times");
if(nt == 1) {
int it = INTEGER(times)[0];
if (it == NA_INTEGER || it < 0)
errorcall(call, _("invalid '%s' argument"), "times");
len = lx * it * each;
} else {
for(i = 0; i < nt; i++) {
int it = INTEGER(times)[i];
if (it == NA_INTEGER || it < 0)
errorcall(call, _("invalid '%s' argument"), "times");
sum += it;
}
len = sum;
}
}
if(len > 0 && each == 0)
errorcall(call, _("invalid '%s' argument"), "each");
SEXP xn = getNamesAttrib(x);
PROTECT(ans = rep4(x, times, len, each, nt));
if (length(xn) > 0)
setAttrib(ans, R_NamesSymbol, rep4(xn, times, len, each, nt));
#ifdef _S4_rep_keepClass
if(IS_S4_OBJECT(x)) { /* e.g. contains = "list" */
setAttrib(ans, R_ClassSymbol, getClassAttrib(x));
SET_S4_OBJECT(ans);
}
#endif
UNPROTECT(nprotect);
return ans;
}
SEXP attribute_hidden do_makenames(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP arg, ans;
R_xlen_t i, n;
int l, allow_;
char *p, *tmp = NULL, *cbuf;
const char *This;
Rboolean need_prefix;
const void *vmax;
checkArity(op ,args);
arg = CAR(args);
if (!isString(arg))
error(_("non-character names"));
n = XLENGTH(arg);
allow_ = asLogical(CADR(args));
if (allow_ == NA_LOGICAL)
error(_("invalid '%s' value"), "allow_");
PROTECT(ans = allocVector(STRSXP, n));
vmax = vmaxget();
for (i = 0 ; i < n ; i++) {
This = translateChar(STRING_ELT(arg, i));
l = (int) strlen(This);
/* need to prefix names not beginning with alpha or ., as
well as . followed by a number */
need_prefix = FALSE;
if (mbcslocale && This[0]) {
int nc = l, used;
wchar_t wc;
mbstate_t mb_st;
const char *pp = This;
mbs_init(&mb_st);
used = (int) Mbrtowc(&wc, pp, MB_CUR_MAX, &mb_st);
pp += used; nc -= used;
if (wc == L'.') {
if (nc > 0) {
Mbrtowc(&wc, pp, MB_CUR_MAX, &mb_st);
if (iswdigit(wc)) need_prefix = TRUE;
}
} else if (!iswalpha(wc)) need_prefix = TRUE;
} else {
if (This[0] == '.') {
if (l >= 1 && isdigit(0xff & (int) This[1])) need_prefix = TRUE;
} else if (!isalpha(0xff & (int) This[0])) need_prefix = TRUE;
}
if (need_prefix) {
tmp = Calloc(l+2, char);
strcpy(tmp, "X");
strcat(tmp, translateChar(STRING_ELT(arg, i)));
} else {
tmp = Calloc(l+1, char);
strcpy(tmp, translateChar(STRING_ELT(arg, i)));
}
if (mbcslocale) {
/* This cannot lengthen the string, so safe to overwrite it.
Would also be possible a char at a time.
*/
int nc = (int) mbstowcs(NULL, tmp, 0);
wchar_t *wstr = Calloc(nc+1, wchar_t), *wc;
if (nc >= 0) {
mbstowcs(wstr, tmp, nc+1);
for (wc = wstr; *wc; wc++) {
if (*wc == L'.' || (allow_ && *wc == L'_'))
/* leave alone */;
else if (!iswalnum((int)*wc)) *wc = L'.';
/* If it changes into dot here,
* length will become short on mbcs.
* The name which became short will contain garbage.
* cf.
* > make.names(c("\u30fb"))
* [1] "X.\0"
*/
}
wcstombs(tmp, wstr, strlen(tmp)+1);
Free(wstr);
} else error(_("invalid multibyte string %d"), i+1);
} else {
for (p = tmp; *p; p++) {
static SEXP ExtractSubset(SEXP x, SEXP result, SEXP indx, SEXP call)
{
R_xlen_t i, ii, n, nx;
int mode, mi;
SEXP tmp, tmp2;
mode = TYPEOF(x);
mi = TYPEOF(indx);
n = XLENGTH(indx);
nx = xlength(x);
tmp = result;
if (x == R_NilValue)
return x;
for (i = 0; i < n; i++) {
switch(mi) {
case REALSXP:
if(!R_FINITE(REAL(indx)[i])) ii = NA_INTEGER;
else ii = (R_xlen_t) (REAL(indx)[i] - 1);
break;
default:
ii = INTEGER(indx)[i];
if (ii != NA_INTEGER) ii--;
}
switch (mode) {
/* NA_INTEGER < 0, so some of this is redundant */
case LGLSXP:
if (0 <= ii && ii < nx && ii != NA_INTEGER)
LOGICAL(result)[i] = LOGICAL(x)[ii];
else
LOGICAL(result)[i] = NA_INTEGER;
break;
case INTSXP:
if (0 <= ii && ii < nx && ii != NA_INTEGER)
INTEGER(result)[i] = INTEGER(x)[ii];
else
INTEGER(result)[i] = NA_INTEGER;
break;
case REALSXP:
if (0 <= ii && ii < nx && ii != NA_INTEGER)
REAL(result)[i] = REAL(x)[ii];
else
REAL(result)[i] = NA_REAL;
break;
case CPLXSXP:
if (0 <= ii && ii < nx && ii != NA_INTEGER) {
COMPLEX(result)[i] = COMPLEX(x)[ii];
} else {
COMPLEX(result)[i].r = NA_REAL;
COMPLEX(result)[i].i = NA_REAL;
}
break;
case STRSXP:
if (0 <= ii && ii < nx && ii != NA_INTEGER)
SET_STRING_ELT(result, i, STRING_ELT(x, ii));
else
SET_STRING_ELT(result, i, NA_STRING);
break;
case VECSXP:
case EXPRSXP:
if (0 <= ii && ii < nx && ii != NA_INTEGER)
SET_VECTOR_ELT(result, i, VECTOR_ELT_FIX_NAMED(x, ii));
else
SET_VECTOR_ELT(result, i, R_NilValue);
break;
case LISTSXP:
/* cannot happen: pairlists are coerced to lists */
case LANGSXP:
#ifdef LONG_VECTOR_SUPPORT
if (ii > R_SHORT_LEN_MAX)
error("invalid subscript for pairlist");
#endif
if (0 <= ii && ii < nx && ii != NA_INTEGER) {
tmp2 = nthcdr(x, (int) ii);
SETCAR(tmp, CAR(tmp2));
SET_TAG(tmp, TAG(tmp2));
}
else
SETCAR(tmp, R_NilValue);
tmp = CDR(tmp);
break;
case RAWSXP:
if (0 <= ii && ii < nx && ii != NA_INTEGER)
RAW(result)[i] = RAW(x)[ii];
else
RAW(result)[i] = (Rbyte) 0;
break;
default:
errorcall(call, R_MSG_ob_nonsub, type2char(mode));
}
}
return result;
}
SEXP attribute_hidden do_subset_dflt(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans, ax, px, x, subs;
int drop, i, nsubs, type;
/* By default we drop extents of length 1 */
/* Handle cases of extracting a single element from a simple vector
or matrix directly to improve speed for these simple cases. */
SEXP cdrArgs = CDR(args);
SEXP cddrArgs = CDR(cdrArgs);
if (cdrArgs != R_NilValue && cddrArgs == R_NilValue &&
TAG(cdrArgs) == R_NilValue) {
/* one index, not named */
SEXP x = CAR(args);
if (ATTRIB(x) == R_NilValue) {
SEXP s = CAR(cdrArgs);
R_xlen_t i = scalarIndex(s);
switch (TYPEOF(x)) {
case REALSXP:
if (i >= 1 && i <= XLENGTH(x))
return ScalarReal( REAL(x)[i-1] );
break;
case INTSXP:
if (i >= 1 && i <= XLENGTH(x))
return ScalarInteger( INTEGER(x)[i-1] );
break;
case LGLSXP:
if (i >= 1 && i <= XLENGTH(x))
return ScalarLogical( LOGICAL(x)[i-1] );
break;
// do the more rare cases as well, since we've already prepared everything:
case CPLXSXP:
if (i >= 1 && i <= XLENGTH(x))
return ScalarComplex( COMPLEX(x)[i-1] );
break;
case RAWSXP:
if (i >= 1 && i <= XLENGTH(x))
return ScalarRaw( RAW(x)[i-1] );
break;
default: break;
}
}
}
else if (cddrArgs != R_NilValue && CDR(cddrArgs) == R_NilValue &&
TAG(cdrArgs) == R_NilValue && TAG(cddrArgs) == R_NilValue) {
/* two indices, not named */
SEXP x = CAR(args);
SEXP attr = ATTRIB(x);
if (TAG(attr) == R_DimSymbol && CDR(attr) == R_NilValue) {
/* only attribute of x is 'dim' */
SEXP dim = CAR(attr);
if (TYPEOF(dim) == INTSXP && LENGTH(dim) == 2) {
/* x is a matrix */
SEXP si = CAR(cdrArgs);
SEXP sj = CAR(cddrArgs);
R_xlen_t i = scalarIndex(si);
R_xlen_t j = scalarIndex(sj);
int nrow = INTEGER(dim)[0];
int ncol = INTEGER(dim)[1];
if (i > 0 && j > 0 && i <= nrow && j <= ncol) {
/* indices are legal scalars */
R_xlen_t k = i - 1 + nrow * (j - 1);
switch (TYPEOF(x)) {
case REALSXP:
if (k < LENGTH(x))
return ScalarReal( REAL(x)[k] );
break;
case INTSXP:
if (k < LENGTH(x))
return ScalarInteger( INTEGER(x)[k] );
break;
case LGLSXP:
if (k < LENGTH(x))
return ScalarLogical( LOGICAL(x)[k] );
break;
case CPLXSXP:
if (k < LENGTH(x))
return ScalarComplex( COMPLEX(x)[k] );
break;
case RAWSXP:
if (k < LENGTH(x))
return ScalarRaw( RAW(x)[k] );
break;
default: break;
}
}
}
}
}
PROTECT(args);
drop = 1;
ExtractDropArg(args, &drop);
x = CAR(args);
/* This was intended for compatibility with S, */
/* but in fact S does not do this. */
/* FIXME: replace the test by isNull ... ? */
if (x == R_NilValue) {
UNPROTECT(1);
return x;
}
subs = CDR(args);
nsubs = length(subs); /* Will be short */
type = TYPEOF(x);
/* Here coerce pair-based objects into generic vectors. */
/* All subsetting takes place on the generic vector form. */
ax = x;
if (isVector(x))
PROTECT(ax);
else if (isPairList(x)) {
SEXP dim = getAttrib(x, R_DimSymbol);
int ndim = length(dim);
if (ndim > 1) {
PROTECT(ax = allocArray(VECSXP, dim));
setAttrib(ax, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol));
setAttrib(ax, R_NamesSymbol, getAttrib(x, R_DimNamesSymbol));
}
else {
PROTECT(ax = allocVector(VECSXP, length(x)));
setAttrib(ax, R_NamesSymbol, getAttrib(x, R_NamesSymbol));
}
for(px = x, i = 0 ; px != R_NilValue ; px = CDR(px))
SET_VECTOR_ELT(ax, i++, CAR(px));
}
else errorcall(call, R_MSG_ob_nonsub, type2char(TYPEOF(x)));
/* This is the actual subsetting code. */
/* The separation of arrays and matrices is purely an optimization. */
if(nsubs < 2) {
SEXP dim = getAttrib(x, R_DimSymbol);
int ndim = length(dim);
PROTECT(ans = VectorSubset(ax, (nsubs == 1 ? CAR(subs) : R_MissingArg),
call));
/* one-dimensional arrays went through here, and they should
have their dimensions dropped only if the result has
length one and drop == TRUE
*/
if(ndim == 1) {
SEXP attr, attrib, nattrib;
int len = length(ans);
if(!drop || len > 1) {
// must grab these before the dim is set.
SEXP nm = PROTECT(getAttrib(ans, R_NamesSymbol));
PROTECT(attr = allocVector(INTSXP, 1));
INTEGER(attr)[0] = length(ans);
setAttrib(ans, R_DimSymbol, attr);
if((attrib = getAttrib(x, R_DimNamesSymbol)) != R_NilValue) {
/* reinstate dimnames, include names of dimnames */
PROTECT(nattrib = duplicate(attrib));
SET_VECTOR_ELT(nattrib, 0, nm);
setAttrib(ans, R_DimNamesSymbol, nattrib);
setAttrib(ans, R_NamesSymbol, R_NilValue);
UNPROTECT(1);
}
UNPROTECT(2);
}
}
} else {
if (nsubs != length(getAttrib(x, R_DimSymbol)))
errorcall(call, _("incorrect number of dimensions"));
if (nsubs == 2)
ans = MatrixSubset(ax, subs, call, drop);
else
ans = ArraySubset(ax, subs, call, drop);
PROTECT(ans);
}
/* Note: we do not coerce back to pair-based lists. */
/* They are "defunct" in this version of R. */
if (type == LANGSXP) {
ax = ans;
PROTECT(ans = allocList(LENGTH(ax)));
if ( LENGTH(ax) > 0 )
SET_TYPEOF(ans, LANGSXP);
for(px = ans, i = 0 ; px != R_NilValue ; px = CDR(px))
SETCAR(px, VECTOR_ELT(ax, i++));
setAttrib(ans, R_DimSymbol, getAttrib(ax, R_DimSymbol));
setAttrib(ans, R_DimNamesSymbol, getAttrib(ax, R_DimNamesSymbol));
setAttrib(ans, R_NamesSymbol, getAttrib(ax, R_NamesSymbol));
SET_NAMED(ans, NAMED(ax)); /* PR#7924 */
}
else {
PROTECT(ans);
}
if (ATTRIB(ans) != R_NilValue) { /* remove probably erroneous attr's */
setAttrib(ans, R_TspSymbol, R_NilValue);
#ifdef _S4_subsettable
if(!IS_S4_OBJECT(x))
#endif
setAttrib(ans, R_ClassSymbol, R_NilValue);
}
UNPROTECT(4);
return ans;
}
RVector::RVector(SEXP vector)
: size_(XLENGTH(vector)), capacity_(XLENGTH(vector)), vector(vector) {
assert(TYPEOF(vector) == VECSXP);
R_PreserveObject(vector);
}
/* This is for all cases with a single index, including 1D arrays and
matrix indexing of arrays */
static SEXP VectorSubset(SEXP x, SEXP s, SEXP call)
{
R_xlen_t n;
int mode;
R_xlen_t stretch = 1;
SEXP indx, result, attrib, nattrib;
if (s == R_MissingArg) return duplicate(x);
PROTECT(s);
attrib = getAttrib(x, R_DimSymbol);
/* Check to see if we have special matrix subscripting. */
/* If we do, make a real subscript vector and protect it. */
if (isMatrix(s) && isArray(x) && ncols(s) == length(attrib)) {
if (isString(s)) {
s = strmat2intmat(s, GetArrayDimnames(x), call);
UNPROTECT(1);
PROTECT(s);
}
if (isInteger(s) || isReal(s)) {
s = mat2indsub(attrib, s, call);
UNPROTECT(1);
PROTECT(s);
}
}
/* Convert to a vector of integer subscripts */
/* in the range 1:length(x). */
PROTECT(indx = makeSubscript(x, s, &stretch, call));
n = XLENGTH(indx);
/* Allocate the result. */
mode = TYPEOF(x);
/* No protection needed as ExtractSubset does not allocate */
result = allocVector(mode, n);
if (mode == VECSXP || mode == EXPRSXP)
/* we do not duplicate the values when extracting the subset,
so to be conservative mark the result as NAMED = 2 */
SET_NAMED(result, 2);
PROTECT(result = ExtractSubset(x, result, indx, call));
if (result != R_NilValue) {
if (
((attrib = getAttrib(x, R_NamesSymbol)) != R_NilValue) ||
( /* here we might have an array. Use row names if 1D */
isArray(x) && LENGTH(getAttrib(x, R_DimNamesSymbol)) == 1 &&
(attrib = getAttrib(x, R_DimNamesSymbol)) != R_NilValue &&
(attrib = GetRowNames(attrib)) != R_NilValue
)
) {
PROTECT(attrib);
nattrib = allocVector(TYPEOF(attrib), n);
PROTECT(nattrib); /* seems unneeded */
nattrib = ExtractSubset(attrib, nattrib, indx, call);
setAttrib(result, R_NamesSymbol, nattrib);
UNPROTECT(2); /* attrib, nattrib */
}
if ((attrib = getAttrib(x, R_SrcrefSymbol)) != R_NilValue &&
TYPEOF(attrib) == VECSXP) {
nattrib = allocVector(VECSXP, n);
PROTECT(nattrib); /* seems unneeded */
nattrib = ExtractSubset(attrib, nattrib, indx, call);
setAttrib(result, R_SrcrefSymbol, nattrib);
UNPROTECT(1);
}
/* FIXME: this is wrong, because the slots are gone, so result is an invalid object of the S4 class! JMC 3/3/09 */
#ifdef _S4_subsettable
if(IS_S4_OBJECT(x)) { /* e.g. contains = "list" */
setAttrib(result, R_ClassSymbol, getAttrib(x, R_ClassSymbol));
SET_S4_OBJECT(result);
}
#endif
}
UNPROTECT(3);
return result;
}
void CodeVerifier::verifyFunctionLayout(SEXP sexp, InterpreterInstance* ctx) {
if (TYPEOF(sexp) != EXTERNALSXP)
Rf_error("RIR Verifier: Invalid SEXPTYPE");
Function* f = Function::unpack(sexp);
// get the code objects
std::vector<Code*> objs;
objs.push_back(f->body());
for (size_t i = 0; i < f->numArgs; ++i)
if (f->defaultArg(i))
objs.push_back(f->defaultArg(i));
if (f->size > XLENGTH(sexp))
Rf_error("RIR Verifier: Reported size must be smaller than the size of "
"the vector");
// check that the call instruction has proper arguments and number of
// instructions is valid
while (!objs.empty()) {
auto c = objs.back();
objs.pop_back();
if (c->info.magic != CODE_MAGIC)
Rf_error("RIR Verifier: Invalid code magic number");
if (c->src == 0)
Rf_error("RIR Verifier: Code must have AST");
unsigned oldo = c->stackLength;
calculateAndVerifyStack(c);
if (oldo != c->stackLength)
Rf_error("RIR Verifier: Invalid stack layout reported");
if (((uintptr_t)(c + 1) + pad4(c->codeSize) +
c->srcLength * sizeof(Code::SrclistEntry)) == 0)
Rf_error("RIR Verifier: Invalid code length reported");
Opcode* cptr = c->code();
Opcode* start = cptr;
Opcode* end = start + c->codeSize;
while (true) {
if (cptr > end)
Rf_error("RIR Verifier: Bytecode overflow");
BC cur = BC::decode(cptr, c);
switch (hasSources(cur.bc)) {
case Sources::Required:
if (c->getSrcIdxAt(cptr, true) == 0)
Rf_error("RIR Verifier: Source required but not found");
break;
case Sources::NotNeeded:
if (c->getSrcIdxAt(cptr, true) != 0)
Rf_error("RIR Verifier: Sources not needed but stored");
break;
case Sources::May: {
}
}
if (*cptr == Opcode::br_ || *cptr == Opcode::brobj_ ||
*cptr == Opcode::brtrue_ || *cptr == Opcode::brfalse_) {
int off = *reinterpret_cast<int*>(cptr + 1);
if (cptr + cur.size() + off < start ||
cptr + cur.size() + off > end)
Rf_error("RIR Verifier: Branch outside closure");
}
if (*cptr == Opcode::ldvar_) {
unsigned* argsIndex = reinterpret_cast<Immediate*>(cptr + 1);
if (*argsIndex >= cp_pool_length(ctx))
Rf_error("RIR Verifier: Invalid arglist index");
SEXP sym = cp_pool_at(ctx, *argsIndex);
if (TYPEOF(sym) != SYMSXP)
Rf_error("RIR Verifier: LdVar binding not a symbol");
if (!(strlen(CHAR(PRINTNAME(sym)))))
Rf_error("RIR Verifier: LdVar empty binding name");
}
if (*cptr == Opcode::promise_) {
unsigned* promidx = reinterpret_cast<Immediate*>(cptr + 1);
objs.push_back(c->getPromise(*promidx));
}
if (*cptr == Opcode::ldarg_) {
unsigned idx = *reinterpret_cast<Immediate*>(cptr + 1);
if (idx >= MAX_ARG_IDX)
Rf_error("RIR Verifier: Loading out of index argument");
}
if (*cptr == Opcode::call_implicit_ ||
*cptr == Opcode::named_call_implicit_) {
uint32_t nargs = *reinterpret_cast<Immediate*>(cptr + 1);
for (size_t i = 0, e = nargs; i != e; ++i) {
uint32_t offset = cur.callExtra().immediateCallArguments[i];
if (offset == MISSING_ARG_IDX || offset == DOTS_ARG_IDX)
continue;
objs.push_back(c->getPromise(offset));
}
if (*cptr == Opcode::named_call_implicit_) {
for (size_t i = 0, e = nargs; i != e; ++i) {
uint32_t offset = cur.callExtra().callArgumentNames[i];
if (offset) {
SEXP name = cp_pool_at(ctx, offset);
if (TYPEOF(name) != SYMSXP && name != R_NilValue)
Rf_error("RIR Verifier: Calling target not a "
"symbol");
}
}
}
}
if (*cptr == Opcode::named_call_) {
uint32_t nargs = *reinterpret_cast<Immediate*>(cptr + 1);
for (size_t i = 0, e = nargs; i != e; ++i) {
uint32_t offset = cur.callExtra().callArgumentNames[i];
if (offset) {
SEXP name = cp_pool_at(ctx, offset);
if (TYPEOF(name) != SYMSXP && name != R_NilValue)
Rf_error(
"RIR Verifier: Calling target not a symbol");
}
}
}
if (*cptr == Opcode::mk_env_ || *cptr == Opcode::mk_stub_env_) {
uint32_t nargs = *reinterpret_cast<Immediate*>(cptr + 1);
for (size_t i = 0, e = nargs; i != e; ++i) {
uint32_t offset = cur.mkEnvExtra().names[i];
SEXP name = cp_pool_at(ctx, offset);
if (TYPEOF(name) != SYMSXP)
Rf_error(
"RIR Verifier: environment argument not a symbol");
}
}
cptr += cur.size();
if (cptr == start + c->codeSize) {
if (!(cur.isJmp() && cur.immediate.offset < 0) &&
!(cur.isExit()))
Rf_error("RIR Verifier: Last opcode should jump backwards "
"or exit");
break;
}
}
}
}
/* ----- gather ----- */
SEXP spmd_gather_integer(SEXP R_send_data, SEXP R_recv_data,
SEXP R_rank_dest, SEXP R_comm){
#ifdef LONG_VECTOR_SUPPORT
SEXP R_buff_data;
int *C_send_data = INTEGER(R_send_data),
*C_recv_data = INTEGER(R_recv_data),
*C_recv_data_fix = INTEGER(R_recv_data),
*C_buff_data,
*C_buff_data_fix;
R_xlen_t C_length_send_data = XLENGTH(R_send_data),
C_length_send_data_fix = XLENGTH(R_send_data);
int C_rank_dest = INTEGER(R_rank_dest)[0],
C_comm = INTEGER(R_comm)[0], C_comm_size, C_comm_rank, i;
if(C_length_send_data > SPMD_SHORT_LEN_MAX){
/* R_send_data is a long vector, so is R_recv_data. */
/* Since C_recv_data is not contiguious, use extra buffer to
store chunk data for MPI calls. */
MPI_Comm_size(comm[C_comm], &C_comm_size);
MPI_Comm_rank(comm[C_comm], &C_comm_rank);
if(C_comm_rank == C_rank_dest){
PROTECT(R_buff_data = allocVector(INTSXP,
(R_xlen_t) C_comm_size *
(R_xlen_t) SPMD_SHORT_LEN_MAX));
} else{
PROTECT(R_buff_data = allocVector(INTSXP, 1));
}
C_buff_data = INTEGER(R_buff_data);
C_buff_data_fix = INTEGER(R_buff_data);
/* Loop through all. */
while(C_length_send_data > SPMD_SHORT_LEN_MAX){
#if (MPI_LONG_DEBUG & 1) == 1
if(C_comm_rank == C_rank_dest){
Rprintf("C_length_send_data: %ld\n",
C_length_send_data);
}
#endif
/* Send C_send_data out to C_buff_data. */
spmd_errhandler(MPI_Gather(C_send_data,
SPMD_SHORT_LEN_MAX,
MPI_INT, C_buff_data, SPMD_SHORT_LEN_MAX,
MPI_INT, C_rank_dest, comm[C_comm]));
C_send_data = C_send_data + SPMD_SHORT_LEN_MAX;
/* Memory copy from C_buff_data to C_recv_data. */
if(C_comm_rank == C_rank_dest){
for(i = 0; i < C_comm_size; i++){
memcpy(C_recv_data, C_buff_data,
SPMD_SHORT_LEN_MAX *
sizeof(int));
C_recv_data = C_recv_data +
C_length_send_data_fix;
C_buff_data = C_buff_data +
SPMD_SHORT_LEN_MAX;
}
C_recv_data_fix = C_recv_data_fix +
SPMD_SHORT_LEN_MAX;
C_recv_data = C_recv_data_fix;
}
C_buff_data = C_buff_data_fix;
C_length_send_data = C_length_send_data -
SPMD_SHORT_LEN_MAX;
}
/* Remainder. */
if(C_length_send_data > 0){
#if (MPI_LONG_DEBUG & 1) == 1
if(C_comm_rank == C_rank_dest){
Rprintf("C_length_send_data: %ld\n",
C_length_send_data);
}
#endif
/* Send C_send_data out to C_buff_data. */
spmd_errhandler(MPI_Gather(C_send_data,
(int) C_length_send_data,
MPI_INT, C_buff_data, (int) C_length_send_data,
MPI_INT, C_rank_dest, comm[C_comm]));
/* Memory copy from C_buff_data to C_recv_data. */
if(C_comm_rank == C_rank_dest){
for(i = 0; i < C_comm_size; i++){
memcpy(C_recv_data, C_buff_data,
(int) C_length_send_data *
sizeof(int));
C_recv_data = C_recv_data +
C_length_send_data_fix;
C_buff_data = C_buff_data +
C_length_send_data;
}
}
}
UNPROTECT(1);
} else{
/* It doesn't matter if R_recv_data is a long vector or not,
since pointer address is already long int.*/
spmd_errhandler(MPI_Gather(C_send_data,
(int) C_length_send_data,
MPI_INT, C_recv_data, (int) C_length_send_data,
MPI_INT, C_rank_dest, comm[C_comm]));
}
#else
int C_length_send_data = LENGTH(R_send_data);
spmd_errhandler(MPI_Gather(INTEGER(R_send_data), C_length_send_data,
MPI_INT, INTEGER(R_recv_data), C_length_send_data,
MPI_INT, INTEGER(R_rank_dest)[0], comm[INTEGER(R_comm)[0]]));
#endif
return(R_recv_data);
} /* End of spmd_gather_integer(). */
SEXP attribute_hidden do_nchar(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP d, s, x, stype;
R_xlen_t i, len;
int allowNA;
size_t ntype;
int nc;
const char *type;
const char *xi;
wchar_t *wc;
const void *vmax;
checkArity(op, args);
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()");
len = XLENGTH(x);
stype = CADR(args);
if (!isString(stype) || LENGTH(stype) != 1)
error(_("invalid '%s' argument"), "type");
type = CHAR(STRING_ELT(stype, 0)); /* always ASCII */
ntype = strlen(type);
if (ntype == 0) error(_("invalid '%s' argument"), "type");
allowNA = asLogical(CADDR(args));
if (allowNA == NA_LOGICAL) allowNA = 0;
PROTECT(s = allocVector(INTSXP, len));
vmax = vmaxget();
for (i = 0; i < len; i++) {
SEXP sxi = STRING_ELT(x, i);
if (sxi == NA_STRING) {
INTEGER(s)[i] = 2;
continue;
}
if (strncmp(type, "bytes", ntype) == 0) {
INTEGER(s)[i] = LENGTH(sxi);
} else if (strncmp(type, "chars", ntype) == 0) {
if (IS_UTF8(sxi)) { /* assume this is valid */
const char *p = CHAR(sxi);
nc = 0;
for( ; *p; p += utf8clen(*p)) nc++;
INTEGER(s)[i] = nc;
} else if (IS_BYTES(sxi)) {
if (!allowNA) /* could do chars 0 */
error(_("number of characters is not computable for element %d in \"bytes\" encoding"), i+1);
INTEGER(s)[i] = NA_INTEGER;
} else if (mbcslocale) {
nc = (int) mbstowcs(NULL, translateChar(sxi), 0);
if (!allowNA && nc < 0)
error(_("invalid multibyte string %d"), i+1);
INTEGER(s)[i] = nc >= 0 ? nc : NA_INTEGER;
} else
INTEGER(s)[i] = (int) strlen(translateChar(sxi));
} else if (strncmp(type, "width", ntype) == 0) {
if (IS_UTF8(sxi)) { /* assume this is valid */
const char *p = CHAR(sxi);
wchar_t wc1;
nc = 0;
for( ; *p; p += utf8clen(*p)) {
utf8toucs(&wc1, p);
nc += Ri18n_wcwidth(wc1);
}
INTEGER(s)[i] = nc;
} else if (IS_BYTES(sxi)) {
if (!allowNA) /* could do width 0 */
error(_("width is not computable for element %d in \"bytes\" encoding"), i+1);
INTEGER(s)[i] = NA_INTEGER;
} else if (mbcslocale) {
xi = translateChar(sxi);
nc = (int) mbstowcs(NULL, xi, 0);
if (nc >= 0) {
wc = (wchar_t *) R_AllocStringBuffer((nc+1)*sizeof(wchar_t), &cbuff);
mbstowcs(wc, xi, nc + 1);
INTEGER(s)[i] = Ri18n_wcswidth(wc, 2147483647);
if (INTEGER(s)[i] < 1) INTEGER(s)[i] = nc;
} else if (allowNA)
error(_("invalid multibyte string %d"), i+1);
else
INTEGER(s)[i] = NA_INTEGER;
} else
INTEGER(s)[i] = (int) strlen(translateChar(sxi));
} else
error(_("invalid '%s' argument"), "type");
vmaxset(vmax);
}
R_FreeStringBufferL(&cbuff);
if ((d = getNamesAttrib(x)) != R_NilValue)
setAttrib(s, R_NamesSymbol, d);
if ((d = getDimAttrib(x)) != R_NilValue)
setAttrib(s, R_DimSymbol, d);
if ((d = getDimNamesAttrib(x)) != R_NilValue)
setAttrib(s, R_DimNamesSymbol, d);
UNPROTECT(2);
return s;
}
SEXP Cdqrls(SEXP x, SEXP y, SEXP tol, SEXP chk)
{
SEXP ans;
SEXP qr, coefficients, residuals, effects, pivot, qraux;
int n, ny = 0, p, rank, nprotect = 4, pivoted = 0;
double rtol = asReal(tol), *work;
Rboolean check = asLogical(chk);
ans = getDimAttrib(x);
if(check && length(ans) != 2) error(_("'x' is not a matrix"));
int *dims = INTEGER(ans);
n = dims[0]; p = dims[1];
if(n) ny = (int)(XLENGTH(y)/n); /* y : n x ny, or an n - vector */
if(check && n * ny != XLENGTH(y))
error(_("dimensions of 'x' (%d,%d) and 'y' (%d) do not match"),
n,p, XLENGTH(y));
/* These lose attributes, so do after we have extracted dims */
if (TYPEOF(x) != REALSXP) {
PROTECT(x = coerceVector(x, REALSXP));
nprotect++;
}
if (TYPEOF(y) != REALSXP) {
PROTECT(y = coerceVector(y, REALSXP));
nprotect++;
}
double *rptr = REAL(x);
for (R_xlen_t i = 0 ; i < XLENGTH(x) ; i++)
if(!R_FINITE(rptr[i])) error(_("NA/NaN/Inf in '%s'"), "x");
rptr = REAL(y);
for (R_xlen_t i = 0 ; i < XLENGTH(y) ; i++)
if(!R_FINITE(rptr[i])) error(_("NA/NaN/Inf in '%s'"), "y");
const char *ansNms[] = {"qr", "coefficients", "residuals", "effects",
"rank", "pivot", "qraux", "tol", "pivoted", ""};
PROTECT(ans = mkNamed(VECSXP, ansNms));
SET_VECTOR_ELT(ans, 0, qr = duplicate(x));
coefficients = (ny > 1) ? allocMatrix(REALSXP, p, ny) : allocVector(REALSXP, p);
PROTECT(coefficients);
SET_VECTOR_ELT(ans, 1, coefficients);
SET_VECTOR_ELT(ans, 2, residuals = duplicate(y));
SET_VECTOR_ELT(ans, 3, effects = duplicate(y));
PROTECT(pivot = allocVector(INTSXP, p));
int *ip = INTEGER(pivot);
for(int i = 0; i < p; i++) ip[i] = i+1;
SET_VECTOR_ELT(ans, 5, pivot);
PROTECT(qraux = allocVector(REALSXP, p));
SET_VECTOR_ELT(ans, 6, qraux);
SET_VECTOR_ELT(ans, 7, tol);
work = (double *) R_alloc(2 * p, sizeof(double));
F77_CALL(dqrls)(REAL(qr), &n, &p, REAL(y), &ny, &rtol,
REAL(coefficients), REAL(residuals), REAL(effects),
&rank, INTEGER(pivot), REAL(qraux), work);
SET_VECTOR_ELT(ans, 4, ScalarInteger(rank));
for(int i = 0; i < p; i++)
if(ip[i] != i+1) { pivoted = 1; break; }
SET_VECTOR_ELT(ans, 8, ScalarLogical(pivoted));
UNPROTECT(nprotect);
return ans;
}
SEXP attribute_hidden complex_binary(ARITHOP_TYPE code, SEXP s1, SEXP s2)
{
R_xlen_t i,i1, i2, n, n1, n2;
SEXP ans;
/* Note: "s1" and "s2" are protected in the calling code. */
n1 = XLENGTH(s1);
n2 = XLENGTH(s2);
/* S4-compatibility change: if n1 or n2 is 0, result is of length 0 */
if (n1 == 0 || n2 == 0) return(allocVector(CPLXSXP, 0));
n = (n1 > n2) ? n1 : n2;
ans = R_allocOrReuseVector(s1, s2, CPLXSXP, n);
PROTECT(ans);
switch (code) {
case PLUSOP:
mod_iterate(n1, n2, i1, i2) {
if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
Rcomplex x1 = COMPLEX(s1)[i1], x2 = COMPLEX(s2)[i2];
COMPLEX(ans)[i].r = x1.r + x2.r;
COMPLEX(ans)[i].i = x1.i + x2.i;
}
break;
case MINUSOP:
mod_iterate(n1, n2, i1, i2) {
if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
Rcomplex x1 = COMPLEX(s1)[i1], x2 = COMPLEX(s2)[i2];
COMPLEX(ans)[i].r = x1.r - x2.r;
COMPLEX(ans)[i].i = x1.i - x2.i;
}
break;
case TIMESOP:
mod_iterate(n1, n2, i1, i2) {
if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
SET_C99_COMPLEX(COMPLEX(ans), i,
C99_COMPLEX2(s1, i1) * C99_COMPLEX2(s2, i2));
}
break;
case DIVOP:
mod_iterate(n1, n2, i1, i2) {
if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
SET_C99_COMPLEX(COMPLEX(ans), i,
C99_COMPLEX2(s1, i1) / C99_COMPLEX2(s2, i2));
}
break;
case POWOP:
mod_iterate(n1, n2, i1, i2) {
if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
SET_C99_COMPLEX(COMPLEX(ans), i,
mycpow(C99_COMPLEX2(s1, i1), C99_COMPLEX2(s2, i2)));
}
break;
default:
error(_("unimplemented complex operation"));
}
UNPROTECT(1);
/* quick return if there are no attributes */
if (ATTRIB(s1) == R_NilValue && ATTRIB(s2) == R_NilValue)
return ans;
/* Copy attributes from longer argument. */
if (ans != s2 && n == n2 && ATTRIB(s2) != R_NilValue)
copyMostAttrib(s2, ans);
if (ans != s1 && n == n1 && ATTRIB(s1) != R_NilValue)
copyMostAttrib(s1, ans); /* Done 2nd so s1's attrs overwrite s2's */
return ans;
}
SEXP clahe (SEXP x, SEXP _uiNrX, SEXP _uiNrY, SEXP _uiNrBins, SEXP _fCliplimit, SEXP _keepRange) {
int nx, ny, nz, i, j;
unsigned int uiNrX, uiNrY, uiNrBins;
float fCliplimit;
int keepRange;
double *src, *tgt;
SEXP res;
kz_pixel_t min = 0, max = uiNR_OF_GREY-1;
kz_pixel_t *img;
double maxPixelValue = uiNR_OF_GREY-1;
PROTECT( res = allocVector(REALSXP, XLENGTH(x)) );
DUPLICATE_ATTRIB(res, x);
nx = INTEGER(GET_DIM(x))[0];
ny = INTEGER(GET_DIM(x))[1];
nz = getNumberOfFrames(x, 0);
uiNrX = INTEGER(_uiNrX)[0];
uiNrY = INTEGER(_uiNrY)[0];
uiNrBins = INTEGER(_uiNrBins)[0];
fCliplimit = REAL(_fCliplimit)[0];
keepRange = LOGICAL(_keepRange)[0];
img = R_Calloc(nx*ny, kz_pixel_t);
// process channels separately
for(j = 0; j < nz; j++) {
src = &(REAL(x)[j*nx*ny]);
tgt = &(REAL(res)[j*nx*ny]);
if (keepRange) {
min = uiNR_OF_GREY-1;
max = 0;
}
// convert frame to CLAHE-compatible format
for (i = 0; i < nx*ny; i++) {
double el = src[i];
// clip
if (el < 0.0) el = 0;
else if (el > 1.0) el = 1.0;
// convert to int
kz_pixel_t nel = (kz_pixel_t) round(el * maxPixelValue);
if (keepRange) {
if (nel < min) min = nel;
if (nel > max) max = nel;
}
img[i] = nel;
}
int val = CLAHE (img, (unsigned int) nx, (unsigned int) ny,
min, max, uiNrX, uiNrY, uiNrBins, fCliplimit);
// translate internal error codes
switch (val) {
case -1:
error("# of regions x-direction too large");
break;
case -2:
error("# of regions y-direction too large");
break;
case -3:
error("x-resolution no multiple of 'nx'");
break;
case -4:
error("y-resolution no multiple of 'ny'");
break;
case -5:
error("maximum too large");
break;
case -6:
error("minimum equal or larger than maximum");
break;
case -7:
error("at least 4 contextual regions required");
break;
case -8:
error("not enough memory! (try reducing 'bins')");
break;
}
// convert back to [0:1] range
for (i = 0; i < nx*ny; i++) {
tgt[i] = (double) img[i] / maxPixelValue;
}
}
R_Free(img);
UNPROTECT(1);
return res;
}
SEXP Cdqrls(SEXP x, SEXP y, SEXP tol)
{
SEXP ans, ansnames;
SEXP qr, coefficients, residuals, effects, pivot, qraux;
int n, ny = 0, p, rank, nprotect = 4, pivoted = 0;
double rtol = asReal(tol), *work;
int *dims = INTEGER(getAttrib(x, R_DimSymbol));
n = dims[0]; p = dims[1];
if(n) ny = LENGTH(y)/n; /* n x ny, or a vector */
/* These lose attributes, so do after we have extracted dims */
if (TYPEOF(x) != REALSXP) {
PROTECT(x = coerceVector(x, REALSXP));
nprotect++;
}
if (TYPEOF(y) != REALSXP) {
PROTECT(y = coerceVector(y, REALSXP));
nprotect++;
}
double *rptr = REAL(x);
for (R_xlen_t i = 0 ; i < XLENGTH(x) ; i++)
if(!R_FINITE(rptr[i])) error("NA/NaN/Inf in 'x'");
rptr = REAL(y);
for (R_xlen_t i = 0 ; i < XLENGTH(y) ; i++)
if(!R_FINITE(rptr[i])) error("NA/NaN/Inf in 'y'");
PROTECT(ans = allocVector(VECSXP, 9));
ansnames = allocVector(STRSXP, 9);
setAttrib(ans, R_NamesSymbol, ansnames);
SET_STRING_ELT(ansnames, 0, mkChar("qr"));
SET_STRING_ELT(ansnames, 1, mkChar("coefficients"));
SET_STRING_ELT(ansnames, 2, mkChar("residuals"));
SET_STRING_ELT(ansnames, 3, mkChar("effects"));
SET_STRING_ELT(ansnames, 4, mkChar("rank"));
SET_STRING_ELT(ansnames, 5, mkChar("pivot"));
SET_STRING_ELT(ansnames, 6, mkChar("qraux"));
SET_STRING_ELT(ansnames, 7, mkChar("tol"));
SET_STRING_ELT(ansnames, 8, mkChar("pivoted"));
SET_VECTOR_ELT(ans, 0, qr = duplicate(x));
if (ny > 1) coefficients = allocMatrix(REALSXP, p, ny);
else coefficients = allocVector(REALSXP, p);
PROTECT(coefficients);
SET_VECTOR_ELT(ans, 1, coefficients);
SET_VECTOR_ELT(ans, 2, residuals = duplicate(y));
SET_VECTOR_ELT(ans, 3, effects = duplicate(y));
PROTECT(pivot = allocVector(INTSXP, p));
int *ip = INTEGER(pivot);
for(int i = 0; i < p; i++) ip[i] = i+1;
SET_VECTOR_ELT(ans, 5, pivot);
PROTECT(qraux = allocVector(REALSXP, p));
SET_VECTOR_ELT(ans, 6, qraux);
SET_VECTOR_ELT(ans, 7, tol);
work = (double *) R_alloc(2 * p, sizeof(double));
F77_CALL(dqrls)(REAL(qr), &n, &p, REAL(y), &ny, &rtol,
REAL(coefficients), REAL(residuals), REAL(effects),
&rank, INTEGER(pivot), REAL(qraux), work);
SET_VECTOR_ELT(ans, 4, ScalarInteger(rank));
for(int i = 0; i < p; i++)
if(ip[i] != i+1) { pivoted = 1; break; }
SET_VECTOR_ELT(ans, 8, ScalarLogical(pivoted));
UNPROTECT(nprotect);
return ans;
}
SEXP df_split(SEXP s, SEXP sSep, SEXP sNamesSep, SEXP sResilient, SEXP sNcol,
SEXP sWhat, SEXP sColNames, SEXP sSkip, SEXP sNlines, SEXP sQuote) {
char sep;
int nsep, use_ncol, resilient, ncol;
long i, j, k, m, len, nmsep_flag, skip, quoteLen;
unsigned long nrow;
char num_buf[48];
const char *c, *c2, *sraw = 0, *send = 0, *quoteChars;
long nlines = asLong(sNlines, -1);
SEXP sOutput, tmp, sOutputNames, st, clv;
/* Parse inputs */
sep = CHAR(STRING_ELT(sSep, 0))[0];
nsep = (TYPEOF(sNamesSep) == STRSXP && LENGTH(sNamesSep) > 0) ? ((int) (unsigned char) *CHAR(STRING_ELT(sNamesSep, 0))) : -1;
nmsep_flag = (nsep > 0);
use_ncol = asInteger(sNcol);
resilient = asInteger(sResilient);
ncol = use_ncol; /* NOTE: "character" is prepended by the R code if nmsep is TRUE,
so ncol *does* include the key column */
skip = asLong(sSkip, 0);
/* parse quote information */
quoteChars = CHAR(STRING_ELT(sQuote, 0));
quoteLen = strlen(quoteChars);
/* count non-NA columns */
for (i = 0; i < use_ncol; i++)
if (TYPEOF(VECTOR_ELT(sWhat,i)) == NILSXP) ncol--;
/* check input */
if (TYPEOF(s) == RAWSXP) {
nrow = (nlines >= 0) ? count_lines_bounded(s, nlines + skip) : count_lines(s);
sraw = (const char*) RAW(s);
send = sraw + XLENGTH(s);
if (nrow >= skip) {
unsigned long slen = XLENGTH(s);
nrow = nrow - skip;
i = 0;
while (i < skip && (sraw = memchr(sraw, '\n', slen))) { sraw++; i++; }
} else {
nrow = 0;
sraw = send;
}
} else if (TYPEOF(s) == STRSXP) {
nrow = XLENGTH(s);
if (nrow >= skip) {
nrow -= skip;
} else {
skip = nrow;
nrow = 0;
}
} else
Rf_error("invalid input to split - must be a raw or character vector");
if (nlines >= 0 && nrow > nlines) nrow = nlines;
/* allocate result */
PROTECT(sOutput = allocVector(VECSXP, ncol));
/* set names */
setAttrib(sOutput, R_NamesSymbol, sOutputNames = allocVector(STRSXP, ncol));
if (nrow > INT_MAX)
Rf_warning("R currently doesn't support large data frames, but we have %lu rows, returning a named list instead", nrow);
else {
/* set automatic row names */
PROTECT(tmp = allocVector(INTSXP, 2));
INTEGER(tmp)[0] = NA_INTEGER;
INTEGER(tmp)[1] = -nrow;
setAttrib(sOutput, R_RowNamesSymbol, tmp);
UNPROTECT(1);
/* set class */
classgets(sOutput, mkString("data.frame"));
}
/* Create SEXP for each element of the output */
j = 0;
for (i = 0; i < use_ncol; i++) {
if (TYPEOF(VECTOR_ELT(sWhat,i)) != NILSXP) /* copy col.name */
SET_STRING_ELT(sOutputNames, j, STRING_ELT(sColNames, i));
switch (TYPEOF(VECTOR_ELT(sWhat,i))) {
case LGLSXP:
case INTSXP:
case REALSXP:
case CPLXSXP:
case STRSXP:
case RAWSXP:
SET_VECTOR_ELT(sOutput, j++, allocVector(TYPEOF(VECTOR_ELT(sWhat,i)), nrow));
break;
case VECSXP:
SET_VECTOR_ELT(sOutput, j++, st = allocVector(REALSXP, nrow));
clv = PROTECT(allocVector(STRSXP, 2));
SET_STRING_ELT(clv, 0, mkChar("POSIXct"));
SET_STRING_ELT(clv, 1, mkChar("POSIXt"));
setAttrib(st, R_ClassSymbol, clv);
/* this is somewhat a security precaution such that users
don't get surprised -- if there is no TZ R will
render it in local time - which is correct but
may confuse people that didn't use GMT to start with */
setAttrib(st, install("tzone"), mkString("GMT"));
UNPROTECT(1);
break;
case NILSXP:
break;
default:
Rf_error("Unsupported input to what %u.", TYPEOF(VECTOR_ELT(sWhat,i)));
break;
}
}
/* Cycle through the rows and extract the data */
for (k = 0; k < nrow; k++) {
const char *l = 0, *le;
if (TYPEOF(s) == RAWSXP) {
l = sraw;
le = memchr(l, '\n', send - l);
if (!le) le = send;
sraw = le + 1;
if (*(le - 1) == '\r' ) le--; /* account for DOS-style '\r\n' */
} else {
l = CHAR(STRING_ELT(s, k + skip));
le = l + strlen(l); /* probably lame, but using strings is way inefficient anyway ;) */
}
if (nmsep_flag) {
c = memchr(l, nsep, le - l);
if (c) {
SET_STRING_ELT(VECTOR_ELT(sOutput, 0), k, Rf_mkCharLen(l, c - l));
l = c + 1;
} else
SET_STRING_ELT(VECTOR_ELT(sOutput, 0), k, R_BlankString);
}
i = nmsep_flag;
j = nmsep_flag;
while (l < le) {
if (!(c = memchr(l, sep, le - l)))
c = le;
if (i >= use_ncol) {
if (resilient) break;
Rf_error("line %lu: too many input columns (expected %u)", k, use_ncol);
}
switch(TYPEOF(VECTOR_ELT(sWhat,i))) { // NOTE: no matching case for NILSXP
case LGLSXP:
len = (int) (c - l);
if (len > sizeof(num_buf) - 1)
len = sizeof(num_buf) - 1;
memcpy(num_buf, l, len);
num_buf[len] = 0;
int tr = StringTrue(num_buf), fa = StringFalse(num_buf);
LOGICAL(VECTOR_ELT(sOutput, j))[k] = (tr || fa) ? tr : NA_INTEGER;
j++;
break;
case INTSXP:
len = (int) (c - l);
/* watch for overflow and truncate -- should we warn? */
if (len > sizeof(num_buf) - 1)
len = sizeof(num_buf) - 1;
memcpy(num_buf, l, len);
num_buf[len] = 0;
INTEGER(VECTOR_ELT(sOutput, j))[k] = Strtoi(num_buf, 10);
j++;
break;
case REALSXP:
len = (int) (c - l);
/* watch for overflow and truncate -- should we warn? */
if (len > sizeof(num_buf) - 1)
len = sizeof(num_buf) - 1;
memcpy(num_buf, l, len);
num_buf[len] = 0;
REAL(VECTOR_ELT(sOutput, j))[k] = R_atof(num_buf);
j++;
break;
case CPLXSXP:
len = (int) (c - l);
/* watch for overflow and truncate -- should we warn? */
if (len > sizeof(num_buf) - 1)
len = sizeof(num_buf) - 1;
memcpy(num_buf, l, len);
num_buf[len] = 0;
COMPLEX(VECTOR_ELT(sOutput, j))[k] = strtoc(num_buf, TRUE);
j++;
break;
case STRSXP:
c2 = c;
if (quoteLen) {
for (m = 0; m < quoteLen; m++) {
if (*l == quoteChars[m]) {
l++;
if (!(c2 = memchr(l, quoteChars[m], le - l))) {
Rf_error("End of line within quoted string.");
} else {
if (!(c = memchr(c2, (unsigned char) sep, le - c2)))
c = le;
}
}
}
}
SET_STRING_ELT(VECTOR_ELT(sOutput, j), k, Rf_mkCharLen(l, c2 - l));
j++;
break;
case RAWSXP:
len = (int) (c - l);
/* watch for overflow and truncate -- should we warn? */
if (len > sizeof(num_buf) - 1)
len = sizeof(num_buf) - 1;
memcpy(num_buf, l, len);
num_buf[len] = 0;
RAW(VECTOR_ELT(sOutput, j))[k] = strtoraw(num_buf);
j++;
break;
case VECSXP:
REAL(VECTOR_ELT(sOutput, j))[k] = parse_ts(l, c);
j++;
}
l = c + 1;
i++;
}
/* fill-up unused columns */
while (i < use_ncol) {
switch (TYPEOF(VECTOR_ELT(sWhat,i))) { // NOTE: no matching case for NILSXP
case LGLSXP:
LOGICAL(VECTOR_ELT(sOutput, j++))[k] = NA_INTEGER;
break;
case INTSXP:
INTEGER(VECTOR_ELT(sOutput, j++))[k] = NA_INTEGER;
break;
case REALSXP:
case VECSXP:
REAL(VECTOR_ELT(sOutput, j++))[k] = NA_REAL;
break;
case CPLXSXP:
COMPLEX(VECTOR_ELT(sOutput, j))[k].r = NA_REAL;
COMPLEX(VECTOR_ELT(sOutput, j++))[k].i = NA_REAL;
break;
case STRSXP:
SET_STRING_ELT(VECTOR_ELT(sOutput, j++), k, R_NaString);
break;
case RAWSXP:
RAW(VECTOR_ELT(sOutput, j))[k] = (Rbyte) 0;
break;
}
i++;
}
}
UNPROTECT(1); /* sOutput */
return(sOutput);
}
/* to match seq.default */
SEXP attribute_hidden do_seq(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans = R_NilValue /* -Wall */, tmp, from, to, by, len, along;
int nargs = length(args), lf;
Rboolean One = nargs == 1;
R_xlen_t i, lout = NA_INTEGER;
static SEXP do_seq_formals = NULL;
if (DispatchOrEval(call, op, R_SeqCharSXP, args, rho, &ans, 0, 1))
return(ans);
/* This is a primitive and we manage argument matching ourselves.
We pretend this is
seq(from, to, by, length.out, along.with, ...)
*/
if (do_seq_formals == NULL) {
do_seq_formals = CONS(R_NilValue, CONS(R_NilValue, list4(R_NilValue, R_NilValue, R_NilValue, R_NilValue)));
R_PreserveObject(do_seq_formals);
tmp = do_seq_formals;
SET_TAG(tmp, install("from")); tmp = CDR(tmp);
SET_TAG(tmp, install("to")); tmp = CDR(tmp);
SET_TAG(tmp, install("by")); tmp = CDR(tmp);
SET_TAG(tmp, R_LengthOutSymbol); tmp = CDR(tmp);
SET_TAG(tmp, R_AlongWithSymbol); tmp = CDR(tmp);
SET_TAG(tmp, R_DotsSymbol);
}
PROTECT(args = matchArgs(do_seq_formals, args, call));
from = CAR(args); args = CDR(args);
to = CAR(args); args = CDR(args);
by = CAR(args); args = CDR(args);
len = CAR(args); args = CDR(args);
along = CAR(args);
if(One && from != R_MissingArg) {
lf = length(from);
if(lf == 1 && (TYPEOF(from) == INTSXP || TYPEOF(from) == REALSXP)) {
double rfrom = asReal(from);
if (!R_FINITE(rfrom))
errorcall(call, "'from' cannot be NA, NaN or infinite");
ans = seq_colon(1.0, rfrom, call);
}
else if (lf)
ans = seq_colon(1.0, (double)lf, call);
else
ans = allocVector(INTSXP, 0);
goto done;
}
if(along != R_MissingArg) {
lout = XLENGTH(along);
if(One) {
ans = lout ? seq_colon(1.0, (double)lout, call) : allocVector(INTSXP, 0);
goto done;
}
} else if(len != R_MissingArg && len != R_NilValue) {
double rout = asReal(len);
if(ISNAN(rout) || rout <= -0.5)
errorcall(call, _("'length.out' must be a non-negative number"));
if(length(len) != 1)
warningcall(call, _("first element used of '%s' argument"),
"length.out");
lout = (R_xlen_t) ceil(rout);
}
if(lout == NA_INTEGER) {
double rfrom = asReal(from), rto = asReal(to), rby = asReal(by), *ra;
if(from == R_MissingArg) rfrom = 1.0;
else if(length(from) != 1) error("'from' must be of length 1");
if(to == R_MissingArg) rto = 1.0;
else if(length(to) != 1) error("'to' must be of length 1");
if (!R_FINITE(rfrom))
errorcall(call, "'from' cannot be NA, NaN or infinite");
if (!R_FINITE(rto))
errorcall(call, "'to' cannot be NA, NaN or infinite");
if(by == R_MissingArg)
ans = seq_colon(rfrom, rto, call);
else {
if(length(by) != 1) error("'by' must be of length 1");
double del = rto - rfrom, n, dd;
R_xlen_t nn;
if(!R_FINITE(rfrom))
errorcall(call, _("'from' must be finite"));
if(!R_FINITE(rto))
errorcall(call, _("'to' must be finite"));
if(del == 0.0 && rto == 0.0) {
ans = to;
goto done;
}
/* printf("from = %f, to = %f, by = %f\n", rfrom, rto, rby); */
n = del/rby;
if(!R_FINITE(n)) {
if(del == 0.0 && rby == 0.0) {
ans = from;
goto done;
} else
errorcall(call, _("invalid '(to - from)/by' in 'seq'"));
}
dd = fabs(del)/fmax2(fabs(rto), fabs(rfrom));
if(dd < 100 * DBL_EPSILON) {
ans = from;
goto done;
}
#ifdef LONG_VECTOR_SUPPORT
if(n > 100 * (double) INT_MAX)
#else
if(n > (double) INT_MAX)
#endif
errorcall(call, _("'by' argument is much too small"));
if(n < - FEPS)
errorcall(call, _("wrong sign in 'by' argument"));
if(TYPEOF(from) == INTSXP &&
TYPEOF(to) == INTSXP &&
TYPEOF(by) == INTSXP) {
int *ia, ifrom = asInteger(from), iby = asInteger(by);
/* With the current limits on integers and FEPS
reduced below 1/INT_MAX this is the same as the
next, so this is future-proofing against longer integers.
*/
/* seq.default gives integer result from
from + (0:n)*by
*/
nn = (R_xlen_t) n;
ans = allocVector(INTSXP, nn+1);
ia = INTEGER(ans);
for(i = 0; i <= nn; i++)
ia[i] = (int)(ifrom + i * iby);
} else {
nn = (int)(n + FEPS);
ans = allocVector(REALSXP, nn+1);
ra = REAL(ans);
for(i = 0; i <= nn; i++)
ra[i] = rfrom + (double)i * rby;
/* Added in 2.9.0 */
if (nn > 0)
if((rby > 0 && ra[nn] > rto) || (rby < 0 && ra[nn] < rto))
ra[nn] = rto;
}
}
} else if (lout == 0) {
ans = allocVector(INTSXP, 0);
} else if (One) {
ans = seq_colon(1.0, (double)lout, call);
} else if (by == R_MissingArg) {
double rfrom = asReal(from), rto = asReal(to), rby;
if(to == R_MissingArg) rto = rfrom + (double)lout - 1;
if(from == R_MissingArg) rfrom = rto - (double)lout + 1;
if(!R_FINITE(rfrom))
errorcall(call, _("'from' must be finite"));
if(!R_FINITE(rto))
errorcall(call, _("'to' must be finite"));
ans = allocVector(REALSXP, lout);
if(lout > 0) REAL(ans)[0] = rfrom;
if(lout > 1) REAL(ans)[lout - 1] = rto;
if(lout > 2) {
rby = (rto - rfrom)/(double)(lout - 1);
for(i = 1; i < lout-1; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
REAL(ans)[i] = rfrom + (double)i*rby;
}
}
} else if (to == R_MissingArg) {
double rfrom = asReal(from), rby = asReal(by), rto;
if(from == R_MissingArg) rfrom = 1.0;
if(!R_FINITE(rfrom))
errorcall(call, _("'from' must be finite"));
if(!R_FINITE(rby))
errorcall(call, _("'by' must be finite"));
rto = rfrom + (double)(lout-1)*rby;
if(rby == (int)rby && rfrom <= INT_MAX && rfrom >= INT_MIN
&& rto <= INT_MAX && rto >= INT_MIN) {
ans = allocVector(INTSXP, lout);
for(i = 0; i < lout; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
INTEGER(ans)[i] = (int)(rfrom + (double)i*rby);
}
} else {
ans = allocVector(REALSXP, lout);
for(i = 0; i < lout; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
REAL(ans)[i] = rfrom + (double)i*rby;
}
}
} else if (from == R_MissingArg) {
double rto = asReal(to), rby = asReal(by),
rfrom = rto - (double)(lout-1)*rby;
if(!R_FINITE(rto))
errorcall(call, _("'to' must be finite"));
if(!R_FINITE(rby))
errorcall(call, _("'by' must be finite"));
if(rby == (int)rby && rfrom <= INT_MAX && rfrom >= INT_MIN
&& rto <= INT_MAX && rto >= INT_MIN) {
ans = allocVector(INTSXP, lout);
for(i = 0; i < lout; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
INTEGER(ans)[i] = (int)(rto - (double)(lout - 1 - i)*rby);
}
} else {
ans = allocVector(REALSXP, lout);
for(i = 0; i < lout; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
REAL(ans)[i] = rto - (double)(lout - 1 - i)*rby;
}
}
} else
errorcall(call, _("too many arguments"));
done:
UNPROTECT(1);
return ans;
}
SEXP attribute_hidden do_earg_transpose(SEXP call, SEXP op, SEXP arg_x, SEXP rho)
{
SEXP a, r, dims, dimnames, dimnamesnames = R_NilValue,
ndimnamesnames, rnames, cnames;
int ldim, ncol = 0, nrow = 0;
R_xlen_t len = 0;
a = arg_x;
if (isVector(a)) {
dims = getDimAttrib(a);
ldim = length(dims);
rnames = R_NilValue;
cnames = R_NilValue;
switch(ldim) {
case 0:
len = nrow = LENGTH(a);
ncol = 1;
rnames = getNamesAttrib(a);
dimnames = rnames;/* for isNull() below*/
break;
case 1:
len = nrow = LENGTH(a);
ncol = 1;
dimnames = getDimNamesAttrib(a);
if (dimnames != R_NilValue) {
rnames = VECTOR_ELT(dimnames, 0);
dimnamesnames = getNamesAttrib(dimnames);
}
break;
case 2:
ncol = ncols(a);
nrow = nrows(a);
len = XLENGTH(a);
dimnames = getDimNamesAttrib(a);
if (dimnames != R_NilValue) {
rnames = VECTOR_ELT(dimnames, 0);
cnames = VECTOR_ELT(dimnames, 1);
dimnamesnames = getNamesAttrib(dimnames);
}
break;
default:
goto not_matrix;
}
}
else
goto not_matrix;
PROTECT(r = allocVector(TYPEOF(a), len));
R_xlen_t i, j, l_1 = len-1;
switch (TYPEOF(a)) {
case LGLSXP:
case INTSXP:
// filling in columnwise, "accessing row-wise":
for (i = 0, j = 0; i < len; i++, j += nrow) {
if (j > l_1) j -= l_1;
INTEGER(r)[i] = INTEGER(a)[j];
}
break;
case REALSXP:
for (i = 0, j = 0; i < len; i++, j += nrow) {
if (j > l_1) j -= l_1;
REAL(r)[i] = REAL(a)[j];
}
break;
case CPLXSXP:
for (i = 0, j = 0; i < len; i++, j += nrow) {
if (j > l_1) j -= l_1;
COMPLEX(r)[i] = COMPLEX(a)[j];
}
break;
case STRSXP:
for (i = 0, j = 0; i < len; i++, j += nrow) {
if (j > l_1) j -= l_1;
SET_STRING_ELT(r, i, STRING_ELT(a,j));
}
break;
case VECSXP:
for (i = 0, j = 0; i < len; i++, j += nrow) {
if (j > l_1) j -= l_1;
SET_VECTOR_ELT(r, i, VECTOR_ELT(a,j));
}
break;
case RAWSXP:
for (i = 0, j = 0; i < len; i++, j += nrow) {
if (j > l_1) j -= l_1;
RAW(r)[i] = RAW(a)[j];
}
break;
default:
UNPROTECT(1);
goto not_matrix;
}
PROTECT(dims = allocVector(INTSXP, 2));
INTEGER(dims)[0] = ncol;
INTEGER(dims)[1] = nrow;
setAttrib(r, R_DimSymbol, dims);
UNPROTECT(1);
/* R <= 2.2.0: dropped list(NULL,NULL) dimnames :
* if(rnames != R_NilValue || cnames != R_NilValue) */
if(!isNull(dimnames)) {
PROTECT(dimnames = allocVector(VECSXP, 2));
SET_VECTOR_ELT(dimnames, 0, cnames);
SET_VECTOR_ELT(dimnames, 1, rnames);
if(!isNull(dimnamesnames)) {
PROTECT(ndimnamesnames = allocVector(VECSXP, 2));
SET_VECTOR_ELT(ndimnamesnames, 1, STRING_ELT(dimnamesnames, 0));
SET_VECTOR_ELT(ndimnamesnames, 0,
(ldim == 2) ? STRING_ELT(dimnamesnames, 1):
R_BlankString);
setAttrib(dimnames, R_NamesSymbol, ndimnamesnames);
UNPROTECT(1);
}
setAttrib(r, R_DimNamesSymbol, dimnames);
UNPROTECT(1);
}
copyMostAttrib(a, r);
UNPROTECT(1);
return r;
not_matrix:
error(_("argument is not a matrix"));
return call;/* never used; just for -Wall */
}
/* iconv(x, from, to, sub, mark) */
SEXP attribute_hidden do_iconv(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP ans, x = CAR(args), si;
void * obj;
const char *inbuf;
char *outbuf;
const char *sub;
size_t inb, outb, res;
R_StringBuffer cbuff = {NULL, 0, MAXELTSIZE};
Rboolean isRawlist = FALSE;
checkArity(op, args);
if(isNull(x)) { /* list locales */
#ifdef HAVE_ICONVLIST
cnt = 0;
iconvlist(count_one, NULL);
PROTECT(ans = allocVector(STRSXP, cnt));
cnt = 0;
iconvlist(write_one, (void *)ans);
#else
PROTECT(ans = R_NilValue);
#endif
} else {
int mark, toRaw;
const char *from, *to;
Rboolean isLatin1 = FALSE, isUTF8 = FALSE;
args = CDR(args);
if(!isString(CAR(args)) || length(CAR(args)) != 1)
error(_("invalid '%s' argument"), "from");
from = CHAR(STRING_ELT(CAR(args), 0)); /* ASCII */
args = CDR(args);
if(!isString(CAR(args)) || length(CAR(args)) != 1)
error(_("invalid '%s' argument"), "to");
to = CHAR(STRING_ELT(CAR(args), 0));
args = CDR(args);
if(!isString(CAR(args)) || length(CAR(args)) != 1)
error(_("invalid '%s' argument"), "sub");
if(STRING_ELT(CAR(args), 0) == NA_STRING) sub = NULL;
else sub = translateChar(STRING_ELT(CAR(args), 0));
args = CDR(args);
mark = asLogical(CAR(args));
if(mark == NA_LOGICAL)
error(_("invalid '%s' argument"), "mark");
args = CDR(args);
toRaw = asLogical(CAR(args));
if(toRaw == NA_LOGICAL)
error(_("invalid '%s' argument"), "toRaw");
/* some iconv's allow "UTF8", but libiconv does not */
if(streql(from, "UTF8") || streql(from, "utf8") ) from = "UTF-8";
if(streql(to, "UTF8") || streql(to, "utf8") ) to = "UTF-8";
/* Should we do something about marked CHARSXPs in 'from = ""'? */
if(streql(to, "UTF-8")) isUTF8 = TRUE;
if(streql(to, "latin1") || streql(to, "ISO_8859-1")
|| streql(to, "CP1252")) isLatin1 = TRUE;
if(streql(to, "") && known_to_be_latin1) isLatin1 = TRUE;
if(streql(to, "") && known_to_be_utf8) isUTF8 = TRUE;
obj = Riconv_open(to, from);
if(obj == (iconv_t)(-1))
#ifdef Win32
error(_("unsupported conversion from '%s' to '%s' in codepage %d"),
from, to, localeCP);
#else
error(_("unsupported conversion from '%s' to '%s'"), from, to);
#endif
isRawlist = (TYPEOF(x) == VECSXP);
if(isRawlist) {
if(toRaw)
PROTECT(ans = duplicate(x));
else {
PROTECT(ans = allocVector(STRSXP, LENGTH(x)));
DUPLICATE_ATTRIB(ans, x);
}
} else {
if(TYPEOF(x) != STRSXP)
error(_("'x' must be a character vector"));
if(toRaw) {
PROTECT(ans = allocVector(VECSXP, LENGTH(x)));
DUPLICATE_ATTRIB(ans, x);
} else
PROTECT(ans = duplicate(x));
}
R_AllocStringBuffer(0, &cbuff); /* 0 -> default */
for(R_xlen_t i = 0; i < XLENGTH(x); i++) {
if (isRawlist) {
si = VECTOR_ELT(x, i);
if (TYPEOF(si) == NILSXP) {
if (!toRaw) SET_STRING_ELT(ans, i, NA_STRING);
continue;
} else if (TYPEOF(si) != RAWSXP)
error(_("'x' must be a list of NULL or raw vectors"));
} else {
si = STRING_ELT(x, i);
if (si == NA_STRING) {
if(!toRaw) SET_STRING_ELT(ans, i, NA_STRING);
continue;
}
}
top_of_loop:
inbuf = isRawlist ? (const char *) RAW(si) : CHAR(si);
inb = LENGTH(si);
outbuf = cbuff.data; outb = cbuff.bufsize - 1;
/* First initialize output */
Riconv (obj, NULL, NULL, &outbuf, &outb);
next_char:
/* Then convert input */
res = Riconv(obj, &inbuf , &inb, &outbuf, &outb);
*outbuf = '\0';
/* other possible error conditions are incomplete
and invalid multibyte chars */
if(res == -1 && errno == E2BIG) {
R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
goto top_of_loop;
} else if(res == -1 && sub &&
(errno == EILSEQ || errno == EINVAL)) {
/* it seems this gets thrown for non-convertible input too */
if(strcmp(sub, "byte") == 0) {
if(outb < 5) {
R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
goto top_of_loop;
}
snprintf(outbuf, 5, "<%02x>", (unsigned char)*inbuf);
outbuf += 4; outb -= 4;
} else {
size_t j;
if(outb < strlen(sub)) {
R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
goto top_of_loop;
}
memcpy(outbuf, sub, j = strlen(sub));
outbuf += j;
outb -= j;
}
inbuf++; inb--;
goto next_char;
}
if(toRaw) {
if(res != -1 && inb == 0) {
size_t nout = cbuff.bufsize - 1 - outb;
SEXP el = allocVector(RAWSXP, nout);
memcpy(RAW(el), cbuff.data, nout);
SET_VECTOR_ELT(ans, i, el);
} /* otherwise is already NULL */
} else {
if(res != -1 && inb == 0) {
cetype_t ienc = CE_NATIVE;
size_t nout = cbuff.bufsize - 1 - outb;
if(mark) {
if(isLatin1) ienc = CE_LATIN1;
else if(isUTF8) ienc = CE_UTF8;
}
SET_STRING_ELT(ans, i,
mkCharLenCE(cbuff.data, (int) nout, ienc));
} else SET_STRING_ELT(ans, i, NA_STRING);
}
}
Riconv_close(obj);
R_FreeStringBuffer(&cbuff);
}
UNPROTECT(1);
return ans;
}
SEXP attribute_hidden do_cmathfuns(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP x, y = R_NilValue; /* -Wall*/
R_xlen_t i, n;
checkArity(op, args);
check1arg(args, call, "z");
if (DispatchGroup("Complex", call, op, args, env, &x))
return x;
x = CAR(args);
if (isComplex(x)) {
n = XLENGTH(x);
switch(PRIMVAL(op)) {
case 1: /* Re */
y = allocVector(REALSXP, n);
for(i = 0 ; i < n ; i++)
REAL(y)[i] = COMPLEX(x)[i].r;
break;
case 2: /* Im */
y = allocVector(REALSXP, n);
for(i = 0 ; i < n ; i++)
REAL(y)[i] = COMPLEX(x)[i].i;
break;
case 3: /* Mod */
case 6: /* abs */
y = allocVector(REALSXP, n);
for(i = 0 ; i < n ; i++)
#if HAVE_CABS
REAL(y)[i] = cabs(C99_COMPLEX2(x, i));
#else
REAL(y)[i] = hypot(COMPLEX(x)[i].r, COMPLEX(x)[i].i);
#endif
break;
case 4: /* Arg */
y = allocVector(REALSXP, n);
for(i = 0 ; i < n ; i++)
#if HAVE_CARG
REAL(y)[i] = carg(C99_COMPLEX2(x, i));
#else
REAL(y)[i] = atan2(COMPLEX(x)[i].i, COMPLEX(x)[i].r);
#endif
break;
case 5: /* Conj */
y = NO_REFERENCES(x) ? x : allocVector(CPLXSXP, n);
for(i = 0 ; i < n ; i++) {
COMPLEX(y)[i].r = COMPLEX(x)[i].r;
COMPLEX(y)[i].i = -COMPLEX(x)[i].i;
}
break;
}
}
else if(isNumeric(x)) { /* so no complex numbers involved */
n = XLENGTH(x);
if(isReal(x)) PROTECT(x);
else PROTECT(x = coerceVector(x, REALSXP));
y = NO_REFERENCES(x) ? x : allocVector(REALSXP, n);
switch(PRIMVAL(op)) {
case 1: /* Re */
case 5: /* Conj */
for(i = 0 ; i < n ; i++)
REAL(y)[i] = REAL(x)[i];
break;
case 2: /* Im */
for(i = 0 ; i < n ; i++)
REAL(y)[i] = 0.0;
break;
case 4: /* Arg */
for(i = 0 ; i < n ; i++)
if(ISNAN(REAL(x)[i]))
REAL(y)[i] = REAL(x)[i];
else if (REAL(x)[i] >= 0)
REAL(y)[i] = 0;
else
REAL(y)[i] = M_PI;
break;
case 3: /* Mod */
case 6: /* abs */
for(i = 0 ; i < n ; i++)
REAL(y)[i] = fabs(REAL(x)[i]);
break;
}
UNPROTECT(1);
}
else errorcall(call, _("non-numeric argument to function"));
if (x != y && ATTRIB(x) != R_NilValue) {
PROTECT(x);
PROTECT(y);
DUPLICATE_ATTRIB(y, x);
UNPROTECT(2);
}
return y;
}
SEXP DropDims(SEXP x)
{
SEXP dims, dimnames, newnames = R_NilValue;
int i, n, ndims;
PROTECT(x);
dims = getDimAttrib(x);
dimnames = getDimNamesAttrib(x);
/* Check that dropping will actually do something. */
/* (1) Check that there is a "dim" attribute. */
if (dims == R_NilValue) {
UNPROTECT(1);
return x;
}
ndims = LENGTH(dims);
/* (2) Check whether there are redundant extents */
n = 0;
for (i = 0; i < ndims; i++)
if (INTEGER(dims)[i] != 1) n++;
if (n == ndims) {
UNPROTECT(1);
return x;
}
if (n <= 1) {
/* We have reduced to a vector result.
If that has length one, it is ambiguous which dimnames to use,
so use it if there is only one (as from R 2.7.0).
*/
if (dimnames != R_NilValue) {
if(XLENGTH(x) != 1) {
for (i = 0; i < LENGTH(dims); i++) {
if (INTEGER(dims)[i] != 1) {
newnames = VECTOR_ELT(dimnames, i);
break;
}
}
} else { /* drop all dims: keep names if unambiguous */
int cnt;
for(i = 0, cnt = 0; i < LENGTH(dims); i++)
if(VECTOR_ELT(dimnames, i) != R_NilValue) cnt++;
if(cnt == 1)
for (i = 0; i < LENGTH(dims); i++) {
newnames = VECTOR_ELT(dimnames, i);
if(newnames != R_NilValue) break;
}
}
}
PROTECT(newnames);
setAttrib(x, R_DimNamesSymbol, R_NilValue);
setAttrib(x, R_DimSymbol, R_NilValue);
setAttrib(x, R_NamesSymbol, newnames);
/* FIXME: the following is desirable, but pointless as long as
subset.c & others have a contrary version that leaves the
S4 class in, incorrectly, in the case of vectors. JMC
3/3/09 */
/* if(IS_S4_OBJECT(x)) {/\* no longer valid subclass of array or
matrix *\/ */
/* setAttrib(x, R_ClassSymbol, R_NilValue); */
/* UNSET_S4_OBJECT(x); */
/* } */
UNPROTECT(1);
} else {
/* We have a lower dimensional array. */
SEXP newdims, dnn, newnamesnames = R_NilValue;
dnn = getNamesAttrib(dimnames);
PROTECT(newdims = allocVector(INTSXP, n));
for (i = 0, n = 0; i < ndims; i++)
if (INTEGER(dims)[i] != 1)
INTEGER(newdims)[n++] = INTEGER(dims)[i];
if (!isNull(dimnames)) {
int havenames = 0;
for (i = 0; i < ndims; i++)
if (INTEGER(dims)[i] != 1 &&
VECTOR_ELT(dimnames, i) != R_NilValue)
havenames = 1;
if (havenames) {
PROTECT(newnames = allocVector(VECSXP, n));
PROTECT(newnamesnames = allocVector(STRSXP, n));
for (i = 0, n = 0; i < ndims; i++) {
if (INTEGER(dims)[i] != 1) {
if(!isNull(dnn))
SET_STRING_ELT(newnamesnames, n,
STRING_ELT(dnn, i));
SET_VECTOR_ELT(newnames, n++, VECTOR_ELT(dimnames, i));
}
}
}
else dimnames = R_NilValue;
}
PROTECT(dimnames);
setAttrib(x, R_DimNamesSymbol, R_NilValue);
setAttrib(x, R_DimSymbol, newdims);
if (dimnames != R_NilValue)
{
if(!isNull(dnn))
setAttrib(newnames, R_NamesSymbol, newnamesnames);
setAttrib(x, R_DimNamesSymbol, newnames);
UNPROTECT(2);
}
UNPROTECT(2);
}
UNPROTECT(1);
return x;
}