The R Project SVN R

#  File src/library/base/R/array.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2015 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
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  A copy of the GNU General Public License is available at
#  https://www.R-project.org/Licenses/

array <-
function(data = NA, dim = length(data), dimnames = NULL)
{
    ## allow for as.vector.factor (converts to character)
    if(is.atomic(data) && !is.object(data))
        return(.Internal(array(data, dim, dimnames)))
    data <- as.vector(data)
    ## package rv has an as.vector() method which leave this as a classed list
    if(is.object(data)) {
        dim <- as.integer(dim)
        if (!length(dim)) stop("'dim' cannot be of length 0")
        vl <- prod(dim)
        if(length(data) != vl) {
            ## C code allows long vectors, but rep() does not.
            if(vl > .Machine$integer.max)
                stop("'dim' specifies too large an array")
            data <- rep_len(data, vl)
        }
        if(length(dim)) dim(data) <- dim
        if(is.list(dimnames) && length(dimnames)) dimnames(data) <- dimnames
        data
    } else .Internal(array(data, dim, dimnames))
}

slice.index <-
function(x, MARGIN)
{
    d <- dim(x)
    if(is.null(d))
        d <- length(x)
    n <- length(d)

    if(!length(MARGIN) || any(MARGIN < 1L) || any(MARGIN > n))
        stop("incorrect value for 'MARGIN'")

    if(any(d == 0L)) return(array(integer(), d))

    m <- MARGIN[1L]
    y <- rep.int(rep.int(1L:d[m],
                         prod(d[seq_len(m - 1L)]) *
                         rep.int(1L, d[m])),
                 prod(d[seq.int(from = m + 1L,
                                length.out = n - m)]))
    if(length(MARGIN) > 1L) {
        p <- d[m]
        for(m in MARGIN[-1L]) {
            y <- y + p * rep.int(rep.int(seq.int(0L, d[m] - 1L),
                                         prod(d[seq_len(m - 1L)]) *
                                         rep.int(1L, d[m])),
                                 prod(d[seq.int(from = m + 1L,
                                                length.out = n - m)]))
            p <- p * d[m]
        }
    }

    dim(y) <- d
    y
}

provideDimnames <-
function(x, sep = "", base = list(LETTERS), unique = TRUE)
{
    ## provide dimnames where missing - not copying x unnecessarily
    dx <- dim(x)
    dnx <- dimnames(x)
    if(new <- is.null(dnx))
    dnx <- vector("list", length(dx))
    k <- length(M <- lengths(base))
    for(i in which(vapply(dnx, is.null, NA))) {
    ii <- 1L+(i-1L) %% k # recycling
        ss <- seq_len(dx[i]) - 1L # dim could be zero
    bi <- base[[ii]][1L+ (ss %% M[ii])]
    dnx[[i]] <- if(unique) make.unique(bi, sep = sep) else bi
    new <- TRUE
    }
    if(new) dimnames(x) <- dnx
    x
}

## The array split part used by apply():
## (With 'X' replaced by 'x').

asplit <-
function(x, MARGIN)
 {
    ## Ensure that x is an array object
    dl <- length(dim(x))
    if(!dl) stop("dim(x) must have a positive length")
    if(is.object(x))
        x <- if(dl == 2L) as.matrix(x) else as.array(x)
    ## now record dim as coercion can change it
    ## (e.g. when a data frame contains a matrix).
    d <- dim(x)
    dn <- dimnames(x)
    ds <- seq_len(dl)
    
    ## Extract the margins and associated dimnames

    if (is.character(MARGIN)) {
        if(is.null(dnn <- names(dn))) # names(NULL) is NULL
           stop("'x' must have named dimnames")
        MARGIN <- match(MARGIN, dnn)
        if (anyNA(MARGIN))
            stop("not all elements of 'MARGIN' are names of dimensions")
    }
    s.call <- ds[-MARGIN]
    s.ans  <- ds[MARGIN]
    d.call <- d[-MARGIN]
    d.ans <- d[MARGIN]
    dn.call <- dn[-MARGIN]
    dn.ans <- dn[MARGIN]

    d2 <- prod(d.ans)
    newx <- aperm(x, c(s.call, s.ans))
    dim(newx) <- c(prod(d.call), d2)
    ans <- vector("list", d2)
    for(i in seq_len(d2)) {
        ans[[i]] <- array(newx[,i], d.call, dn.call)
    }

    array(ans, d.ans, dn.ans)
}