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