static Rboolean any_nan_complex(SEXP x) { const Rcomplex * xp = COMPLEX_RO(x); const Rcomplex * const xe = xp + xlength(x); for (; xp != xe; xp++) { if (R_IsNaN((*xp).r) || R_IsNaN((*xp).i)) return TRUE; } return FALSE; }
static int_err_t check_convertible_complex(SEXP x, const double tol) { const Rcomplex * xc = COMPLEX_RO(x); const R_xlen_t n = length(x); int_err_t res = { 0, INT_OK }; for (R_xlen_t i = 0; i < n; i++) { int_check_t ok = is_unconvertible_complex(xc[i], tol); if (ok != INT_OK) { res.pos = i + 1; res.err = ok; break; } } return res; }
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); }