1# File src/library/base/R/sapply.R 2# Part of the R package, https://www.R-project.org 3# 4# Copyright (C) 1995-2020 The R Core Team 5# 6# This program is free software; you can redistribute it and/or modify 7# it under the terms of the GNU General Public License as published by 8# the Free Software Foundation; either version 2 of the License, or 9# (at your option) any later version. 10# 11# This program is distributed in the hope that it will be useful, 12# but WITHOUT ANY WARRANTY; without even the implied warranty of 13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14# GNU General Public License for more details. 15# 16# A copy of the GNU General Public License is available at 17# https://www.R-project.org/Licenses/ 18 19##' "Simplify" a list of commonly structured components into an array. 20##' 21##' @title simplify list() to an array if the list elements are structurally equal 22##' @param x a list, typically resulting from lapply() 23##' @param higher logical indicating if an array() of "higher rank" 24##' should be returned when appropriate, namely when all elements of 25##' \code{x} have the same \code{\link{dim}()}ension. 26##' @return x itself, or an array if the simplification "is sensible" 27simplify2array <- function(x, higher = TRUE) 28{ 29 if(!length(x)) return(x) 30 if(length(common.len <- unique(lengths(x))) > 1L) 31 return(x) 32 if(common.len == 1L) { 33 n <- length(x) 34 r <- unlist(x, recursive = FALSE) 35 if(length(r) == n) r else x 36 } 37 else if(common.len > 1L) { 38 n <- length(x) 39 ## make sure that array(*) will not call rep() {e.g. for 'call's}: 40 r <- unlist(x, recursive = FALSE, use.names = FALSE) 41 if(higher && length(c.dim <- unique(lapply(x, dim))) == 1 && 42 is.numeric(c.dim <- c.dim[[1L]]) && 43 prod(d <- c(c.dim, n)) == length(r)) { 44 45 iN1 <- is.null(n1 <- dimnames(x[[1L]])) 46 n2 <- names(x) 47 dnam <- 48 if(!(iN1 && is.null(n2))) 49 c(if(iN1) rep.int(list(n1), length(c.dim)) else n1, 50 list(n2)) ## else NULL 51 array(r, dim = d, dimnames = dnam) 52 53 } else if(prod(d <- c(common.len, n)) == length(r)) 54 array(r, dim = d, 55 dimnames = if(!(is.null(n1 <- names(x[[1L]])) & 56 is.null(n2 <- names(x)))) list(n1,n2)) 57 else x 58 } 59 else x 60} 61 62sapply <- function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) 63{ 64 FUN <- match.fun(FUN) 65 answer <- lapply(X = X, FUN = FUN, ...) 66 if(USE.NAMES && is.character(X) && is.null(names(answer))) 67 names(answer) <- X 68 if(!isFALSE(simplify)) 69 simplify2array(answer, higher = (simplify == "array")) 70 else answer 71} 72 73vapply <- function(X, FUN, FUN.VALUE, ..., USE.NAMES = TRUE) 74{ 75 FUN <- match.fun(FUN) 76 if(!is.vector(X) || is.object(X)) X <- as.list(X) 77 .Internal(vapply(X, FUN, FUN.VALUE, USE.NAMES)) 78} 79 80 81