s/sapply/vapply.

hornik · hornik · commit 06393c5de707 · 2025-06-08T08:34:13.000Z
git-svn-id: https://svn.r-project.org/R/trunk@88284 00db46b3-68df-0310-9c12-caf00c1e9a41
diff --git a/src/library/base/R/character.R b/src/library/base/R/character.R
@@ -62,7 +62,8 @@ abbreviate <-
 	if(method == "both.sides")
 	    ## string reversion: FIXME reverse .Internal(abbreviate(.))
 	    chRev <- function(x)
-		sapply(lapply(strsplit(x, NULL), rev), paste, collapse="")
+		vapply(lapply(strsplit(x, NULL), rev),
+                       paste, "", collapse = "")
 	dup2 <- rep.int(TRUE, length(names.arg))
 	these <- names.arg
 	repeat {
diff --git a/src/library/base/R/datetime.R b/src/library/base/R/datetime.R
@@ -922,7 +922,7 @@ function(..., recursive = FALSE)
     }
     args <- list(...)
     if(!length(args)) return(.difftime(double(), "secs"))
-    ind <- sapply(args, inherits, "difftime")
+    ind <- vapply(args, inherits, NA, "difftime")
     pos <- which(!ind)
     units <- sapply(args[ind], attr, "units")
     if(all(units == (un1 <- units[1L]))) {
diff --git a/src/library/base/R/dump.R b/src/library/base/R/dump.R
@@ -22,7 +22,7 @@ dump <- function (list, file = "dumpdata.R", append = FALSE,
 {
     if(is.character(file)) {
 	## avoid opening a file if there is nothing to dump
-	ex <- sapply(list, exists, envir=envir)
+	ex <- vapply(list, exists, NA, envir = envir)
 	if(!any(ex)) return(invisible(character()))
 	if(nzchar(file)) {
 	    file <- file(file, if(append) "a" else "w")
diff --git a/src/library/base/R/kronecker.R b/src/library/base/R/kronecker.R
@@ -52,14 +52,14 @@ kronecker <- function (X, Y, FUN = "*", make.dimnames = FALSE, ...)
 	    dnx <- vector("list", length(dX))
 	else if (ld < 0L)
 	    dnx <- c(dnx, vector("list", -ld))
-	tmp <- which(sapply(dnx, is.null))
+	tmp <- which(vapply(dnx, is.null, NA))
 	dnx[tmp] <- lapply(tmp, function(i) rep.int("", dX[i]))
 
 	if (is.null(dny))
 	    dny <- vector("list", length(dY))
 	else if (ld > 0)
 	    dny <- c(dny, vector("list", ld))
-	tmp <- which(sapply(dny, is.null))
+	tmp <- which(vapply(dny, is.null, NA))
 	dny[tmp] <- lapply(tmp, function(i) rep.int("", dY[i]))
 
 	k <- length(dim(opobj))
diff --git a/src/library/base/R/namespace.R b/src/library/base/R/namespace.R
@@ -1056,7 +1056,7 @@ namespaceImportFrom <- function(self, ns, vars, generics, packages,
                 ## and is in order of adding.
                 current <- getNamespaceInfo(self, "imports")
                 poss <- lapply(rev(current), `[`, n)
-                poss <- poss[!sapply(poss, is.na)]
+                poss <- poss[!vapply(poss, is.na, NA)]
                 if(length(poss) >= 1L) {
                     prev <- names(poss)[1L]
                     warning(sprintf(gettext("replacing previous import %s by %s when loading %s"),
diff --git a/src/library/base/R/summary.R b/src/library/base/R/summary.R
@@ -164,7 +164,7 @@ summary.data.frame <-
                 tmp <- rbind(tmp, matrix("", nr - nrow(sms), ncol(sms)))
             sms <- apply(tmp, 1L, function(x) paste(x, collapse="  "))
             ## produce a suitable colname: undoing padding
-            wid <- sapply(tmp[1L, ], nchar, type="w") # might be NA
+            wid <- vapply(tmp[1L, ], nchar, 0, type = "w") # might be NA
             blanks <- paste(character(max(wid)), collapse = " ")
             wcn <- ncw(cn)
             pad0 <- floor((wid - wcn)/2)
diff --git a/src/library/grDevices/R/glyph.R b/src/library/grDevices/R/glyph.R
@@ -168,7 +168,7 @@ glyphFontList <- function(...) {
     fonts <- list(...)
     if (!length(fonts))
         stop("List must include at least one font")
-    if (!all(sapply(fonts, function(x) inherits(x, "RGlyphFont"))))
+    if (!all(vapply(fonts, inherits, NA, "RGlyphFont")))
         stop("Invalid glyph font")
     class(fonts) <- "RGlyphFontList"
     fonts
diff --git a/src/library/grDevices/R/postscript.R b/src/library/grDevices/R/postscript.R
@@ -524,7 +524,7 @@ postscriptFonts <- function(...)
         fontNames <- names(fonts)
         nnames <- length(fontNames)
         if (nnames == 0L) {
-            if (!all(sapply(fonts, is.character)))
+            if (!all(vapply(fonts, is.character, NA)))
                 stop(gettextf("invalid arguments in '%s' (must be font names)",
                               "postscriptFonts"), domain = NA)
             else
@@ -578,7 +578,7 @@ pdfFonts <- function(...)
         fontNames <- names(fonts)
         nnames <- length(fontNames)
         if (nnames == 0L) {
-            if (!all(sapply(fonts, is.character)))
+            if (!all(vapply(fonts, is.character, NA)))
                 stop(gettextf("invalid arguments in '%s' (must be font names)",
                               "pdfFonts"), domain = NA)
             else
@@ -1009,7 +1009,7 @@ embedGlyphs <- function(file, glyphInfo, outfile = file,
     infoList <- FALSE
     if (!inherits(glyphInfo, "RGlyphInfo")) {
         if (is.list(glyphInfo)) {
-            if (!all(sapply(glyphInfo, inherits, "RGlyphInfo"))) {
+            if (!all(vapply(glyphInfo, inherits, NA, "RGlyphInfo"))) {
                 stop("Invalid 'glyphInfo'")
             } else {
                 infoList <- TRUE
diff --git a/src/library/graphics/R/fourfoldplot.R b/src/library/graphics/R/fourfoldplot.R
@@ -65,7 +65,7 @@ function(x, color = c("#99CCFF", "#6699CC"), conf.level = 0.95,
     dnx <- dimnames(x)
     if(is.null(dnx))
         dnx <- vector("list", 3L)
-    for(i in which(sapply(dnx, is.null)))
+    for(i in which(vapply(dnx, is.null, NA)))
         dnx[[i]] <- LETTERS[seq_len(dim(x)[i])]
     if(is.null(names(dnx)))
         i <- 1L : 3L
diff --git a/src/library/graphics/R/plot.design.R b/src/library/graphics/R/plot.design.R
@@ -30,7 +30,7 @@ plot.design <-
 	    stop("'y' must be a numeric vector")
 	if(!is.data.frame(x)) # or allow factor (see 2 lines below)?? {FIXME}
 	    stop("'x' must be a data frame")
-	if(!all(sapply(x, is.factor)) && !is.factor(x)) # incl "ordered"
+	if(!all(vapply(x, is.factor, NA)) && !is.factor(x)) # incl "ordered"
 	    stop("all columns/components of 'x' must be factors")
 	k <- ncol(x)
         if(anyNA(y)) {
@@ -75,17 +75,17 @@ plot.design <-
 	    x <- stats::model.frame(y , data = x)
 	}
 	else if(is.numeric(y)) {
-	    x <- cbind(y,x[,sapply(x, is.factor)])
+	    x <- cbind(y, x[, vapply(x, is.factor, NA)])
 	    tmpname <- match.call()
 	    names(x) <- as.character(c(tmpname[[3L]],names(x[,-1])))
 	}
 	else if(is.character(y)) {
 	    ynames <- y
 	    y <- data.frame(x[,y])
-	    if(sum(sapply(y, is.numeric)) != ncol(y)) {
+	    if(sum(vapply(y, is.numeric, NA)) != ncol(y)) {
 		stop("a variable in 'y' is not numeric")
 	    }
-	    x <- x[,sapply(x, is.factor)]
+	    x <- x[, vapply(x, is.factor, NA)]
 	    xnames <- names(x)
 	    x <- cbind(x,y)
 	    names(x) <- c(xnames,ynames)
@@ -98,8 +98,8 @@ plot.design <-
 	x <- stats::model.frame(x)
     }
 
-    i.fac <- sapply(x, is.factor)
-    i.num <- sapply(x, is.numeric)
+    i.fac <- vapply(x, is.factor, NA)
+    i.num <- vapply(x, is.numeric, NA)
     nResp <- sum(i.num)
     if (nResp == 0)
 	stop("there must be at least one numeric variable!")
diff --git a/src/library/grid/R/coords.R b/src/library/grid/R/coords.R
@@ -20,13 +20,13 @@ validCoords <- function(x) {
 
 validGrobCoords <- function(x) {
     is.list(x) && length(x) > 0 &&
-        all(sapply(x, inherits, "GridCoords"))
+        all(vapply(x, inherits, NA, "GridCoords"))
 }
 
 validGTreeCoords <- function(x) {
     is.list(x) && length(x) > 0 &&
-        all(sapply(x, inherits, "GridGrobCoords") |
-            sapply(x, inherits, "GridGTreeCoords"))
+        all(vapply(x, inherits, NA, "GridGrobCoords") |
+            vapply(x, inherits, NA, "GridGTreeCoords"))
 }
 
 coordPrintIndent <- "  "
@@ -216,11 +216,11 @@ isEmptyCoords.GridCoords <- function(coords) {
 }
 
 isEmptyCoords.GridGrobCoords <- function(coords) {
-    all(sapply(coords, identical, emptyCoords))
+    all(vapply(coords, identical, NA, emptyCoords))
 }
 
 isEmptyCoords.GridGTreeCoords <- function(coords) {
-    all(sapply(coords, isEmptyCoords))    
+    all(vapply(coords, isEmptyCoords, NA))
 }
 
 ################################################################################
@@ -617,7 +617,7 @@ grobPoints.points <- function(x, closed=TRUE, ...) {
         stop("Closed must be length 1 and must not be a missing value")
     pts <- grid.Call(C_pointsPoints, x$x, x$y, x$pch, x$size, closed)
     if (is.null(pts) ||
-        all(sapply(pts, is.null))) {
+        all(vapply(pts, is.null, NA))) {
         emptyGrobCoords(x$name)
     } else {
         names <- attr(pts, "coordNames")
diff --git a/src/library/grid/R/edit.R b/src/library/grid/R/edit.R
@@ -46,7 +46,7 @@ applyEdit <- function(x, edit) {
 # A list of gEdit's to apply to the same grob
 gEditList <- function(...) {
   edits <- list(...)
-  if (!all(sapply(edits, is.gEdit)))
+  if (!all(vapply(edits, is.gEdit, NA)))
     stop("'gEditList' can only contain 'gEdit' objects")
   class(edits) <- "gEditList"
   edits
diff --git a/src/library/grid/R/gpar.R b/src/library/grid/R/gpar.R
@@ -98,7 +98,7 @@ validGP <- function(gpars) {
           ## OR a "GridPattern" OR a list of "GridPattern"s
           if (!is.pattern(gpars$fill)) {
               if (is.list(gpars$fill)) {
-                  if (!all(sapply(gpars$fill, is.pattern)))
+                  if (!all(vapply(gpars$fill, is.pattern, NA)))
                       stop("'fill' gpar list components must all be patterns")
                   class(gpars$fill) <- "GridPatternList"
               }
diff --git a/src/library/grid/R/grob.R b/src/library/grid/R/grob.R
@@ -187,10 +187,10 @@ as.gList <- function(x) {
 gList <- function(...) {
     gl <- list(...)
     if (length(gl) == 0L ||
-        all(sapply(gl, okGListelt, simplify=TRUE))) {
+        all(vapply(gl, okGListelt, NA))) {
         # Ensure gList is "flat"
         # Don't want gList containing gList ...
-        if (!all(sapply(gl, is.grob)))
+        if (!all(vapply(gl, is.grob, NA)))
             gl <- do.call("c", lapply(gl, as.gList))
         class(gl) <- c("gList")
         return(gl)
@@ -259,7 +259,7 @@ setChildren <- function(x, children) {
   # Thin out NULL children
   if (!is.null(children)) {
     cl <- class(children)
-    children <- children[!sapply(children, is.null)]
+    children <- children[!vapply(children, is.null, NA)]
     class(children) <- cl
   }
   if (length(children)) {
diff --git a/src/library/grid/R/ls.R b/src/library/grid/R/ls.R
@@ -693,7 +693,7 @@ nestedListing <- function(x, gindent="  ", vpindent=gindent) {
     makePrefix <- function(indent, depth) {
         indents <- rep(indent, length(depth))
         indents <- mapply(rep, indents, depth)
-        sapply(indents, paste, collapse="")
+        vapply(indents, paste, "", collapse = "")
     }
 
     if (!inherits(x, "flatGridListing"))
diff --git a/src/library/methods/R/ClassUnion.R b/src/library/methods/R/ClassUnion.R
@@ -34,7 +34,7 @@
 
 setClassUnion <- function(name, members = character(), where = topenv(parent.frame())) {
     if(length(members)>0) {
-        membersDefined <- sapply(members, isClass, where = as.environment(where))
+        membersDefined <- vapply(members, isClass, NA, where = as.environment(where))
         if(!all(membersDefined))
             stop(gettextf("the member classes must be defined: not true of %s",
                           paste(.dQ(as(members[!membersDefined], "character")), collapse=", ")), domain = NA)
diff --git a/src/library/methods/R/Methods.R b/src/library/methods/R/Methods.R
@@ -1062,9 +1062,11 @@ showMethods <-
     geom <- vapply(signatures, Negate(is.null), logical(1))
     packages <- packages[geom]
     methods <- methods[geom]
-    signatures <- sapply(signatures[geom], function(elt) {
-        paste0(as.vector(elt), collapse=",")
-    })
+    signatures <- vapply(signatures[geom],
+                         function(elt) {
+                             paste0(as.vector(elt), collapse=",")
+                         },
+                         "")
 
     .methods_info(generic=rep(generic.function, length(packages)), from=packages,
                   signature=signatures)
diff --git a/src/library/methods/R/RMethodUtils.R b/src/library/methods/R/RMethodUtils.R
@@ -1908,7 +1908,9 @@ getLoadActions <- function(where = topenv(parent.frame())) {
         return(list())
     actions <- get(actionListName, envir = where)
     if(length(actions)) {
-        allExists <- sapply(actions, function(what) exists(.actionMetaName(what), envir = where, inherits = FALSE))
+        allExists <- vapply(actions,
+                            function(what) exists(.actionMetaName(what), envir = where, inherits = FALSE),
+                            NA)
         if(!all(allExists)) {
             warning(gettextf("some actions are missing: %s",
                              paste(actions[!allExists], collapse =", ")),
diff --git a/src/library/methods/R/methodsTable.R b/src/library/methods/R/methodsTable.R
@@ -1630,7 +1630,7 @@ testInheritedMethods <- function(f, signatures, test = TRUE,  virtual = FALSE,
     }
     signatures <- lapply(signatures, doSelect)
   }
-  signatures <- sapply(signatures, paste0, collapse = "#")
+  signatures <- vapply(signatures, paste0, "", collapse = "#")
   names(signatures) <- sigLabels
 
   new("MethodSelectionReport", generic = fname, allSelections = signatures,
diff --git a/src/library/parallel/R/unix/mclapply.R b/src/library/parallel/R/unix/mclapply.R
@@ -63,7 +63,7 @@ mclapply <- function(X, FUN, ..., mc.preschedule = TRUE, mc.set.seed = TRUE,
                                                   silent = mc.silent))
             res <- mccollect(jobs)
             if (length(res) == length(X)) names(res) <- names(X)
-            has.errors <- sum(sapply(res, inherits, "try-error"))
+            has.errors <- sum(vapply(res, inherits, NA, "try-error"))
         } else { # more complicated, we have to wait for jobs selectively
             sx <- seq_along(X)
             res <- vector("list", length(sx))
diff --git a/src/library/stats/R/aov.R b/src/library/stats/R/aov.R
@@ -274,7 +274,7 @@ summary.aov <- function(object, intercept = FALSE, split,
                     tmp <- apply(tmp, 1L, function(x) paste(x, collapse="."))
                     new <- lapply(splitnames, function(x) match(x, tmp))
                     split[[ names[i+1L] ]] <-
-                        new[sapply(new, function(x) length(x) > 0L)]
+                        new[lengths(new) > 0L]
                 } else {
                     old <- split[[ f[sp] ]]
                     marg.coefs <- df.names[asgn == (match(f[sp], names) - 1L)]
diff --git a/src/library/stats/R/bartlett.test.R b/src/library/stats/R/bartlett.test.R
@@ -26,7 +26,7 @@ function(x, g, ...)
         if (length(x) < 2L)
             stop("'x' must be a list with at least 2 elements")
         DNAME <- deparse1(substitute(x))
-        if (all(sapply(x, function(obj) inherits(obj, "lm"))))
+        if (all(vapply(x, inherits, NA, "lm")))
             LM <- TRUE
         else
             x <- lapply(x, function(x) x <- x[is.finite(x)])
diff --git a/src/library/stats/R/glm-profile.R b/src/library/stats/R/glm-profile.R
@@ -130,7 +130,7 @@ plot.profile <-
   ## R version: non-Trellis-based replacement for plot.profile
   function(x, ...)
 {
-    nulls <- sapply(x, is.null)
+    nulls <- vapply(x, is.null, NA)
     if (all(nulls)) return(NULL)
     x <- x[!nulls]
     nm <- names(x)
diff --git a/src/library/stats/R/kruskal.test.R b/src/library/stats/R/kruskal.test.R
@@ -28,7 +28,7 @@ function(x, g, ...)
             warning("'x' is a list, so ignoring argument 'g'")
         DNAME <- deparse1(substitute(x))
         x <- lapply(x, function(u) u <- u[complete.cases(u)])
-        if (!all(sapply(x, is.numeric)))
+        if (!all(vapply(x, is.numeric, NA)))
             warning("some elements of 'x' are not numeric and will be coerced to numeric")
         k <- length(x)
         l <- lengths(x)
diff --git a/src/library/stats/R/loess.R b/src/library/stats/R/loess.R
@@ -39,7 +39,7 @@ function(formula, data, weights, subset, na.action, model = FALSE,
     w <- model.weights(mf) %||% rep_len(1, length(y))
     nmx <- as.character(attr(mt, "variables"))[-(1L:2)]
     x <- mf[, nmx, drop=FALSE]
-    if(any(sapply(x, is.factor))) stop("predictors must all be numeric")
+    if(any(vapply(x, is.factor, NA))) stop("predictors must all be numeric")
     x <- as.matrix(x)
     D <- ncol(x)
     nmx <- setNames(nm = colnames(x))
diff --git a/src/library/stats/R/model.tables.R b/src/library/stats/R/model.tables.R
@@ -314,7 +314,7 @@ replications <- function(formula, data = NULL, na.action)
     z <- setNames(vector("list", n), labels)
     dummy <- numeric(.row_names_info(data, 2L))
     data <- lapply(data, function(x) if (is.character(x)) as.factor(x) else x)
-    notfactor <- !sapply(data, function(x) inherits(x, "factor"))
+    notfactor <- !vapply(data, inherits, NA, "factor")
     balance <- TRUE
     for(i in seq_len(n)) {
 	l <- labels[i]
@@ -421,7 +421,7 @@ eff.aovlist <- function(aovlist)
 {
     Terms <- terms(aovlist)
     if(names(aovlist)[[1L]] == "(Intercept)") aovlist <- aovlist[-1L]
-    pure.error.strata <- sapply(aovlist, function(x) is.null(x$qr))
+    pure.error.strata <- vapply(aovlist, function(x) is.null(x$qr), NA)
     aovlist <- aovlist[!pure.error.strata]
     s.labs <- names(aovlist)
     ## find which terms are in which strata
diff --git a/src/library/stats/R/nls-profile.R b/src/library/stats/R/nls-profile.R
@@ -86,7 +86,7 @@ profiler.nls <- function(fitted, ...)
                  } else {
                      if(length(args) == 1 && is.list(args[[1L]])) {
                          params <- unlist(args[[1L]])
-                     } else if(all(sapply(args, is.numeric))) {
+                     } else if(all(vapply(args, is.numeric, NA))) {
                          params <- unlist(args)
                      } else stop("invalid argument to 'getProfile'")
                      if(!all(names(params) %in% names(fittedPars)))
diff --git a/src/library/stats/R/prcomp.R b/src/library/stats/R/prcomp.R
@@ -162,5 +162,7 @@ predict.prcomp <- function(object, newdata, ...)
     mt <- attr(mf, "terms")
     mterms <- attr(mt, "factors")
     mterms <- rownames(mterms)[apply(mterms, 1L, function(x) any(x > 0L))]
-    any(sapply(mterms, function(x) is.factor(mf[,x]) || !is.numeric(mf[,x])))
+    any(vapply(mterms,
+               function(x) is.factor(mf[,x]) || !is.numeric(mf[,x]),
+               NA))
 }
diff --git a/src/library/stats/R/termplot.R b/src/library/stats/R/termplot.R
@@ -78,7 +78,9 @@ termplot <- function(model, data = NULL, envir = environment(formula(model)),
     }
 
     in.mf <- nmt %in% names(mf)
-    is.fac <- sapply(nmt, function(i) i %in% names(mf) && is.factor(mf[, i]))
+    is.fac <- vapply(nmt,
+                     function(i) i %in% names(mf) && is.factor(mf[, i]),
+                     NA)
 
     if (!plot) {
         outlist <- vector("list", sum(in.mf))
diff --git a/src/library/stats4/R/mle.R b/src/library/stats4/R/mle.R
@@ -55,7 +55,7 @@ mle <- function(minuslogl, start, optim = stats::optim,
         )
 
     nf <- names(fullcoef)
-    signature <- list(lengths = sapply(fullcoef, length),
+    signature <- list(lengths = lengths(fullcoef),
                       names = lapply(fullcoef, names))
     sigindex <- factor(rep(nf, signature$lengths), levels=nf)
     npars <- sum(signature$lengths)

Original file line number	Diff line number	Diff line change
`@@ -922,7 +922,7 @@ function(..., recursive = FALSE)`
`922`	`922`	`}`
`923`	`923`	`args <- list(...)`
`924`	`924`	`if(!length(args)) return(.difftime(double(), "secs"))`
`925`		`- ind <- sapply(args, inherits, "difftime")`
	`925`	`+ ind <- vapply(args, inherits, NA, "difftime")`
`926`	`926`	`pos <- which(!ind)`
`927`	`927`	`units <- sapply(args[ind], attr, "units")`
`928`	`928`	`if(all(units == (un1 <- units[1L]))) {`
Original file line number	Diff line number	Diff line change
`@@ -22,7 +22,7 @@ dump <- function (list, file = "dumpdata.R", append = FALSE,`
`22`	`22`	`{`
`23`	`23`	`if(is.character(file)) {`
`24`	`24`	`## avoid opening a file if there is nothing to dump`
`25`		`- ex <- sapply(list, exists, envir=envir)`
	`25`	`+ ex <- vapply(list, exists, NA, envir = envir)`
`26`	`26`	`if(!any(ex)) return(invisible(character()))`
`27`	`27`	`if(nzchar(file)) {`
`28`	`28`	`file <- file(file, if(append) "a" else "w")`