void copyVector(SEXP s, SEXP t)
{
SEXPTYPE sT = TYPEOF(s), tT = TYPEOF(t);
if (sT != tT)
error("vector types do not match in copyVector");
R_xlen_t ns = XLENGTH(s), nt = XLENGTH(t);
switch (sT) {
case STRSXP:
xcopyStringWithRecycle(s, t, 0, ns, nt);
break;
case LGLSXP:
xcopyLogicalWithRecycle(LOGICAL(s), LOGICAL(t), 0, ns, nt);
break;
case INTSXP:
xcopyIntegerWithRecycle(INTEGER(s), INTEGER(t), 0, ns, nt);
break;
case REALSXP:
xcopyRealWithRecycle(REAL(s), REAL(t), 0, ns, nt);
break;
case CPLXSXP:
xcopyComplexWithRecycle(COMPLEX(s), COMPLEX(t), 0, ns, nt);
break;
case EXPRSXP:
case VECSXP:
xcopyVectorWithRecycle(s, t, 0, ns, nt);
break;
case RAWSXP:
xcopyRawWithRecycle(RAW(s), RAW(t), 0, ns, nt);
break;
default:
UNIMPLEMENTED_TYPE("copyVector", s);
}
}
SEXP lazy_duplicate(SEXP s) {
switch (TYPEOF(s)) {
case NILSXP:
case SYMSXP:
case ENVSXP:
case SPECIALSXP:
case BUILTINSXP:
case EXTPTRSXP:
case BCODESXP:
case WEAKREFSXP:
case CHARSXP:
case PROMSXP:
break;
case CLOSXP:
case LISTSXP:
case LANGSXP:
case DOTSXP:
case EXPRSXP:
case VECSXP:
case LGLSXP:
case INTSXP:
case REALSXP:
case CPLXSXP:
case RAWSXP:
case STRSXP:
case S4SXP:
SET_NAMED(s, 2);
break;
default:
UNIMPLEMENTED_TYPE("lazy_duplicate", s);
}
return s;
}
/* EncodeElement is called by cat(), write.table() and deparsing. */
const char *EncodeElement(SEXP x, int indx, int quote, char dec)
{
int w, d, e, wi, di, ei;
const char *res;
switch(TYPEOF(x)) {
case LGLSXP:
formatLogical(&LOGICAL(x)[indx], 1, &w);
res = EncodeLogical(LOGICAL(x)[indx], w);
break;
case INTSXP:
formatInteger(&INTEGER(x)[indx], 1, &w);
res = EncodeInteger(INTEGER(x)[indx], w);
break;
case REALSXP:
formatReal(&REAL(x)[indx], 1, &w, &d, &e, 0);
res = EncodeReal(REAL(x)[indx], w, d, e, dec);
break;
case STRSXP:
formatString(&STRING_PTR(x)[indx], 1, &w, quote);
res = EncodeString(STRING_ELT(x, indx), w, quote, Rprt_adj_left);
break;
case CPLXSXP:
formatComplex(&COMPLEX(x)[indx], 1, &w, &d, &e, &wi, &di, &ei, 0);
res = EncodeComplex(COMPLEX(x)[indx], w, d, e, wi, di, ei, dec);
break;
case RAWSXP:
res = EncodeRaw(RAW(x)[indx]);
break;
default:
res = NULL; /* -Wall */
UNIMPLEMENTED_TYPE("EncodeElement", x);
}
return res;
}
SEXP attribute_hidden do_polyroot(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP z, zr, zi, r, rr, ri;
Rboolean fail;
int degree, i, n;
checkArity(op, args);
z = CAR(args);
switch(TYPEOF(z)) {
case CPLXSXP:
PROTECT(z);
break;
case REALSXP:
case INTSXP:
case LGLSXP:
PROTECT(z = coerceVector(z, CPLXSXP));
break;
default:
UNIMPLEMENTED_TYPE("polyroot", z);
}
#ifdef LONG_VECTOR_SUPPORT
R_xlen_t nn = XLENGTH(z);
if (nn > R_SHORT_LEN_MAX) error("long vectors are not supported");
n = (int) nn;
#else
n = LENGTH(z);
#endif
degree = 0;
for(i = 0; i < n; i++) {
if(COMPLEX(z)[i].r!= 0.0 || COMPLEX(z)[i].i != 0.0) degree = i;
}
n = degree + 1; /* omit trailing zeroes */
if(degree >= 1) {
PROTECT(rr = allocVector(REALSXP, n));
PROTECT(ri = allocVector(REALSXP, n));
PROTECT(zr = allocVector(REALSXP, n));
PROTECT(zi = allocVector(REALSXP, n));
for(i = 0 ; i < n ; i++) {
if(!R_FINITE(COMPLEX(z)[i].r) || !R_FINITE(COMPLEX(z)[i].i))
error(_("invalid polynomial coefficient"));
REAL(zr)[degree-i] = COMPLEX(z)[i].r;
REAL(zi)[degree-i] = COMPLEX(z)[i].i;
}
R_cpolyroot(REAL(zr), REAL(zi), °ree, REAL(rr), REAL(ri), &fail);
if(fail) error(_("root finding code failed"));
UNPROTECT(2);
r = allocVector(CPLXSXP, degree);
for(i = 0 ; i < degree ; i++) {
COMPLEX(r)[i].r = REAL(rr)[i];
COMPLEX(r)[i].i = REAL(ri)[i];
}
UNPROTECT(3);
}
else {
UNPROTECT(1);
r = allocVector(CPLXSXP, 0);
}
return r;
}
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;
}
attribute_hidden
void printMatrix(SEXP x, int offset, SEXP dim, int quote, int right,
SEXP rl, SEXP cl, const char *rn, const char *cn)
{
/* 'rl' and 'cl' are dimnames(.)[[1]] and dimnames(.)[[2]] whereas
* 'rn' and 'cn' are the names(dimnames(.))
*/
const void *vmax = vmaxget();
int r = INTEGER(dim)[0];
int c = INTEGER(dim)[1], r_pr;
/* PR#850 */
if ((rl != R_NilValue) && (r > length(rl)))
error(_("too few row labels"));
if ((cl != R_NilValue) && (c > length(cl)))
error(_("too few column labels"));
if (r == 0 && c == 0) {
Rprintf("<0 x 0 matrix>\n");
return;
}
r_pr = r;
if(c > 0 && R_print.max / c < r) /* avoid integer overflow */
/* using floor(), not ceil(), since 'c' could be huge: */
r_pr = R_print.max / c;
switch (TYPEOF(x)) {
case LGLSXP:
printLogicalMatrix(x, offset, r_pr, r, c, rl, cl, rn, cn);
break;
case INTSXP:
printIntegerMatrix(x, offset, r_pr, r, c, rl, cl, rn, cn);
break;
case REALSXP:
printRealMatrix (x, offset, r_pr, r, c, rl, cl, rn, cn);
break;
case CPLXSXP:
printComplexMatrix(x, offset, r_pr, r, c, rl, cl, rn, cn);
break;
case STRSXP:
if (quote) quote = '"';
printStringMatrix (x, offset, r_pr, r, c, quote, right, rl, cl, rn, cn);
break;
case RAWSXP:
printRawMatrix (x, offset, r_pr, r, c, rl, cl, rn, cn);
break;
default:
UNIMPLEMENTED_TYPE("printMatrix", x);
}
#ifdef ENABLE_NLS
if(r_pr < r) // number of formats must be consistent here
Rprintf(ngettext(" [ reached getOption(\"max.print\") -- omitted %d row ]\n",
" [ reached getOption(\"max.print\") -- omitted %d rows ]\n",
r - r_pr),
r - r_pr);
#else
if(r_pr < r)
Rprintf(" [ reached getOption(\"max.print\") -- omitted %d rows ]\n",
r - r_pr);
#endif
vmaxset(vmax);
}
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);
}
static R_size_t objectsize(SEXP s)
{
R_size_t cnt = 0, vcnt = 0;
SEXP tmp, dup;
Rboolean isVec = FALSE;
switch (TYPEOF(s)) {
case NILSXP:
return(0);
break;
case SYMSXP:
break;
case LISTSXP:
case LANGSXP:
case BCODESXP:
case DOTSXP:
cnt += objectsize(TAG(s));
cnt += objectsize(CAR(s));
cnt += objectsize(CDR(s));
break;
case CLOSXP:
cnt += objectsize(FORMALS(s));
cnt += objectsize(BODY(s));
/* no charge for the environment */
break;
case ENVSXP:
R_CheckStack(); /* in case attributes might lead to a cycle */
case PROMSXP:
case SPECIALSXP:
case BUILTINSXP:
break;
case CHARSXP:
vcnt = BYTE2VEC(length(s)+1);
isVec = TRUE;
break;
case LGLSXP:
case INTSXP:
vcnt = INT2VEC(xlength(s));
isVec = TRUE;
break;
case REALSXP:
vcnt = FLOAT2VEC(xlength(s));
isVec = TRUE;
break;
case CPLXSXP:
vcnt = COMPLEX2VEC(xlength(s));
isVec = TRUE;
break;
case STRSXP:
vcnt = PTR2VEC(xlength(s));
PROTECT(dup = Rf_csduplicated(s));
for (R_xlen_t i = 0; i < xlength(s); i++) {
tmp = STRING_ELT(s, i);
if(tmp != NA_STRING && !LOGICAL(dup)[i])
cnt += objectsize(tmp);
}
isVec = TRUE;
UNPROTECT(1);
break;
case ANYSXP:
/* we don't know about these */
break;
case VECSXP:
case EXPRSXP:
case WEAKREFSXP:
/* Generic Vector Objects */
vcnt = PTR2VEC(xlength(s));
for (R_xlen_t i = 0; i < xlength(s); i++)
cnt += objectsize(VECTOR_ELT(s, i));
isVec = TRUE;
break;
case EXTPTRSXP:
cnt += sizeof(void *); /* the actual pointer */
cnt += objectsize(EXTPTR_PROT(s));
cnt += objectsize(EXTPTR_TAG(s));
break;
case RAWSXP:
vcnt = BYTE2VEC(xlength(s));
isVec = TRUE;
break;
case S4SXP:
/* Has TAG and ATRIB but no CAR nor CDR */
cnt += objectsize(TAG(s));
break;
default:
UNIMPLEMENTED_TYPE("object.size", s);
}
/* add in node space:
we need to take into account the rounding up that goes on
in the node classes. */
if(isVec) {
cnt += sizeof(SEXPREC_ALIGN);
if (vcnt > 16) cnt += 8*vcnt;
else if (vcnt > 8) cnt += 128;
else if (vcnt > 6) cnt += 64;
else if (vcnt > 4) cnt += 48;
else if (vcnt > 2) cnt += 32;
else if (vcnt > 1) cnt += 16;
else if (vcnt > 0) cnt += 8;
} else cnt += sizeof(SEXPREC);
/* add in attributes: these are fake for CHARSXPs */
if(TYPEOF(s) != CHARSXP) cnt += objectsize(ATTRIB(s));
return(cnt);
}
SEXP attribute_hidden do_subset2_dflt(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans, dims, dimnames, indx, subs, x;
int i, ndims, nsubs;
int drop = 1, pok, exact = -1;
int named_x;
R_xlen_t offset = 0;
PROTECT(args);
ExtractDropArg(args, &drop);
/* Is partial matching ok? When the exact arg is NA, a warning is
issued if partial matching occurs.
*/
exact = ExtractExactArg(args);
if (exact == -1)
pok = exact;
else
pok = !exact;
x = CAR(args);
/* This code was intended for compatibility with S, */
/* but in fact S does not do this. Will anyone notice? */
if (x == R_NilValue) {
UNPROTECT(1); /* args */
return x;
}
/* Get the subscripting and dimensioning information */
/* and check that any array subscripting is compatible. */
subs = CDR(args);
if(0 == (nsubs = length(subs)))
errorcall(call, _("no index specified"));
dims = getAttrib(x, R_DimSymbol);
ndims = length(dims);
if(nsubs > 1 && nsubs != ndims)
errorcall(call, _("incorrect number of subscripts"));
/* code to allow classes to extend environment */
if(TYPEOF(x) == S4SXP) {
x = R_getS4DataSlot(x, ANYSXP);
if(x == R_NilValue)
errorcall(call, _("this S4 class is not subsettable"));
}
PROTECT(x);
/* split out ENVSXP for now */
if( TYPEOF(x) == ENVSXP ) {
if( nsubs != 1 || !isString(CAR(subs)) || length(CAR(subs)) != 1 )
errorcall(call, _("wrong arguments for subsetting an environment"));
ans = findVarInFrame(x, installTrChar(STRING_ELT(CAR(subs), 0)));
if( TYPEOF(ans) == PROMSXP ) {
PROTECT(ans);
ans = eval(ans, R_GlobalEnv);
UNPROTECT(1); /* ans */
} else SET_NAMED(ans, 2);
UNPROTECT(2); /* args, x */
if(ans == R_UnboundValue)
return(R_NilValue);
if (NAMED(ans))
SET_NAMED(ans, 2);
return ans;
}
/* back to the regular program */
if (!(isVector(x) || isList(x) || isLanguage(x)))
errorcall(call, R_MSG_ob_nonsub, type2char(TYPEOF(x)));
named_x = NAMED(x); /* x may change below; save this now. See PR#13411 */
if(nsubs == 1) { /* vector indexing */
SEXP thesub = CAR(subs);
int len = length(thesub);
if (len > 1) {
#ifdef SWITCH_TO_REFCNT
if (IS_GETTER_CALL(call)) {
/* this is (most likely) a getter call in a complex
assighment so we duplicate as needed. The original
x should have been duplicated if it might be
shared */
if (MAYBE_SHARED(x))
error("getter call used outside of a complex assignment.");
x = vectorIndex(x, thesub, 0, len-1, pok, call, TRUE);
}
else
x = vectorIndex(x, thesub, 0, len-1, pok, call, FALSE);
#else
x = vectorIndex(x, thesub, 0, len-1, pok, call, FALSE);
#endif
named_x = NAMED(x);
UNPROTECT(1); /* x */
PROTECT(x);
}
SEXP xnames = PROTECT(getAttrib(x, R_NamesSymbol));
offset = get1index(thesub, xnames,
xlength(x), pok, len > 1 ? len-1 : -1, call);
UNPROTECT(1); /* xnames */
if (offset < 0 || offset >= xlength(x)) {
/* a bold attempt to get the same behaviour for $ and [[ */
if (offset < 0 && (isNewList(x) ||
isExpression(x) ||
isList(x) ||
isLanguage(x))) {
UNPROTECT(2); /* args, x */
return R_NilValue;
}
else errorcall(call, R_MSG_subs_o_b);
}
} else { /* matrix indexing */
/* Here we use the fact that: */
/* CAR(R_NilValue) = R_NilValue */
/* CDR(R_NilValue) = R_NilValue */
int ndn; /* Number of dimnames. Unlikely to be anything but
0 or nsubs, but just in case... */
PROTECT(indx = allocVector(INTSXP, nsubs));
dimnames = getAttrib(x, R_DimNamesSymbol);
ndn = length(dimnames);
for (i = 0; i < nsubs; i++) {
INTEGER(indx)[i] = (int)
get1index(CAR(subs),
(i < ndn) ? VECTOR_ELT(dimnames, i) : R_NilValue,
INTEGER(indx)[i], pok, -1, call);
subs = CDR(subs);
if (INTEGER(indx)[i] < 0 ||
INTEGER(indx)[i] >= INTEGER(dims)[i])
errorcall(call, R_MSG_subs_o_b);
}
offset = 0;
for (i = (nsubs - 1); i > 0; i--)
offset = (offset + INTEGER(indx)[i]) * INTEGER(dims)[i - 1];
offset += INTEGER(indx)[0];
UNPROTECT(1); /* indx */
}
if(isPairList(x)) {
#ifdef LONG_VECTOR_SUPPORT
if (offset > R_SHORT_LEN_MAX)
error("invalid subscript for pairlist");
#endif
ans = CAR(nthcdr(x, (int) offset));
if (named_x > NAMED(ans))
SET_NAMED(ans, named_x);
} else if(isVectorList(x)) {
/* did unconditional duplication before 2.4.0 */
ans = VECTOR_ELT(x, offset);
if (named_x > NAMED(ans))
SET_NAMED(ans, named_x);
} else {
ans = allocVector(TYPEOF(x), 1);
switch (TYPEOF(x)) {
case LGLSXP:
case INTSXP:
INTEGER(ans)[0] = INTEGER(x)[offset];
break;
case REALSXP:
REAL(ans)[0] = REAL(x)[offset];
break;
case CPLXSXP:
COMPLEX(ans)[0] = COMPLEX(x)[offset];
break;
case STRSXP:
SET_STRING_ELT(ans, 0, STRING_ELT(x, offset));
break;
case RAWSXP:
RAW(ans)[0] = RAW(x)[offset];
break;
default:
UNIMPLEMENTED_TYPE("do_subset2", x);
}
}
UNPROTECT(2); /* args, x */
return ans;
}
static SEXP rep(SEXP s, SEXP ncopy)
{
int i, ns, na, nc;
SEXP a, t;
if (!isVector(ncopy))
error(_("rep() incorrect type for second argument"));
if (!isVector(s) && (!isList(s)))
error(_("attempt to replicate non-vector"));
if ((length(ncopy) == length(s)))
return rep2(s, ncopy);
if ((length(ncopy) != 1))
error(_("invalid number of copies in rep()"));
if ((nc = asInteger(ncopy)) == NA_INTEGER || nc < 0)/* nc = 0 ok */
error(_("invalid number of copies in rep()"));
ns = length(s);
na = nc * ns;
if (isVector(s))
a = allocVector(TYPEOF(s), na);
else
a = allocList(na);
PROTECT(a);
switch (TYPEOF(s)) {
case LGLSXP:
for (i = 0; i < na; i++)
LOGICAL(a)[i] = LOGICAL(s)[i % ns];
break;
case INTSXP:
for (i = 0; i < na; i++)
INTEGER(a)[i] = INTEGER(s)[i % ns];
break;
case REALSXP:
for (i = 0; i < na; i++)
REAL(a)[i] = REAL(s)[i % ns];
break;
case CPLXSXP:
for (i = 0; i < na; i++)
COMPLEX(a)[i] = COMPLEX(s)[i % ns];
break;
case STRSXP:
for (i = 0; i < na; i++)
SET_STRING_ELT(a, i, STRING_ELT(s, i% ns));
break;
case LISTSXP:
i = 0;
for (t = a; t != R_NilValue; t = CDR(t), i++)
SETCAR(t, duplicate(CAR(nthcdr(s, (i % ns)))));
break;
case VECSXP:
i = 0;
for (i = 0; i < na; i++)
SET_VECTOR_ELT(a, i, duplicate(VECTOR_ELT(s, i% ns)));
break;
case RAWSXP:
for (i = 0; i < na; i++)
RAW(a)[i] = RAW(s)[i % ns];
break;
default:
UNIMPLEMENTED_TYPE("rep", s);
}
if (inherits(s, "factor")) {
SEXP tmp;
if(inherits(s, "ordered")) {
PROTECT(tmp = allocVector(STRSXP, 2));
SET_STRING_ELT(tmp, 0, mkChar("ordered"));
SET_STRING_ELT(tmp, 1, mkChar("factor"));
}
else {
PROTECT(tmp = allocVector(STRSXP, 1));
SET_STRING_ELT(tmp, 0, mkChar("factor"));
}
setAttrib(a, R_ClassSymbol, tmp);
UNPROTECT(1);
setAttrib(a, R_LevelsSymbol, getAttrib(s, R_LevelsSymbol));
}
UNPROTECT(1);
return a;
}
/* It is assumed that type-checking has been done in rep */
static SEXP rep2(SEXP s, SEXP ncopy)
{
int i, na, nc, n, j;
SEXP a, t, u;
t = coerceVector(ncopy, INTSXP);
PROTECT(t);
nc = length(ncopy);
na = 0;
for (i = 0; i < nc; i++) {
if (INTEGER(t)[i] == NA_INTEGER || INTEGER(t)[i]<0)
error(_("invalid number of copies in rep()"));
na += INTEGER(t)[i];
}
if (isVector(s))
a = allocVector(TYPEOF(s), na);
else
a = allocList(na);
PROTECT(a);
n = 0;
switch (TYPEOF(s)) {
case LGLSXP:
for (i = 0; i < nc; i++)
for (j = 0; j < (INTEGER(t)[i]); j++)
LOGICAL(a)[n++] = LOGICAL(s)[i];
break;
case INTSXP:
for (i = 0; i < nc; i++)
for (j = 0; j < (INTEGER(t)[i]); j++)
INTEGER(a)[n++] = INTEGER(s)[i];
break;
case REALSXP:
for (i = 0; i < nc; i++)
for (j = 0; j < (INTEGER(t)[i]); j++)
REAL(a)[n++] = REAL(s)[i];
break;
case CPLXSXP:
for (i = 0; i < nc; i++)
for (j = 0; j < (INTEGER(t)[i]); j++)
COMPLEX(a)[n++] = COMPLEX(s)[i];
break;
case STRSXP:
for (i = 0; i < nc; i++)
for (j = 0; j < (INTEGER(t)[i]); j++)
SET_STRING_ELT(a, n++, STRING_ELT(s, i));
break;
case VECSXP:
case EXPRSXP:
for (i = 0; i < nc; i++)
for (j = 0; j < (INTEGER(t)[i]); j++)
SET_VECTOR_ELT(a, n++, VECTOR_ELT(s, i));
break;
case LISTSXP:
u = a;
for (i = 0; i < nc; i++)
for (j = 0; j < (INTEGER(t)[i]); j++) {
SETCAR(u, duplicate(CAR(nthcdr(s, i))));
u = CDR(u);
}
break;
case RAWSXP:
for (i = 0; i < nc; i++)
for (j = 0; j < (INTEGER(t)[i]); j++)
RAW(a)[n++] = RAW(s)[i];
break;
default:
UNIMPLEMENTED_TYPE("rep2", s);
}
if (inherits(s, "factor")) {
SEXP tmp;
if(inherits(s, "ordered")) {
PROTECT(tmp = allocVector(STRSXP, 2));
SET_STRING_ELT(tmp, 0, mkChar("ordered"));
SET_STRING_ELT(tmp, 1, mkChar("factor"));
}
else {
PROTECT(tmp = allocVector(STRSXP, 1));
SET_STRING_ELT(tmp, 0, mkChar("factor"));
}
setAttrib(a, R_ClassSymbol, tmp);
UNPROTECT(1);
setAttrib(a, R_LevelsSymbol, getAttrib(s, R_LevelsSymbol));
}
UNPROTECT(2);
return a;
}
/* used in connections.c */
SEXP xlengthgets(SEXP x, R_xlen_t len)
{
R_xlen_t lenx, i;
SEXP rval, names, xnames, t;
if (!isVector(x) && !isVectorizable(x))
error(_("cannot set length of non-vector"));
lenx = xlength(x);
if (lenx == len)
return (x);
PROTECT(rval = allocVector(TYPEOF(x), len));
PROTECT(xnames = getAttrib(x, R_NamesSymbol));
if (xnames != R_NilValue)
names = allocVector(STRSXP, len);
else names = R_NilValue; /*- just for -Wall --- should we do this ? */
switch (TYPEOF(x)) {
case NILSXP:
break;
case LGLSXP:
case INTSXP:
for (i = 0; i < len; i++)
if (i < lenx) {
INTEGER(rval)[i] = INTEGER(x)[i];
if (xnames != R_NilValue)
SET_STRING_ELT(names, i, STRING_ELT(xnames, i));
}
else
INTEGER(rval)[i] = NA_INTEGER;
break;
case REALSXP:
for (i = 0; i < len; i++)
if (i < lenx) {
REAL(rval)[i] = REAL(x)[i];
if (xnames != R_NilValue)
SET_STRING_ELT(names, i, STRING_ELT(xnames, i));
}
else
REAL(rval)[i] = NA_REAL;
break;
case CPLXSXP:
for (i = 0; i < len; i++)
if (i < lenx) {
COMPLEX(rval)[i] = COMPLEX(x)[i];
if (xnames != R_NilValue)
SET_STRING_ELT(names, i, STRING_ELT(xnames, i));
}
else {
COMPLEX(rval)[i].r = NA_REAL;
COMPLEX(rval)[i].i = NA_REAL;
}
break;
case STRSXP:
for (i = 0; i < len; i++)
if (i < lenx) {
SET_STRING_ELT(rval, i, STRING_ELT(x, i));
if (xnames != R_NilValue)
SET_STRING_ELT(names, i, STRING_ELT(xnames, i));
}
else
SET_STRING_ELT(rval, i, NA_STRING);
break;
case LISTSXP:
for (t = rval; t != R_NilValue; t = CDR(t), x = CDR(x)) {
SETCAR(t, CAR(x));
SET_TAG(t, TAG(x));
}
case VECSXP:
for (i = 0; i < len; i++)
if (i < lenx) {
SET_VECTOR_ELT(rval, i, VECTOR_ELT(x, i));
if (xnames != R_NilValue)
SET_STRING_ELT(names, i, STRING_ELT(xnames, i));
}
break;
case RAWSXP:
for (i = 0; i < len; i++)
if (i < lenx) {
RAW(rval)[i] = RAW(x)[i];
if (xnames != R_NilValue)
SET_STRING_ELT(names, i, STRING_ELT(xnames, i));
}
else
RAW(rval)[i] = (Rbyte) 0;
break;
default:
UNIMPLEMENTED_TYPE("length<-", x);
}
if (isVector(x) && xnames != R_NilValue)
setAttrib(rval, R_NamesSymbol, names);
UNPROTECT(2);
return rval;
}
/* rep(), allowing for both times and each */
static SEXP rep4(SEXP x, SEXP times, R_xlen_t len, int each, R_xlen_t nt)
{
SEXP a;
R_xlen_t lx = xlength(x);
R_xlen_t i, j, k, k2, k3, sum;
// faster code for common special case
if (each == 1 && nt == 1) return rep3(x, lx, len);
PROTECT(a = allocVector(TYPEOF(x), len));
switch (TYPEOF(x)) {
case LGLSXP:
if(nt == 1)
for(i = 0; i < len; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
LOGICAL(a)[i] = LOGICAL(x)[(i/each) % lx];
}
else {
for(i = 0, k = 0, k2 = 0; i < lx; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
for(j = 0, sum = 0; j < each; j++) sum += INTEGER(times)[k++];
for(k3 = 0; k3 < sum; k3++) {
LOGICAL(a)[k2++] = LOGICAL(x)[i];
if(k2 == len) goto done;
}
}
}
break;
case INTSXP:
if(nt == 1)
for(i = 0; i < len; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
INTEGER(a)[i] = INTEGER(x)[(i/each) % lx];
}
else {
for(i = 0, k = 0, k2 = 0; i < lx; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
for(j = 0, sum = 0; j < each; j++) sum += INTEGER(times)[k++];
for(k3 = 0; k3 < sum; k3++) {
INTEGER(a)[k2++] = INTEGER(x)[i];
if(k2 == len) goto done;
}
}
}
break;
case REALSXP:
if(nt == 1)
for(i = 0; i < len; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
REAL(a)[i] = REAL(x)[(i/each) % lx];
}
else {
for(i = 0, k = 0, k2 = 0; i < lx; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
for(j = 0, sum = 0; j < each; j++) sum += INTEGER(times)[k++];
for(k3 = 0; k3 < sum; k3++) {
REAL(a)[k2++] = REAL(x)[i];
if(k2 == len) goto done;
}
}
}
break;
case CPLXSXP:
if(nt == 1)
for(i = 0; i < len; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
COMPLEX(a)[i] = COMPLEX(x)[(i/each) % lx];
}
else {
for(i = 0, k = 0, k2 = 0; i < lx; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
for(j = 0, sum = 0; j < each; j++) sum += INTEGER(times)[k++];
for(k3 = 0; k3 < sum; k3++) {
COMPLEX(a)[k2++] = COMPLEX(x)[i];
if(k2 == len) goto done;
}
}
}
break;
case STRSXP:
if(nt == 1)
for(i = 0; i < len; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
SET_STRING_ELT(a, i, STRING_ELT(x, (i/each) % lx));
}
else {
for(i = 0, k = 0, k2 = 0; i < lx; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
for(j = 0, sum = 0; j < each; j++) sum += INTEGER(times)[k++];
for(k3 = 0; k3 < sum; k3++) {
SET_STRING_ELT(a, k2++, STRING_ELT(x, i));
if(k2 == len) goto done;
}
}
}
break;
case VECSXP:
case EXPRSXP:
if(nt == 1)
for(i = 0; i < len; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
SET_VECTOR_ELT(a, i, VECTOR_ELT(x, (i/each) % lx));
}
else {
for(i = 0, k = 0, k2 = 0; i < lx; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
for(j = 0, sum = 0; j < each; j++) sum += INTEGER(times)[k++];
for(k3 = 0; k3 < sum; k3++) {
SET_VECTOR_ELT(a, k2++, VECTOR_ELT(x, i));
if(k2 == len) goto done;
}
}
}
break;
case RAWSXP:
if(nt == 1)
for(i = 0; i < len; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
RAW(a)[i] = RAW(x)[(i/each) % lx];
}
else {
for(i = 0, k = 0, k2 = 0; i < lx; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
for(j = 0, sum = 0; j < each; j++) sum += INTEGER(times)[k++];
for(k3 = 0; k3 < sum; k3++) {
RAW(a)[k2++] = RAW(x)[i];
if(k2 == len) goto done;
}
}
}
break;
default:
UNIMPLEMENTED_TYPE("rep4", x);
}
done:
UNPROTECT(1);
return a;
}
/* rep_len(x, len), also used for rep.int() with scalar 'times' */
static SEXP rep3(SEXP s, R_xlen_t ns, R_xlen_t na)
{
R_xlen_t i, j;
SEXP a;
PROTECT(a = allocVector(TYPEOF(s), na));
// i % ns is slow, especially with long R_xlen_t
switch (TYPEOF(s)) {
case LGLSXP:
for (i = 0, j = 0; i < na;) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
if (j >= ns) j = 0;
LOGICAL(a)[i++] = LOGICAL(s)[j++];
}
break;
case INTSXP:
for (i = 0, j = 0; i < na;) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
if (j >= ns) j = 0;
INTEGER(a)[i++] = INTEGER(s)[j++];
}
break;
case REALSXP:
for (i = 0, j = 0; i < na;) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
if (j >= ns) j = 0;
REAL(a)[i++] = REAL(s)[j++];
}
break;
case CPLXSXP:
for (i = 0, j = 0; i < na;) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
if (j >= ns) j = 0;
COMPLEX(a)[i++] = COMPLEX(s)[j++];
}
break;
case RAWSXP:
for (i = 0, j = 0; i < na;) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
if (j >= ns) j = 0;
RAW(a)[i++] = RAW(s)[j++];
}
break;
case STRSXP:
for (i = 0, j = 0; i < na;) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
if (j >= ns) j = 0;
SET_STRING_ELT(a, i++, STRING_ELT(s, j++));
}
break;
case VECSXP:
case EXPRSXP:
for (i = 0, j = 0; i < na;) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
if (j >= ns) j = 0;
SET_VECTOR_ELT(a, i++, lazy_duplicate(VECTOR_ELT(s, j++)));
}
break;
default:
UNIMPLEMENTED_TYPE("rep3", s);
}
UNPROTECT(1);
return a;
}
/* rep.int(x, times) for a vector times */
static SEXP rep2(SEXP s, SEXP ncopy)
{
R_xlen_t i, na, nc, n;
int j;
SEXP a, t;
PROTECT(t = coerceVector(ncopy, INTSXP));
nc = xlength(ncopy);
na = 0;
for (i = 0; i < nc; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
if (INTEGER(t)[i] == NA_INTEGER || INTEGER(t)[i] < 0)
error(_("invalid '%s' value"), "times");
na += INTEGER(t)[i];
}
/* R_xlen_t ni = NINTERRUPT, ratio;
if(nc > 0) {
ratio = na/nc; // average no of replications
if (ratio > 1000U) ni = 1000U;
} */
PROTECT(a = allocVector(TYPEOF(s), na));
n = 0;
switch (TYPEOF(s)) {
case LGLSXP:
for (i = 0; i < nc; i++) {
// if ((i+1) % ni == 0) R_CheckUserInterrupt();
for (j = 0; j < INTEGER(t)[i]; j++)
LOGICAL(a)[n++] = LOGICAL(s)[i];
}
break;
case INTSXP:
for (i = 0; i < nc; i++) {
// if ((i+1) % ni == 0) R_CheckUserInterrupt();
for (j = 0; j < INTEGER(t)[i]; j++)
INTEGER(a)[n++] = INTEGER(s)[i];
}
break;
case REALSXP:
for (i = 0; i < nc; i++) {
// if ((i+1) % ni == 0) R_CheckUserInterrupt();
for (j = 0; j < INTEGER(t)[i]; j++)
REAL(a)[n++] = REAL(s)[i];
}
break;
case CPLXSXP:
for (i = 0; i < nc; i++) {
// if ((i+1) % ni == 0) R_CheckUserInterrupt();
for (j = 0; j < INTEGER(t)[i]; j++)
COMPLEX(a)[n++] = COMPLEX(s)[i];
}
break;
case STRSXP:
for (i = 0; i < nc; i++) {
// if ((i+1) % ni == 0) R_CheckUserInterrupt();
for (j = 0; j < INTEGER(t)[i]; j++)
SET_STRING_ELT(a, n++, STRING_ELT(s, i));
}
break;
case VECSXP:
case EXPRSXP:
for (i = 0; i < nc; i++) {
// if ((i+1) % ni == 0) R_CheckUserInterrupt();
SEXP elt = lazy_duplicate(VECTOR_ELT(s, i));
for (j = 0; j < INTEGER(t)[i]; j++)
SET_VECTOR_ELT(a, n++, elt);
if (j > 1) SET_NAMED(elt, 2);
}
break;
case RAWSXP:
for (i = 0; i < nc; i++) {
// if ((i+1) % ni == 0) R_CheckUserInterrupt();
for (j = 0; j < INTEGER(t)[i]; j++)
RAW(a)[n++] = RAW(s)[i];
}
break;
default:
UNIMPLEMENTED_TYPE("rep2", s);
}
UNPROTECT(2);
return a;
}
SEXP attribute_hidden do_split(/*const*/ CXXR::Expression* call, const CXXR::BuiltInFunction* op, CXXR::Environment* env, CXXR::RObject* const* args, int num_args, const CXXR::PairList* tags)
{
SEXP x, f, counts, vec, nm, nmj;
Rboolean have_names;
op->checkNumArgs(num_args, call);
x = args[0];
f = args[1];
if (!isVector(x))
error(_("first argument must be a vector"));
if (!isFactor(f))
error(_("second argument must be a factor"));
int nlevs = nlevels(f);
R_xlen_t nfac = XLENGTH(args[1]);
R_xlen_t nobs = XLENGTH(args[0]);
if (nfac <= 0 && nobs > 0)
error(_("group length is 0 but data length > 0"));
if (nfac > 0 && (nobs % nfac) != 0)
warning(_("data length is not a multiple of split variable"));
nm = getAttrib(x, R_NamesSymbol);
have_names = CXXRCONSTRUCT(Rboolean, nm != nullptr);
PROTECT(counts = allocVector(INTSXP, nlevs));
for (int i = 0; i < nlevs; i++) INTEGER(counts)[i] = 0;
for (R_xlen_t i = 0; i < nobs; i++) {
int j = INTEGER(f)[i % nfac];
if (j != NA_INTEGER) {
/* protect against malformed factors */
if (j > nlevs || j < 1) error(_("factor has bad level"));
INTEGER(counts)[j - 1]++;
}
}
/* Allocate a generic vector to hold the results. */
/* The i-th element will hold the split-out data */
/* for the ith group. */
PROTECT(vec = allocVector(VECSXP, nlevs));
for (R_xlen_t i = 0; i < nlevs; i++) {
SET_VECTOR_ELT(vec, i, allocVector(TYPEOF(x), INTEGER(counts)[i]));
setAttrib(VECTOR_ELT(vec, i), R_LevelsSymbol,
getAttrib(x, R_LevelsSymbol));
if(have_names)
setAttrib(VECTOR_ELT(vec, i), R_NamesSymbol,
allocVector(STRSXP, INTEGER(counts)[i]));
}
for (int i = 0; i < nlevs; i++) INTEGER(counts)[i] = 0;
for (R_xlen_t i = 0; i < nobs; i++) {
int j = INTEGER(f)[i % nfac];
if (j != NA_INTEGER) {
int k = INTEGER(counts)[j - 1];
switch (TYPEOF(x)) {
case LGLSXP:
case INTSXP:
INTEGER(VECTOR_ELT(vec, j - 1))[k] = INTEGER(x)[i];
break;
case REALSXP:
REAL(VECTOR_ELT(vec, j - 1))[k] = REAL(x)[i];
break;
case CPLXSXP:
COMPLEX(VECTOR_ELT(vec, j - 1))[k] = COMPLEX(x)[i];
break;
case STRSXP:
SET_STRING_ELT(VECTOR_ELT(vec, j - 1), k, STRING_ELT(x, i));
break;
case VECSXP:
SET_VECTOR_ELT(VECTOR_ELT(vec, j - 1), k, VECTOR_ELT(x, i));
break;
case RAWSXP:
RAW(VECTOR_ELT(vec, j - 1))[k] = RAW(x)[i];
break;
default:
UNIMPLEMENTED_TYPE("split", x);
}
if(have_names) {
nmj = getAttrib(VECTOR_ELT(vec, j - 1), R_NamesSymbol);
SET_STRING_ELT(nmj, k, STRING_ELT(nm, i));
}
INTEGER(counts)[j - 1] += 1;
}
}
setAttrib(vec, R_NamesSymbol, getAttrib(f, R_LevelsSymbol));
UNPROTECT(2);
return vec;
}
static void extractItem(char *buffer, SEXP ans, int i, LocalData *d)
{
char *endp;
switch(TYPEOF(ans)) {
case NILSXP:
break;
case LGLSXP:
if (isNAstring(buffer, 0, d))
LOGICAL(ans)[i] = NA_INTEGER;
else {
int tr = StringTrue(buffer), fa = StringFalse(buffer);
if(tr || fa) LOGICAL(ans)[i] = tr;
else expected("a logical", buffer, d);
}
break;
case INTSXP:
if (isNAstring(buffer, 0, d))
INTEGER(ans)[i] = NA_INTEGER;
else {
INTEGER(ans)[i] = Strtoi(buffer, 10);
if (INTEGER(ans)[i] == NA_INTEGER)
expected("an integer", buffer, d);
}
break;
case REALSXP:
if (isNAstring(buffer, 0, d))
REAL(ans)[i] = NA_REAL;
else {
REAL(ans)[i] = Strtod(buffer, &endp, TRUE, d);
if (!isBlankString(endp))
expected("a real", buffer, d);
}
break;
case CPLXSXP:
if (isNAstring(buffer, 0, d))
COMPLEX(ans)[i].r = COMPLEX(ans)[i].i = NA_REAL;
else {
COMPLEX(ans)[i] = strtoc(buffer, &endp, TRUE, d);
if (!isBlankString(endp))
expected("a complex", buffer, d);
}
break;
case STRSXP:
if (isNAstring(buffer, 1, d))
SET_STRING_ELT(ans, i, NA_STRING);
else
SET_STRING_ELT(ans, i, insertString(buffer, d));
break;
case RAWSXP:
if (isNAstring(buffer, 0, d))
RAW(ans)[i] = 0;
else {
RAW(ans)[i] = strtoraw(buffer, &endp);
if (!isBlankString(endp))
expected("a raw", buffer, d);
}
break;
default:
UNIMPLEMENTED_TYPE("extractItem", ans);
}
}
static SEXP duplicate1(SEXP s, Rboolean deep)
{
SEXP t;
R_xlen_t i, n;
duplicate1_elts++;
duplicate_elts++;
switch (TYPEOF(s)) {
case NILSXP:
case SYMSXP:
case ENVSXP:
case SPECIALSXP:
case BUILTINSXP:
case EXTPTRSXP:
case BCODESXP:
case WEAKREFSXP:
return s;
case CLOSXP:
PROTECT(s);
PROTECT(t = allocSExp(CLOSXP));
SET_FORMALS(t, FORMALS(s));
SET_BODY(t, BODY(s));
SET_CLOENV(t, CLOENV(s));
DUPLICATE_ATTRIB(t, s, deep);
if (NOJIT(s)) SET_NOJIT(t);
if (MAYBEJIT(s)) SET_MAYBEJIT(t);
UNPROTECT(2);
break;
case LISTSXP:
PROTECT(s);
t = duplicate_list(s, deep);
UNPROTECT(1);
break;
case LANGSXP:
PROTECT(s);
PROTECT(t = duplicate_list(s, deep));
SET_TYPEOF(t, LANGSXP);
DUPLICATE_ATTRIB(t, s, deep);
UNPROTECT(2);
break;
case DOTSXP:
PROTECT(s);
PROTECT(t = duplicate_list(s, deep));
SET_TYPEOF(t, DOTSXP);
DUPLICATE_ATTRIB(t, s, deep);
UNPROTECT(2);
break;
case CHARSXP:
return s;
break;
case EXPRSXP:
case VECSXP:
n = XLENGTH(s);
PROTECT(s);
PROTECT(t = allocVector(TYPEOF(s), n));
for(i = 0 ; i < n ; i++)
SET_VECTOR_ELT(t, i, duplicate_child(VECTOR_ELT(s, i), deep));
DUPLICATE_ATTRIB(t, s, deep);
COPY_TRUELENGTH(t, s);
UNPROTECT(2);
break;
case LGLSXP: DUPLICATE_ATOMIC_VECTOR(int, LOGICAL, t, s, deep); break;
case INTSXP: DUPLICATE_ATOMIC_VECTOR(int, INTEGER, t, s, deep); break;
case REALSXP: DUPLICATE_ATOMIC_VECTOR(double, REAL, t, s, deep); break;
case CPLXSXP: DUPLICATE_ATOMIC_VECTOR(Rcomplex, COMPLEX, t, s, deep); break;
case RAWSXP: DUPLICATE_ATOMIC_VECTOR(Rbyte, RAW, t, s, deep); break;
case STRSXP:
/* direct copying and bypassing the write barrier is OK since
t was just allocated and so it cannot be older than any of
the elements in s. LT */
DUPLICATE_ATOMIC_VECTOR(SEXP, STRING_PTR, t, s, deep);
break;
case PROMSXP:
return s;
break;
case S4SXP:
PROTECT(s);
PROTECT(t = allocS4Object());
DUPLICATE_ATTRIB(t, s, deep);
UNPROTECT(2);
break;
default:
UNIMPLEMENTED_TYPE("duplicate", s);
t = s;/* for -Wall */
}
if(TYPEOF(t) == TYPEOF(s) ) { /* surely it only makes sense in this case*/
SET_OBJECT(t, OBJECT(s));
(IS_S4_OBJECT(s) ? SET_S4_OBJECT(t) : UNSET_S4_OBJECT(t));
}
return t;
}
SEXP writetable(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP x, sep, rnames, eol, na, dec, quote, xj;
int nr, nc, i, j, qmethod;
Rboolean wasopen, quote_rn = FALSE, *quote_col;
Rconnection con;
const char *csep, *ceol, *cna, *sdec, *tmp=NULL /* -Wall */;
char cdec;
SEXP *levels;
R_StringBuffer strBuf = {NULL, 0, MAXELTSIZE};
wt_info wi;
RCNTXT cntxt;
args = CDR(args);
x = CAR(args); args = CDR(args);
/* this is going to be a connection open or openable for writing */
if(!inherits(CAR(args), "connection"))
error(_("'file' is not a connection"));
con = getConnection(asInteger(CAR(args))); args = CDR(args);
if(!con->canwrite)
error(_("cannot write to this connection"));
wasopen = con->isopen;
if(!wasopen) {
strcpy(con->mode, "wt");
if(!con->open(con)) error(_("cannot open the connection"));
}
nr = asInteger(CAR(args)); args = CDR(args);
nc = asInteger(CAR(args)); args = CDR(args);
rnames = CAR(args); args = CDR(args);
sep = CAR(args); args = CDR(args);
eol = CAR(args); args = CDR(args);
na = CAR(args); args = CDR(args);
dec = CAR(args); args = CDR(args);
quote = CAR(args); args = CDR(args);
qmethod = asLogical(CAR(args));
if(nr == NA_INTEGER) error(_("invalid '%s' argument"), "nr");
if(nc == NA_INTEGER) error(_("invalid '%s' argument"), "nc");
if(!isNull(rnames) && !isString(rnames))
error(_("invalid '%s' argument"), "rnames");
if(!isString(sep)) error(_("invalid '%s' argument"), "sep");
if(!isString(eol)) error(_("invalid '%s' argument"), "eol");
if(!isString(na)) error(_("invalid '%s' argument"), "na");
if(!isString(dec)) error(_("invalid '%s' argument"), "dec");
if(qmethod == NA_LOGICAL) error(_("invalid '%s' argument"), "qmethod");
csep = translateChar(STRING_ELT(sep, 0));
ceol = translateChar(STRING_ELT(eol, 0));
cna = translateChar(STRING_ELT(na, 0));
sdec = translateChar(STRING_ELT(dec, 0));
if(strlen(sdec) != 1)
error(_("'dec' must be a single character"));
cdec = sdec[0];
quote_col = (Rboolean *) R_alloc(nc, sizeof(Rboolean));
for(j = 0; j < nc; j++) quote_col[j] = FALSE;
for(i = 0; i < length(quote); i++) { /* NB, quote might be NULL */
int this = INTEGER(quote)[i];
if(this == 0) quote_rn = TRUE;
if(this > 0) quote_col[this - 1] = TRUE;
}
R_AllocStringBuffer(0, &strBuf);
PrintDefaults();
wi.savedigits = R_print.digits; R_print.digits = DBL_DIG;/* MAX precision */
wi.con = con;
wi.wasopen = wasopen;
wi.buf = &strBuf;
begincontext(&cntxt, CTXT_CCODE, call, R_BaseEnv, R_BaseEnv,
R_NilValue, R_NilValue);
cntxt.cend = &wt_cleanup;
cntxt.cenddata = &wi;
if(isVectorList(x)) { /* A data frame */
/* handle factors internally, check integrity */
levels = (SEXP *) R_alloc(nc, sizeof(SEXP));
for(j = 0; j < nc; j++) {
xj = VECTOR_ELT(x, j);
if(LENGTH(xj) != nr)
error(_("corrupt data frame -- length of column %d does not not match nrows"), j+1);
if(inherits(xj, "factor")) {
levels[j] = getAttrib(xj, R_LevelsSymbol);
} else levels[j] = R_NilValue;
}
for(i = 0; i < nr; i++) {
if(i % 1000 == 999) R_CheckUserInterrupt();
if(!isNull(rnames))
Rconn_printf(con, "%s%s",
EncodeElement2(rnames, i, quote_rn, qmethod,
&strBuf, cdec), csep);
for(j = 0; j < nc; j++) {
xj = VECTOR_ELT(x, j);
if(j > 0) Rconn_printf(con, "%s", csep);
if(isna(xj, i)) tmp = cna;
else {
if(!isNull(levels[j])) {
/* We do not assume factors have integer levels,
although they should. */
if(TYPEOF(xj) == INTSXP)
tmp = EncodeElement2(levels[j], INTEGER(xj)[i] - 1,
quote_col[j], qmethod,
&strBuf, cdec);
else if(TYPEOF(xj) == REALSXP)
tmp = EncodeElement2(levels[j],
(int) (REAL(xj)[i] - 1),
quote_col[j], qmethod,
&strBuf, cdec);
else
error("column %s claims to be a factor but does not have numeric codes", j+1);
} else {
tmp = EncodeElement2(xj, i, quote_col[j], qmethod,
&strBuf, cdec);
}
/* if(cdec) change_dec(tmp, cdec, TYPEOF(xj)); */
}
Rconn_printf(con, "%s", tmp);
}
Rconn_printf(con, "%s", ceol);
}
} else { /* A matrix */
if(!isVectorAtomic(x))
UNIMPLEMENTED_TYPE("write.table, matrix method", x);
/* quick integrity check */
if(LENGTH(x) != nr * nc)
error(_("corrupt matrix -- dims not not match length"));
for(i = 0; i < nr; i++) {
if(i % 1000 == 999) R_CheckUserInterrupt();
if(!isNull(rnames))
Rconn_printf(con, "%s%s",
EncodeElement2(rnames, i, quote_rn, qmethod,
&strBuf, cdec), csep);
for(j = 0; j < nc; j++) {
if(j > 0) Rconn_printf(con, "%s", csep);
if(isna(x, i + j*nr)) tmp = cna;
else {
tmp = EncodeElement2(x, i + j*nr, quote_col[j], qmethod,
&strBuf, cdec);
/* if(cdec) change_dec(tmp, cdec, TYPEOF(x)); */
}
Rconn_printf(con, "%s", tmp);
}
Rconn_printf(con, "%s", ceol);
}
}
endcontext(&cntxt);
wt_cleanup(&wi);
return R_NilValue;
}
