using deprecated options(OutDec = "<not-1-char>") now warns in print() etc

git-svn-id: https://svn.r-project.org/R/trunk@87474 00db46b3-68df-0310-9c12-caf00c1e9a41

Author: maechler

doc/NEWS.Rd

@@ -424,6 +424,10 @@
       an error in the future, when \code{s} is not a string with exactly
       one character.
 
+      \item When \code{s <- getOption("OutDec")} is not a string of one
+      character, a warning is signalled now whenever it is used in internal
+      C code, notably when calling the default methods of \code{format()}.
+
       \item \code{pwilcox()} and \code{qwilcox()} now check for user
       interrupt less frequently.
     }

src/main/paste.c

@@ -515,7 +515,7 @@ attribute_hidden SEXP do_format(SEXP call, SEXP op, SEXP args, SEXP env)
 	my_OutDec = OutDec; // default
     else {
 	static char sdec[11];
-#define _WARN_decimal_mark_non_1 // were *not* warning here by default since 2015-06-19
+#undef  _WARN_decimal_mark_non_1 /* as we now warn in EncodeReal0() */
 #ifdef  _WARN_decimal_mark_non_1
  	if(R_nchar(STRING_ELT(CAR(args), 0), Chars,
 		   /* allowNA = */ FALSE, /* keepNA = */ FALSE,

src/main/printarray.c

@@ -41,7 +41,7 @@
    Used only for row/column names found by GetMatrixDimnames,
    so in native encoding.  (NULL ones from do_prmatrix are skipped.)
 */
-int Rstrwid(const char *str, int slen, int enc, int quote);  /* from printutils.c */
+int Rstrwid(const char *str, int slen, cetype_t ienc, int quote); /* from printutils.c */
 #define strwidth(x) Rstrwid(x, (int) strlen(x), CE_NATIVE, 0)
 
 /* ceil_DIV(a,b) :=  ceil(a / b)  in _int_ arithmetic : */

src/main/printutils.c

@@ -180,6 +180,9 @@ const char *EncodeExtptr(SEXP x)
     return buf;
 }
 
+int Rstrwid(const char *str, int slen, cetype_t ienc, int quote); /* below */
+#define strwidth(x) Rstrwid(x, (int) strlen(x), CE_NATIVE, 0)
+
 attribute_hidden
 const char *EncodeReal(double x, int w, int d, int e, char cdec)
 {
@@ -202,22 +205,26 @@ const char *EncodeReal0(double x, int w, int d, int e, const char *dec)
 	else snprintf(buff, NB, "%*s", min(w, (NB-1)), "-Inf");
     }
     else if (e) {
-	if(d) {
+	if(d) { // '#' flag
 	    snprintf(fmt, 20, "%%#%d.%de", min(w, (NB-1)), d);
-	    snprintf(buff, NB, fmt, x);
 	}
 	else {
 	    snprintf(fmt, 20, "%%%d.%de", min(w, (NB-1)), d);
-	    snprintf(buff, NB, fmt, x);
 	}
+	snprintf(buff, NB, fmt, x);
     }
     else { /* e = 0 */
 	snprintf(fmt, 20, "%%%d.%df", min(w, (NB-1)), d);
 	snprintf(buff, NB, fmt, x);
     }
     buff[NB-1] = '\0';
 
-    if(strcmp(dec, ".")) {
+    if(strcmp(dec, ".")) { /* replace "." by dec */
+	int len = strwidth(dec); /* 3·14 must work */
+	if(len != 1) warning(
+	    _("the decimal mark is %s than one character wide; this will become an error"),
+	    (len > 1) ? "more" : "less");
+
 	char *p, *q;
 	for(p = buff, q = buff2; *p; p++) {
 	    if(*p == '.') for(const char *r = dec; *r; r++) *q++ = *r;
@@ -230,6 +237,7 @@ const char *EncodeReal0(double x, int w, int d, int e, const char *dec)
     return out;
 }
 
+// A copy of EncodeReal0() -- additionally dropping trailing zeros:
 static const char
 *EncodeRealDrop0(double x, int w, int d, int e, const char *dec)
 {
@@ -247,12 +255,11 @@ static const char
     else if (e) {
 	if(d) {
 	    snprintf(fmt, 20, "%%#%d.%de", min(w, (NB-1)), d);
-	    snprintf(buff, NB, fmt, x);
 	}
 	else {
 	    snprintf(fmt, 20, "%%%d.%de", min(w, (NB-1)), d);
-	    snprintf(buff, NB, fmt, x);
 	}
+	snprintf(buff, NB, fmt, x);
     }
     else { /* e = 0 */
 	snprintf(fmt, 20, "%%%d.%df", min(w, (NB-1)), d);
@@ -274,7 +281,12 @@ static const char
 	}
     }
 
-    if(strcmp(dec, ".")) {
+    if(strcmp(dec, ".")) { /* replace "." by dec */
+	int len = strwidth(dec); /* 3·14 must work */
+	if(len != 1) warning(
+	    _("the decimal mark is %s than one character wide; this will become an error"),
+	    (len > 1) ? "more" : "less");
+
 	char *p, *q;
 	for(p = buff, q = buff2; *p; p++) {
 	    if(*p == '.') for(const char *r = dec; *r; r++) *q++ = *r;
@@ -1063,7 +1075,7 @@ void REvprintf(const char *format, va_list arg)
 
 int attribute_hidden IndexWidth(R_xlen_t n)
 {
-    return (int) (log10(n + 0.5) + 1);
+    return (int) (log10((double)n + 0.5) + 1);
 }
 
 attribute_hidden void VectorIndex(R_xlen_t i, int w)

tests/reg-encodings.R

@@ -372,3 +372,14 @@ r16[7] <- as.raw(0x00)  # invalid (unpaired surrogate)
 r16[8] <- as.raw(0xd8)
 stopifnot(identical(iconv(list(r16), "UTF-16", "UTF-8", sub="byte"),
           "He<00><d8>lo world"))
+
+
+## Using a __unicode__ decimal mark is fine :
+op <- options(OutDec = "·", scipen = 1)
+x <- pi* 10^(-6:5)
+fx <- sapply(x, format)
+print(fx, width=88, quote=FALSE) # 3·141593e-06 0·00003141593 0·0003141593 ....
+options(OutDec = ".") # back to normal
+stopifnot(grepl("·", fx, fixed=TRUE),
+          identical(sub("·", ".", fx), sapply(x, format)))
+options(op)

tests/reg-tests-1e.R

@@ -3,7 +3,8 @@
 .pt <- proc.time()
 tryCid <- function(expr) tryCatch(expr, error = identity)
 tryCmsg<- function(expr) tryCatch(expr, error = conditionMessage) # typically == *$message
-assertErrV <- function(...) tools::assertError(..., verbose=TRUE)
+assertErrV  <- function(...) tools::assertError  (..., verbose=TRUE)
+assertWarnV <- function(...) tools::assertWarning(..., verbose=TRUE)
 `%||%` <- function (L, R)  if(is.null(L)) R else L
 ##' get value of `expr` and keep warning as attribute (if there is one)
 getVaW <- function(expr) {
@@ -464,8 +465,8 @@ mod2 <- local({
        offset = { print("world"); x-y })
 }) # rank-deficient in "subtle" way {warning/NA may not be needed}; just show for now:
 nd <- data.frame(x = 1:5)
-tools::assertWarning(print(predict(mod2, newdata=nd, rankdeficient = "warnif")))
-                           predict(mod2, newdata=nd, rankdeficient = "NA")
+assertWarnV(print(predict(mod2, newdata=nd, rankdeficient = "warnif")))
+                  predict(mod2, newdata=nd, rankdeficient = "NA") # NA's but no warning
 nm5 <- as.character(1:5)
 stopifnot(exprs = {
     all.equal(setNames(rep(0, 5), nm5), predict(mod2), tol=1e-13) # pred: 1.776e-15
@@ -507,7 +508,7 @@ stopifnot(all.equal(urf$root, 0.88653, tolerance = 1e-4))
 
 
 ## chkDots() in subset.data.frame() to prevent usage errors
-tools::assertWarning(subset(data.frame(y = 1), y = 2), verbose = TRUE)
+assertWarnV(subset(data.frame(y = 1), y = 2))
 ## R < 4.3.0 was silent about unused ... arguments
 
 
@@ -518,8 +519,8 @@ a <- 1:2
 assertErrV(a:1) # numerical expression has length > 1
 assertErrV(2:a) #  "         "          "      "
 Sys.unsetenv("_R_CHECK_LENGTH_COLON_")
-tools::assertWarning(s1 <- a:1, verbose=TRUE)
-tools::assertWarning(s2 <- 2:a, verbose=TRUE)
+assertWarnV(s1 <- a:1)
+assertWarnV(s2 <- 2:a)
 stopifnot(identical(s1, 1L), identical(s2, 2:1))
 Sys.setenv("_R_CHECK_LENGTH_COLON_" = oldV)# reset
 ## always only warned in R <= 4.2.z
@@ -802,11 +803,9 @@ km1d <- kappa(m, norm = "1", method = "direct")
 all.equal(km1d, 7.6, tol=0) # 1.17e-16  {was wrongly 11.907 in R <= 4.3.1}
 ## 2) kappa(z, norm="2", LINPACK=TRUE) silently returns estimate of the *1*-norm cond.nr.
 (km1 <- kappa(m, norm = "1")) # 4.651847 {unchanged}
-tools::assertWarning(verbose=TRUE, # now *warns*
-                     km2L <- kappa(m, norm="2", LINPACK=TRUE))
+assertWarnV( km2L <- kappa(m, norm="2", LINPACK=TRUE)) # now *warns*
 ## 3) kappa(z, norm="2", LINPACK=FALSE) throws an error
-tools::assertWarning(verbose=TRUE, # *same* warning (1-norm instead of 2-)
-                     km2La <- kappa(m, norm="2", LINPACK=FALSE))
+assertWarnV(km2La <- kappa(m, norm="2", LINPACK=FALSE))# same warning (1-norm instead of 2-)
 km2La
 ## 4) kappa.qr(z) implicitly assumes nrow(z$qr) >= ncol(z$qr), not true in general
 (kqrm2 <- kappa(qr(cbind(m, m + 1))))
@@ -853,10 +852,8 @@ stopifnot(exprs = {
 (zm <- m + 1i*c(1,-(1:2))*(m/4))
 (kz1d <- kappa(zm, norm = "1", method = "direct"))
 (kz1  <- kappa(zm, norm = "1"))# meth = "qr"
-tools::assertWarning(verbose=TRUE, # now *warns* {gave *error* previously}
-                     kz2L <- kappa(zm, norm="2", LINPACK=TRUE))
-tools::assertWarning(verbose=TRUE, # *same* warning (1-norm instead of 2-)
-                     kz2La <- kappa(zm, norm="2", LINPACK=FALSE))
+assertWarnV(kz2L  <- kappa(zm, norm="2", LINPACK=TRUE))# now *warns* {gave *error* previously}
+assertWarnV(kz2La <- kappa(zm, norm="2", LINPACK=FALSE))# same warning (1-norm instead of 2-)
 kz2La
 ## 4) kappa.qr(z) implicitly assumes nrow(z$qr) >= ncol(z$qr) ..
 (kzqr2 <- kappa(qr(cbind(zm, zm + 1)))) # gave Error .. matrix should be square
@@ -1026,7 +1023,7 @@ stopifnot(identical(tt, drop.terms(tt, dropx = 0[0], keep.response=TRUE)))
 
 
 ## as.complex("<num>i") -- should work (and fail/warn) as the parser does:
-tools::assertWarning(cc <- as.complex("12iL"), verbose=TRUE)
+       assertWarnV(  cc <- as.complex("12iL"))
 tools::assertWarning(cF <- as.complex("12irene"))
 tools::assertWarning(cI <- as.complex("12I"))
 stopifnot(is.na(cc), is.na(cF), is.na(cI),
@@ -1477,6 +1474,8 @@ if(attr(oL, "ok") && capabilities("NLS") && !is.na(.popath)
     stopifnot(is.character(print("checking 'out' : ")),
               grepl("^argument non num.rique pour un ", out))
 ## was *not* switched to French (when this was run via 'make ..')
+## reset {just in case}:
+Sys.setLanguage("en")
 
 
 ## print( ls.str() ) using '<missing>' also in non-English setup:
@@ -1605,9 +1604,9 @@ assertErrV(options(scipen = NULL))# would work (but ..) in R <= 4.4.2
 assertErrV(options(scipen = 1:2)) # would just work
 assertErrV(options(scipen = 1e99))# would "work" w/ 2 warnings and invalid setting
 stopifnot(identical(getOption("scipen"), scipenO))# unchanged
-tools::assertWarning(verbose=TRUE, options(scipen = -100  ))# warns and sets to min = -9
+assertWarnV(options(scipen = -100))# warns and sets to min = -9
 stopifnot(identical(getOption("scipen"), -9L))
-tools::assertWarning(verbose=TRUE, options(scipen = 100000))# warns and sets to max = 9999
+assertWarnV(options(scipen = 100000))# warns and sets to max = 9999
 stopifnot(identical(getOption("scipen"), 9999L))
 ## setting to NULL  would invalidate as.character(Sys.time())
 
@@ -1678,6 +1677,24 @@ sort.int(x, method = "quick")
 sort.int(x, method = "quick", index.return = TRUE)
 
 
+## More warning for  _illegal_ OutDec -- even auto print() ing now warns when OutDec is illegal:
+assertWarnV(op <- options(OutDec = "_._", scipen = 6, warn = 1))
+assertWarnV( print(pi) ) # _new_ warning ... "will become an error"
+writeLines(m <- capture.output(format(pi), type = "message"))
+## Warning in prettyNum(.Internal(format(x, trim, digits, nsmall, width, 3L,  :
+##   the decimal mark is more than one character wide; this will become an error
+assertWarnV(options(OutDec = ""))
+m2 <- tryCatch(print(pi), warning = conditionMessage)
+assertWarnV( print(pi * 10^(-4:4)) ) # _new_ warning
+if(englishMsgs) stopifnot(exprs = {
+    grepl("^Warning in prettyNum\\(\\.Internal\\(format\\(", m[1])
+    grepl("the decimal mark is more than one character wide", m[length(m)])
+    grepl("the decimal mark is less than one character wide", m2)
+})
+## now warn from format() and (only once) from print()
+options(op) # return to sanity + warn=2
+
+
 
 ## keep at end
 rbind(last =  proc.time() - .pt,