cosmetics: gettext() with %s for transl; comments; lengths(); examples

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

src/library/base/R/as.R

@@ -20,7 +20,7 @@ as.single <- function(x,...) UseMethod("as.single")
 as.single.default <- function(x,...)
  structure(.Internal(as.vector(x,"double")), Csingle=TRUE)
 
-# as.character is now internal. The default method remains here to
+# as.character is now .Primitive(). The default method remains here to
 # preserve the semantics that for a call with an object argument
 # dispatching is done first on as.character and then on as.vector.
 as.character.default <- function(x,...) .Internal(as.vector(x, "character"))

src/library/base/R/attr.R

@@ -33,7 +33,7 @@
  ## Be careful to set dim before dimnames.
  if(h.dim && L == prod(d1)) attr(x, "dim") <- dm <- d1
  if(h.dmn && !is.null(dm)) {
- ddn <- vapply(dn1, length, 1, USE.NAMES=FALSE)
+ ddn <- lengths(dn1, use.names=FALSE)
  if( all((dm == ddn)[ddn > 0]) ) attr(x, "dimnames") <- dn1
  }
  ## don't set if it has 'dim' now

src/library/base/R/load.R

@@ -90,7 +90,8 @@ save <- function(..., list = character(),
  }
  }
  if (is.character(file)) {
- if(!nzchar(file)) stop("'file' must be non-empty string")
+ if(!nzchar(file)) 
+ stop(gettextf("'%s' must be a non-empty string", "file"), domain = NA)
  if(!is.character(compress)) {
  if(!is.logical(compress))
  stop("'compress' must be logical or character")
@@ -128,9 +129,8 @@ save <- function(..., list = character(),
 save.image <- function (file = ".RData", version = NULL, ascii = FALSE,
  compress = !ascii, safe = TRUE)
 {
- if (! is.character(file) || file == "")
- stop("'file' must be non-empty string")
-
+ if (!is.character(file) || length(file) != 1 || file == "")
+ stop(gettextf("'%s' must be a non-empty string", "file"), domain = NA)
  opts <- getOption("save.image.defaults")
  if(is.null(opts)) opts <- getOption("save.defaults")
 

src/library/base/R/methodsSupport.R

@@ -34,6 +34,7 @@ trace <- function(what, tracer, exit, at, print, signature,
  ## the correct namespace (e.g., correct version of class())
  call <- sys.call()
  call[[1L]] <- quote(methods:::.TraceWithMethods)
+ # -> ../../methods/R/trace.R
  call$where <- where
  eval.parent(call)
 }

src/library/base/R/serialize.R

@@ -1,7 +1,7 @@
 # File src/library/base/R/serialize.R
 # Part of the R package, https://www.R-project.org
 #
-# Copyright (C) 1995-2019 The R Core Team
+# Copyright (C) 1995-2023 The R Core Team
 #
 # This program is free software; you can redistribute it and/or modify
 # it under the terms of the GNU General Public License as published by
@@ -21,7 +21,8 @@ saveRDS <-
  compress = TRUE, refhook = NULL)
 {
  if(is.character(file)) {
- if(file == "") stop("'file' must be non-empty string")
+ if(length(file) != 1 || file == "")
+ stop(gettextf("'%s' must be a non-empty string", "file"), domain = NA)
  object <- object # do not create corrupt file if object does not exist
  mode <- if(ascii %in% FALSE) "wb" else "w"
  con <- if (is.logical(compress))

src/library/base/R/sort.R

@@ -16,6 +16,7 @@
 # A copy of the GNU General Public License is available at
 # https://www.R-project.org/Licenses/
 
+## interfacing to ALTREP meta data about "sorted"ness and presence of NAs:
 .doSortWrap <- local({
  ## this matches the enum in Rinternals.h
  INCR_NA_1ST <- 2
@@ -52,7 +53,7 @@
  }
 })
 ## temporary, for sort.int and sort.list captured as S4 default methods
-## .doWrap introduced in r74405 | 2018-03-14 replaced by .doSoftWrap in r74504 | 2018-04-02
+## .doWrap introduced in r74405 | 2018-03-14 replaced by .doSortWrap in r74504 | 2018-04-02
 .doWrap <- .doSortWrap
 
 sort <- function(x, decreasing = FALSE, ...)
@@ -81,7 +82,7 @@ sort.int <-
  method = c("auto", "shell", "quick", "radix"),
  index.return = FALSE)
 {
- ## fastpass
+ ## fastpass {for "known to be sorted" x (ALTREP meta data; see .doSortWrap()}
  decreasing <- as.logical(decreasing)
  if (is.null(partial) && !index.return && is.numeric(x)) {
  if (.Internal(sorted_fpass(x, decreasing, na.last))) {
@@ -180,18 +181,18 @@ sort.int <-
  if (isfact)
  y <- (if (isord) ordered else factor)(y, levels = seq_len(nlev),
  labels = lev)
- if (is.null(partial)) {
- y <- .doSortWrap(y, decreasing, na.last)
- }
- y
+ if (is.null(partial))
+ .doSortWrap(y, decreasing, na.last)
+ else
+  y
 }
 
 order <- function(..., na.last = TRUE, decreasing = FALSE,
  method = c("auto", "shell", "radix"))
 {
  z <- list(...)
 
- ## fastpass, take advantage of ALTREP metadata
+ ## fastpass, take advantage of ALTREP metadata, see .doSortWrap()
  decreasing <- as.logical(decreasing)
  if (length(z) == 1L && is.numeric(x <- z[[1L]]) && !is.object(x) && length(x) > 0) {
  if (.Internal(sorted_fpass(x, decreasing, na.last)))

src/library/base/R/version.R

@@ -171,7 +171,7 @@ function(x)
  classes <- class(x)
  nms <- names(x)
  x <- unclass(x)
- lens <- vapply(x, length, 0L)
+ lens <- lengths(x)
  y <- lapply(x, function(e) sprintf("%o", e))
  ## Maximal number of octal digits needed.
  width <- max(nchar(unlist(y)), 0L)
@@ -382,7 +382,7 @@ function(x, recursive = FALSE)
 {
  ## <NOTE>
  ## Assuming *valid* numeric_version objects, we could simply do:
- ## any(vapply(unclass(x), length, 0L) == 0L)
+ ## any(lengths(unclass(x)) == 0L)
  ## </NOTE>
  anyNA(.encode_numeric_version(x))
 }

src/library/base/man/stopifnot.Rd

@@ -136,6 +136,18 @@ stopifnot("m must be symmetric"= m == t(m))
 #=> Error: m must be symmetric
 
 options(op) # revert to previous error handler
+
+##' warnifnot(): a "only-warning" version of stopifnot()
+##' {Yes, learn how to use do.call(substitute, ...) in a powerful manner !!}
+warnifnot <- stopifnot ; N <- length(bdy <- body(warnifnot))
+bdy <- do.call(substitute, list(bdy, list(stopifnot = quote(warnifnot))))
+bdy[[N-1]] <- do.call(substitute, list(bdy[[N-1]], list(stop = quote(warning))))
+body(warnifnot) <- bdy
+warnifnot(1 == 1, 1 < 2, 2 < 2) # => warns " 2 < 2 is not TRUE "
+warnifnot(exprs = {
+ 1 == 1
+ 3 < 3 # => warns "3 < 3 is not TRUE"
+})
 }
 \keyword{environment}
 \keyword{programming}

src/library/base/man/table.Rd

@@ -150,6 +150,7 @@ with(airquality, table(cut(Temp, quantile(Temp)), Month))
 
 a <- letters[1:3]
 table(a, sample(a)) # dnn is c("a", "")
+table(a, sample(a), dnn = NULL) # dimnames() have no names
 table(a, sample(a), deparse.level = 0) # dnn is c("", "")
 table(a, sample(a), deparse.level = 2) # dnn is c("a", "sample(a)")
 

src/library/grDevices/R/postscript.R

@@ -1,7 +1,7 @@
 # File src/library/grDevices/R/postscript.R
 # Part of the R package, https://www.R-project.org
 #
-# Copyright (C) 1995-2019 The R Core Team
+# Copyright (C) 1995-2022 The R Core Team
 #
 # This program is free software; you can redistribute it and/or modify
 # it under the terms of the GNU General Public License as published by
@@ -961,7 +961,8 @@ embedFonts <- function(file, # The ps or pdf file to convert
  )
 {
  if(!is.character(file) || length(file) != 1L || !nzchar(file))
- stop("'file' must be a non-empty character string")
+ stop(gettextf("'%s' must be a non-empty character string", "file"),
+ domain = NA)
  gsexe <- tools::find_gs_cmd()
  if(!nzchar(gsexe)) stop("GhostScript was not found")
  if(.Platform$OS.type == "windows") gsexe <- shortPathName(gsexe)

src/library/methods/src/methods_list_dispatch.c

@@ -499,11 +499,9 @@ SEXP R_getGeneric(SEXP name, SEXP mustFind, SEXP env, SEXP package)
  value = get_generic(name, env, package);
  if(value == R_UnboundValue) {
  if(asLogical(mustFind)) {
- if(env == R_GlobalEnv)
- error(_("no generic function definition found for '%s'"),
- CHAR(asChar(name)));
- else
- error(_("no generic function definition found for '%s' in the supplied environment"),
+ error((env == R_GlobalEnv)
+ ? _("no generic function definition found for '%s'")
+ : _("no generic function definition found for '%s' in the supplied environment"),
  CHAR(asChar(name)));
  }
  value = R_NilValue;

src/library/stats/loess-README

@@ -1,6 +1,6 @@
 A first try at de-obfuscate the structure, mainly in ./loessf.f :
 
- ehg182(): warning(message) generator, defined in ./loessc.c
+ loesswarn(), formerly ehg182() : warning(message) generator, defined in ./loessc.c
  called from almost any non-trivial function in loessf.f
  and hence *NOT* in the following calling structure
 

src/library/stats/man/Hypergeometric.Rd

@@ -1,6 +1,6 @@
 % File src/library/stats/man/Hypergeometric.Rd
 % Part of the R package, https://www.R-project.org
-% Copyright 1995-2020 R Core Team
+% Copyright 1995-2023 R Core Team
 % Distributed under GPL 2 or later
 
 \name{Hypergeometric}
@@ -111,7 +111,9 @@ m <- 10; n <- 7; k <- 8
 x <- 0:(k+1)
 rbind(phyper(x, m, n, k), dhyper(x, m, n, k))
 all(phyper(x, m, n, k) == cumsum(dhyper(x, m, n, k))) # FALSE
-\donttest{## but error is very small:
+\donttest{## but errors are very small:
 signif(phyper(x, m, n, k) - cumsum(dhyper(x, m, n, k)), digits = 3)
-}}
+}
+stopifnot(abs(phyper(x, m, n, k) - cumsum(dhyper(x, m, n, k))) < 5e-16)
+}
 \keyword{distribution}

src/library/stats/man/loess.Rd

@@ -1,6 +1,6 @@
 % File src/library/stats/man/loess.Rd
 % Part of the R package, https://www.R-project.org
-% Copyright 1995-2015 R Core Team
+% Copyright 1995-2023 R Core Team
 % Distributed under GPL 2 or later
 
 \name{loess}
@@ -57,7 +57,7 @@ loess(formula, data, weights, subset, na.action, model = FALSE,
  (\emph{if} \code{control} is not specified).}
 }
 \description{
- Fit a polynomial surface determined by one or more numerical
+ Fit a locally polynomial surface determined by one or more numerical
  predictors, using local fitting.
 }
 \details{
@@ -83,7 +83,9 @@ loess(formula, data, weights, subset, na.action, model = FALSE,
  speed. See \code{\link{loess.control}} for details.
 }
 \value{
- An object of class \code{"loess"}.% otherwise entirely unspecified (!)
+ An object of class \code{"loess"}, % otherwise entirely unspecified (!)
+ with \code{print()}, \code{\link{summary}()}, \code{\link{predict}} and
+ \code{\link{anova}} methods.
 }
 \references{
  W. S. Cleveland, E. Grosse and W. M. Shyu (1992) Local regression
@@ -124,8 +126,8 @@ cars.lo <- loess(dist ~ speed, cars)
 predict(cars.lo, data.frame(speed = seq(5, 30, 1)), se = TRUE)
 # to allow extrapolation
 cars.lo2 <- loess(dist ~ speed, cars,
- control = loess.control(surface = "direct"))
+  control = loess.control(surface = "direct"))
 predict(cars.lo2, data.frame(speed = seq(5, 30, 1)), se = TRUE)
-}
+}%% Add a 2D example, e.g. like 'topo' of MASS ch04.R, but using volcano?
 \keyword{smooth}
 \keyword{loess}

src/library/stats/src/deriv.c

@@ -781,13 +781,13 @@ static SEXP AddParens(SEXP expr)
 
 SEXP doD(SEXP args)
 {
- SEXP expr, var;
  args = CDR(args);
+ SEXP expr;
  if (isExpression(CAR(args))) expr = VECTOR_ELT(CAR(args), 0);
  else expr = CAR(args);
  if (!(isLanguage(expr) || isSymbol(expr) || isNumeric(expr) || isComplex(expr)))
  error(_("expression must not be type '%s'"), type2char(TYPEOF(expr)));
- var = CADR(args);
+ SEXP var = CADR(args);
  if (!isString(var) || length(var) < 1)
  error(_("variable must be a character string"));
  if (length(var) > 1)

src/library/stats/src/massdist.c

@@ -3,8 +3,7 @@
  * Copyright (C) 1996-2020 The R Core Team
  * Copyright (C) 2005 The R Foundation
 
- * "HACKED" to allow weights by Adrian Baddeley
- * Changes indicated by 'AB'
+ * "HACKED" to allow weights by Adrian Baddeley (commit r34130, 2005-04-30)
  * -------
  * FIXME Does he want 'COPYRIGHT' ?
  * -------
@@ -34,7 +33,7 @@
 /* NB: this only works on the lower half of y, but pads with zeros. */
 SEXP BinDist(SEXP sx, SEXP sw, SEXP slo, SEXP shi, SEXP sn)
 {
- PROTECT(sx = coerceVector(sx, REALSXP)); 
+ PROTECT(sx = coerceVector(sx, REALSXP));
  PROTECT(sw = coerceVector(sw, REALSXP));
  int n = asInteger(sn);
  if (n == NA_INTEGER || n <= 0) error("invalid '%s' argument", "n");

src/library/tools/R/Rd2latex.R

@@ -82,10 +82,7 @@ Rd2latex <- function(Rd, out = "", defines = .Platform$OS.type,
  }
  }
 
- if (concordance)
- conc <- activeConcordance()
- else
- conc <- NULL
+ conc <- if(concordance) activeConcordance() # else NULL
 
  last_char <- ""
  of0 <- function(...) of1(paste0(...))

src/library/tools/R/testing.R

@@ -833,8 +833,10 @@ testInstalledBasic <- function(scope = c("basic", "devel", "both", "internet", "
  runone("datetime5")
  message("running tests of consistency of as/is.*", domain = NA)
  runone("isas-tests")
- message("running tests of random deviate generation -- fails occasionally")
+ message("running tests of random deviate generation (should no longer ever fail)")
  runone("p-r-random-tests", TRUE)
+ message("running miscellanous strict devel checks", domain = NA)
+ if (runone("misc-devel")) return(invisible(1L))
  message("running tests demos from base and stats", domain = NA)
  if (runone("demos")) return(invisible(1L))
  if (runone("demos2")) return(invisible(1L))

src/library/utils/R/debugcall.R

@@ -1,7 +1,7 @@
 ## File src/library/utils/R/debugcall.R
 ## Part of the R package, https://www.R-project.org
 ##
-## Copyright (C) 1995-2016 The R Core Team
+## Copyright (C) 1995-2023 The R Core Team
 ##
 ## This program is free software; you can redistribute it and/or modify
 ## it under the terms of the GNU General Public License as published by
@@ -19,26 +19,25 @@
 .debugcall <- function(call, op) {
  funsym <- deparse(call[[1L]])
  func <- get(funsym, parent.frame(2L), mode="function")
- 
+
  have.methods <- isNamespaceLoaded("methods")
  func <- if(is.primitive(func)) {
- if (have.methods) methods::getGeneric(func)
- } else func
+  if (have.methods) methods::getGeneric(func)
+  } else func
  if(is.null(func)) {
  stop("Cannot debug primitive functions unless they are implicit generics (requires loading the methods package)")
  }
  mcall <- match.call(func, call)
 
  env <- parent.frame(2L)
- sig <- NULL
- s4Generic <- have.methods && methods::isGeneric(funsym)
- if(!s4Generic) {
+ if(!(have.methods && methods::isGeneric(funsym))) { # not S4-generic
  s3ret <- isS3stdGeneric(func)
  if(s3ret) {
  genname <- names(s3ret)
- arg <- eval(mcall[[2L]], envir=env) 
+ arg <- eval(mcall[[2L]], envir=env)
  func <- getS3method(genname, class(arg))
  }
+ sig <- NULL
  } else {
  sig <- .signatureFromCall(func, mcall, env)
  }
@@ -49,7 +48,7 @@
  args <- formals(fdef)
  call <- match.call(fdef, expr, expand.dots = FALSE)
  args[names(call[-1L])] <- call[-1L]
- if ("..." %in% names(call)) 
+ if ("..." %in% names(call))
  args$... <- args$...[[1L]]
  sigNames <- fdef@signature
  sigClasses <- rep.int("missing", length(sigNames))
@@ -68,8 +67,8 @@
  ## the evaluator.
  if (doEval || !simple) {
  argVal <- try(eval(argExpr, envir))
- if (methods::is(argVal, "try-error")) 
- stop(gettextf("error in trying to evaluate the expression for argument %s (%s)", 
+ if (methods::is(argVal, "try-error"))
+ stop(gettextf("error in trying to evaluate the expression for argument %s (%s)",
  sQuote(arg), deparse(argExpr)), domain = NA)
  sigClasses[[arg]] <- class(argVal)[1L]
  }