const char
*EncodeComplex(Rcomplex x, int wr, int dr, int er, int wi, int di, int ei,
const char *dec)
{
static char buff[NB];
/* IEEE allows signed zeros; strip these here */
if (x.r == 0.0) x.r = 0.0;
if (x.i == 0.0) x.i = 0.0;
if (ISNA(x.r) || ISNA(x.i)) {
snprintf(buff, NB,
"%*s", /* was "%*s%*s", R_print.gap, "", */
min(wr+wi+2, (NB-1)), CHAR(R_print.na_string));
} else {
char Re[NB];
const char *Im, *tmp;
int flagNegIm = 0;
Rcomplex y;
/* formatComplex rounded, but this does not, and we need to
keep it that way so we don't get strange trailing zeros.
But we do want to avoid printing small exponentials that
are probably garbage.
*/
z_prec_r(&y, &x, R_print.digits);
/* EncodeReal has static buffer, so copy */
tmp = EncodeReal0(y.r == 0. ? y.r : x.r, wr, dr, er, dec);
strcpy(Re, tmp);
if ( (flagNegIm = (x.i < 0)) ) x.i = -x.i;
Im = EncodeReal0(y.i == 0. ? y.i : x.i, wi, di, ei, dec);
snprintf(buff, NB, "%s%s%si", Re, flagNegIm ? "-" : "+", Im);
}
buff[NB-1] = '\0';
return buff;
}
const char *EncodeElement0(SEXP x, int indx, int quote, const 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 = EncodeReal0(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;
}
// used in uncmin.c
attribute_hidden
void printRealVector(double *x, R_xlen_t n, int indx)
{
int w, d, e, labwidth=0, width;
DO_first_lab;
formatReal(x, n, &w, &d, &e, 0);
w += R_print.gap;
for (R_xlen_t i = 0; i < n; i++) {
if (i > 0 && width + w > R_print.width) {
DO_newline;
}
Rprintf("%s", EncodeReal0(x[i], w, d, e, OutDec));
width += w;
}
Rprintf("\n");
}
attribute_hidden
void printComplexVector(Rcomplex *x, R_xlen_t n, int indx)
{
int 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 (R_xlen_t 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", EncodeReal0(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");
}
const char *EncodeReal(double x, int w, int d, int e, char cdec)
{
char dec[2];
dec[0] = cdec; dec[1] = '\0';
return EncodeReal0(x, w, d, e, dec);
}
static void printNamedLogicalVector(int * x, int n, SEXP * names)
PRINT_N_VECTOR(formatLogical(x, n, &w),
Rprintf("%s%*s", EncodeLogical(x[k],w), R_print.gap,""))
static void printNamedIntegerVector(int * x, int n, SEXP * names)
PRINT_N_VECTOR(formatInteger(x, n, &w),
Rprintf("%s%*s", EncodeInteger(x[k],w), R_print.gap,""))
#undef INI_F_REAL
#define INI_F_REAL int d, e; formatReal(x, n, &w, &d, &e, 0)
static void printNamedRealVector(double * x, int n, SEXP * names)
PRINT_N_VECTOR(INI_F_REAL,
Rprintf("%s%*s",
EncodeReal0(x[k],w,d,e, OutDec),R_print.gap,""))
#undef INI_F_CPLX
#define INI_F_CPLX \
int wr, dr, er, wi, di, ei; \
formatComplex(x, n, &wr, &dr, &er, &wi, &di, &ei, 0); \
w = wr + wi + 2
#undef P_IMAG_NA
#define P_IMAG_NA \
if(ISNAN(x[k].i)) \
Rprintf("+%si", "NaN"); \
else
static void printNamedComplexVector(Rcomplex * x, int n, SEXP * names)
PRINT_N_VECTOR(INI_F_CPLX,
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;
}
