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; }