/* 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;
}
static void printComplexMatrix(SEXP sx, int offset, int r_pr, int r, int c,
SEXP rl, SEXP cl, const char *rn, const char *cn)
{
_PRINT_INIT_rl_rn;
Rcomplex *x = COMPLEX(sx) + offset;
int *dr = (int *) R_alloc(c, sizeof(int)),
*er = (int *) R_alloc(c, sizeof(int)),
*wr = (int *) R_alloc(c, sizeof(int)),
*di = (int *) R_alloc(c, sizeof(int)),
*ei = (int *) R_alloc(c, sizeof(int)),
*wi = (int *) R_alloc(c, sizeof(int));
/* Determine the column widths */
for (j = 0; j < c; j++) {
formatComplex(&x[j * r], (R_xlen_t) r,
&wr[j], &dr[j], &er[j],
&wi[j], &di[j], &ei[j], 0);
_PRINT_SET_clabw;
w[j] = wr[j] + wi[j] + 2;
if (w[j] < clabw)
w[j] = clabw;
w[j] += R_print.gap;
}
_PRINT_DEAL_c_eq_0;
while (jmin < c) {
width = rlabw;
do {
width += w[jmax];
jmax++;
}
while (jmax < c && width + w[jmax] < R_print.width);
_PRINT_ROW_LAB;
for (j = jmin; j < jmax ; j++)
MatrixColumnLabel(cl, j, w[j]);
for (i = 0; i < r_pr; i++) {
MatrixRowLabel(rl, i, rlabw, lbloff);
for (j = jmin; j < jmax; j++) {
if (ISNA(x[i + j * r].r) || ISNA(x[i + j * r].i))
Rprintf("%s", EncodeReal(NA_REAL, w[j], 0, 0, OutDec));
else
Rprintf("%s",
EncodeComplex(x[i + j * r],
wr[j] + R_print.gap, dr[j], er[j],
wi[j], di[j], ei[j], OutDec));
}
}
Rprintf("\n");
jmin = jmax;
}
}
void printComplexVector(Rcomplex *x, int n, int indx)
{
int i, w, wr, dr, er, wi, di, ei, labwidth=0, width;
DO_first_lab;
formatComplex(x, n, &wr, &dr, &er, &wi, &di, &ei, 0);
w = wr + wi + 2; /* +2 for "+" and "i" */
w += R_print.gap;
for (i = 0; i < n; i++) {
if (i > 0 && width + w > R_print.width) {
DO_newline;
}
if (ISNA(x[i].r) || ISNA(x[i].i))
Rprintf("%s", EncodeReal(NA_REAL, w, 0, 0, OutDec));
else
Rprintf("%s", EncodeComplex(x[i], wr + R_print.gap , dr, er,
wi, di, ei, OutDec));
width += w;
}
Rprintf("\n");
}
static void PrintGenericVector(SEXP s, SEXP env)
{
int i, taglen, ns, w, d, e, wr, dr, er, wi, di, ei;
SEXP dims, t, names, newcall, tmp;
char pbuf[115], *ptag, save[TAGBUFLEN0];
ns = length(s);
if((dims = getAttrib(s, R_DimSymbol)) != R_NilValue && length(dims) > 1) {
// special case: array-like list
PROTECT(dims);
PROTECT(t = allocArray(STRSXP, dims));
/* FIXME: check (ns <= R_print.max +1) ? ns : R_print.max; */
for (i = 0; i < ns; i++) {
switch(TYPEOF(PROTECT(tmp = VECTOR_ELT(s, i)))) {
case NILSXP:
snprintf(pbuf, 115, "NULL");
break;
case LGLSXP:
if (LENGTH(tmp) == 1) {
const int *x = LOGICAL_RO(tmp);
formatLogical(x, 1, &w);
snprintf(pbuf, 115, "%s",
EncodeLogical(x[0], w));
} else
snprintf(pbuf, 115, "Logical,%d", LENGTH(tmp));
break;
case INTSXP:
/* factors are stored as integers */
if (inherits(tmp, "factor")) {
snprintf(pbuf, 115, "factor,%d", LENGTH(tmp));
} else {
if (LENGTH(tmp) == 1) {
const int *x = INTEGER_RO(tmp);
formatInteger(x, 1, &w);
snprintf(pbuf, 115, "%s",
EncodeInteger(x[0], w));
} else
snprintf(pbuf, 115, "Integer,%d", LENGTH(tmp));
}
break;
case REALSXP:
if (LENGTH(tmp) == 1) {
const double *x = REAL_RO(tmp);
formatReal(x, 1, &w, &d, &e, 0);
snprintf(pbuf, 115, "%s",
EncodeReal0(x[0], w, d, e, OutDec));
} else
snprintf(pbuf, 115, "Numeric,%d", LENGTH(tmp));
break;
case CPLXSXP:
if (LENGTH(tmp) == 1) {
const Rcomplex *x = COMPLEX_RO(tmp);
if (ISNA(x[0].r) || ISNA(x[0].i))
/* formatReal(NA) --> w=R_print.na_width, d=0, e=0 */
snprintf(pbuf, 115, "%s",
EncodeReal0(NA_REAL, R_print.na_width, 0, 0, OutDec));
else {
formatComplex(x, 1, &wr, &dr, &er, &wi, &di, &ei, 0);
snprintf(pbuf, 115, "%s",
EncodeComplex(x[0],
wr, dr, er, wi, di, ei, OutDec));
}
} else
snprintf(pbuf, 115, "Complex,%d", LENGTH(tmp));
break;
case STRSXP:
if (LENGTH(tmp) == 1) {
const void *vmax = vmaxget();
/* This can potentially overflow */
const char *ctmp = translateChar(STRING_ELT(tmp, 0));
int len = (int) strlen(ctmp);
if(len < 100)
snprintf(pbuf, 115, "\"%s\"", ctmp);
else {
snprintf(pbuf, 101, "\"%s\"", ctmp);
pbuf[100] = '"'; pbuf[101] = '\0';
strcat(pbuf, " [truncated]");
}
vmaxset(vmax);
} else
snprintf(pbuf, 115, "Character,%d", LENGTH(tmp));
break;
case RAWSXP:
snprintf(pbuf, 115, "Raw,%d", LENGTH(tmp));
break;
case LISTSXP:
case VECSXP:
snprintf(pbuf, 115, "List,%d", length(tmp));
break;
case LANGSXP:
snprintf(pbuf, 115, "Expression");
break;
default:
snprintf(pbuf, 115, "?");
break;
}
UNPROTECT(1); /* tmp */
pbuf[114] = '\0';
SET_STRING_ELT(t, i, mkChar(pbuf));
}
if (LENGTH(dims) == 2) {
SEXP rl, cl;
const char *rn, *cn;
GetMatrixDimnames(s, &rl, &cl, &rn, &cn);
/* as from 1.5.0: don't quote here as didn't in array case */
printMatrix(t, 0, dims, 0, R_print.right, rl, cl,
rn, cn);
}
else {
PROTECT(names = GetArrayDimnames(s));
printArray(t, dims, 0, Rprt_adj_left, names);
UNPROTECT(1);
}
UNPROTECT(2);
}
else { // no dim()
PROTECT(names = getAttrib(s, R_NamesSymbol));
taglen = (int) strlen(tagbuf);
ptag = tagbuf + taglen;
PROTECT(newcall = allocList(2));
SETCAR(newcall, install("print"));
SET_TYPEOF(newcall, LANGSXP);
if(ns > 0) {
int n_pr = (ns <= R_print.max +1) ? ns : R_print.max;
/* '...max +1' ==> will omit at least 2 ==> plural in msg below */
for (i = 0; i < n_pr; i++) {
if (i > 0) Rprintf("\n");
if (names != R_NilValue &&
STRING_ELT(names, i) != R_NilValue &&
*CHAR(STRING_ELT(names, i)) != '\0') {
const void *vmax = vmaxget();
/* Bug for L <- list(`a\\b` = 1, `a\\c` = 2) :
const char *ss = translateChar(STRING_ELT(names, i));
*/
const char *ss = EncodeChar(STRING_ELT(names, i));
#ifdef Win32
/* FIXME: double translation to native encoding, in
EncodeChar and translateChar; it is however necessary
to call isValidName() on a string without Rgui
escapes, because Rgui escapes cause a name to be
regarded invalid;
note also differences with printList
*/
const char *st = ss;
if (WinUTF8out)
st = translateChar(STRING_ELT(names, i));
#endif
if (taglen + strlen(ss) > TAGBUFLEN) {
if (taglen <= TAGBUFLEN)
sprintf(ptag, "$...");
} else {
/* we need to distinguish character NA from "NA", which
is a valid (if non-syntactic) name */
if (STRING_ELT(names, i) == NA_STRING)
sprintf(ptag, "$<NA>");
#ifdef Win32
else if( isValidName(st) )
#else
else if( isValidName(ss) )
#endif
sprintf(ptag, "$%s", ss);
else
sprintf(ptag, "$`%s`", ss);
}
vmaxset(vmax);
}
else {
if (taglen + IndexWidth(i) > TAGBUFLEN) {
if (taglen <= TAGBUFLEN)
sprintf(ptag, "$...");
} else
sprintf(ptag, "[[%d]]", i+1);
}
Rprintf("%s\n", tagbuf);
if(isObject(VECTOR_ELT(s, i))) {
SEXP x = VECTOR_ELT(s, i);
int nprot = 0;
if (TYPEOF(x) == LANGSXP) {
// quote(x) to not accidentally evaluate it with newcall() below:
x = PROTECT(lang2(R_Primitive("quote"), x)); nprot++;
}
/* need to preserve tagbuf */
strcpy(save, tagbuf);
SETCADR(newcall, x);
eval(newcall, env);
strcpy(tagbuf, save);
UNPROTECT(nprot);
}
else PrintValueRec(VECTOR_ELT(s, i), env);
*ptag = '\0';
}
Rprintf("\n");
if(n_pr < ns)
Rprintf(" [ reached getOption(\"max.print\") -- omitted %d entries ]\n",
ns - n_pr);
}
/* format.default(x, trim, digits, nsmall, width, justify, na.encode,
scientific) */
SEXP attribute_hidden do_format(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP l, x, y, swd;
int il, digits, trim = 0, nsmall = 0, wd = 0, adj = -1, na, sci = 0;
int w, d, e;
int wi, di, ei, scikeep;
const char *strp;
R_xlen_t i, n;
checkArity(op, args);
PrintDefaults();
scikeep = R_print.scipen;
if (isEnvironment(x = CAR(args))) {
return mkString(EncodeEnvironment(x));
}
else if (!isVector(x))
error(_("first argument must be atomic"));
args = CDR(args);
trim = asLogical(CAR(args));
if (trim == NA_INTEGER)
error(_("invalid '%s' argument"), "trim");
args = CDR(args);
if (!isNull(CAR(args))) {
digits = asInteger(CAR(args));
if (digits == NA_INTEGER || digits < R_MIN_DIGITS_OPT
|| digits > R_MAX_DIGITS_OPT)
error(_("invalid '%s' argument"), "digits");
R_print.digits = digits;
}
args = CDR(args);
nsmall = asInteger(CAR(args));
if (nsmall == NA_INTEGER || nsmall < 0 || nsmall > 20)
error(_("invalid '%s' argument"), "nsmall");
args = CDR(args);
if (isNull(swd = CAR(args))) wd = 0; else wd = asInteger(swd);
if(wd == NA_INTEGER)
error(_("invalid '%s' argument"), "width");
args = CDR(args);
adj = asInteger(CAR(args));
if(adj == NA_INTEGER || adj < 0 || adj > 3)
error(_("invalid '%s' argument"), "justify");
args = CDR(args);
na = asLogical(CAR(args));
if(na == NA_LOGICAL)
error(_("invalid '%s' argument"), "na.encode");
args = CDR(args);
if(LENGTH(CAR(args)) != 1)
error(_("invalid '%s' argument"), "scientific");
if(isLogical(CAR(args))) {
int tmp = LOGICAL(CAR(args))[0];
if(tmp == NA_LOGICAL) sci = NA_INTEGER;
else sci = tmp > 0 ?-100 : 100;
} else if (isNumeric(CAR(args))) {
sci = asInteger(CAR(args));
} else
error(_("invalid '%s' argument"), "scientific");
if(sci != NA_INTEGER) R_print.scipen = sci;
if ((n = XLENGTH(x)) <= 0) {
PROTECT(y = allocVector(STRSXP, 0));
} else {
switch (TYPEOF(x)) {
case LGLSXP:
PROTECT(y = allocVector(STRSXP, n));
if (trim) w = 0; else formatLogical(LOGICAL(x), n, &w);
w = imax2(w, wd);
for (i = 0; i < n; i++) {
strp = EncodeLogical(LOGICAL(x)[i], w);
SET_STRING_ELT(y, i, mkChar(strp));
}
break;
case INTSXP:
PROTECT(y = allocVector(STRSXP, n));
if (trim) w = 0;
else formatInteger(INTEGER(x), n, &w);
w = imax2(w, wd);
for (i = 0; i < n; i++) {
strp = EncodeInteger(INTEGER(x)[i], w);
SET_STRING_ELT(y, i, mkChar(strp));
}
break;
case REALSXP:
formatReal(REAL(x), n, &w, &d, &e, nsmall);
if (trim) w = 0;
w = imax2(w, wd);
PROTECT(y = allocVector(STRSXP, n));
for (i = 0; i < n; i++) {
strp = EncodeReal0(REAL(x)[i], w, d, e, OutDec);
SET_STRING_ELT(y, i, mkChar(strp));
}
break;
case CPLXSXP:
formatComplex(COMPLEX(x), n, &w, &d, &e, &wi, &di, &ei, nsmall);
if (trim) wi = w = 0;
w = imax2(w, wd); wi = imax2(wi, wd);
PROTECT(y = allocVector(STRSXP, n));
for (i = 0; i < n; i++) {
strp = EncodeComplex(COMPLEX(x)[i], w, d, e, wi, di, ei, OutDec);
SET_STRING_ELT(y, i, mkChar(strp));
}
break;
case STRSXP:
{
/* this has to be different from formatString/EncodeString as
we don't actually want to encode here */
const char *s;
char *q;
int b, b0, cnt = 0, j;
SEXP s0, xx;
/* This is clumsy, but it saves rewriting and re-testing
this complex code */
PROTECT(xx = duplicate(x));
for (i = 0; i < n; i++) {
SEXP tmp = STRING_ELT(xx, i);
if(IS_BYTES(tmp)) {
const char *p = CHAR(tmp), *q;
char *pp = R_alloc(4*strlen(p)+1, 1), *qq = pp, buf[5];
for (q = p; *q; q++) {
unsigned char k = (unsigned char) *q;
if (k >= 0x20 && k < 0x80) {
*qq++ = *q;
} else {
snprintf(buf, 5, "\\x%02x", k);
for(int j = 0; j < 4; j++) *qq++ = buf[j];
}
}
*qq = '\0';
s = pp;
} else s = translateChar(tmp);
if(s != CHAR(tmp)) SET_STRING_ELT(xx, i, mkChar(s));
}
w = wd;
if (adj != Rprt_adj_none) {
for (i = 0; i < n; i++)
if (STRING_ELT(xx, i) != NA_STRING)
w = imax2(w, Rstrlen(STRING_ELT(xx, i), 0));
else if (na) w = imax2(w, R_print.na_width);
} else w = 0;
/* now calculate the buffer size needed, in bytes */
for (i = 0; i < n; i++)
if (STRING_ELT(xx, i) != NA_STRING) {
il = Rstrlen(STRING_ELT(xx, i), 0);
cnt = imax2(cnt, LENGTH(STRING_ELT(xx, i)) + imax2(0, w-il));
} else if (na) cnt = imax2(cnt, R_print.na_width + imax2(0, w-R_print.na_width));
R_CheckStack2(cnt+1);
char buff[cnt+1];
PROTECT(y = allocVector(STRSXP, n));
for (i = 0; i < n; i++) {
if(!na && STRING_ELT(xx, i) == NA_STRING) {
SET_STRING_ELT(y, i, NA_STRING);
} else {
q = buff;
if(STRING_ELT(xx, i) == NA_STRING) s0 = R_print.na_string;
else s0 = STRING_ELT(xx, i) ;
s = CHAR(s0);
il = Rstrlen(s0, 0);
b = w - il;
if(b > 0 && adj != Rprt_adj_left) {
b0 = (adj == Rprt_adj_centre) ? b/2 : b;
for(j = 0 ; j < b0 ; j++) *q++ = ' ';
b -= b0;
}
for(j = 0; j < LENGTH(s0); j++) *q++ = *s++;
if(b > 0 && adj != Rprt_adj_right)
for(j = 0 ; j < b ; j++) *q++ = ' ';
*q = '\0';
SET_STRING_ELT(y, i, mkChar(buff));
}
}
}
UNPROTECT(2); /* xx , y */
PROTECT(y);
break;
default:
error(_("Impossible mode ( x )")); y = R_NilValue;/* -Wall */
}
}
if((l = getAttrib(x, R_DimSymbol)) != R_NilValue) {
setAttrib(y, R_DimSymbol, l);
if((l = getAttrib(x, R_DimNamesSymbol)) != R_NilValue)
setAttrib(y, R_DimNamesSymbol, l);
} else if((l = getAttrib(x, R_NamesSymbol)) != R_NilValue)
setAttrib(y, R_NamesSymbol, l);
/* In case something else forgets to set PrintDefaults(), PR#14477 */
R_print.scipen = scikeep;
UNPROTECT(1); /* y */
return y;
}