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-2026 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)

    ## Extract the margins and associated dimnames

    if (is.character(MARGIN)) {

        dn <- dimnames(x)

        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")

    }

    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,

         use.names = FALSE)

{

    ## provide dimnames and optionally names(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(use.names && !is.null(nbase <- names(base)) && # no names() or *some* non-"" names:

       (is.null(ndnx <- names(dnx)) || length(i <- which(!nzchar(ndnx))))) {

        nbi <- if(is.null(ndnx)) rep_len(nbase, length(dx))

               else nbase[1L + (i-1L) %% k]

        if(unique)

            nbi <- make.unique(nbi, sep = sep)

        names(dnx) <- if(is.null(ndnx)) nbi

                      else `[<-`(ndnx, i, nbi)

        new <- TRUE

    }

    if(new) dimnames(x) <- dnx

    x

}

## The array split part used by apply() { ./apply.R }

## (With 'X' replaced by 'x').

asplit <-

function(x, MARGIN, drop = FALSE)

{

    ## 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")

    }

    d.call <- d[-MARGIN]

    d.ans  <- d[ MARGIN]

    if (anyNA(d.call) || anyNA(d.ans))

        stop("'MARGIN' does not match dim(X)")

    s.call <- ds[-MARGIN]

    s.ans  <- ds[ MARGIN]

    dn.call <- dn[-MARGIN]

    dn.ans  <- dn[ MARGIN]

    dimnames(x) <- NULL

    .Internal(asplit(aperm(x, c(s.call, s.ans)),

                     d.ans, d.call, dn.ans, dn.call,

                     prod(d.call), prod(d.ans),

                     as.logical(drop)))

}

## Convert to data frame, mainly for list arrays produced by tapply()

array2DF <-

function (x, responseName = "Value", sep = "",

          base = list(LETTERS),

          simplify = TRUE, allowLong = TRUE)

{

    .df_helper <- function(x) # for data frames

    {

        ## check whether all components of list array 'x'

        ## - are data frames

        ## - have same column names

        ## If TRUE, return value is a vector of corresponding nrow()-s

        ## If FALSE, return value is integer(0)

        if (!is.list(x)) return(integer(0))

        if (!all(vapply(x, inherits, TRUE, "data.frame"))) return(integer(0))

        if (length(unique(vapply(x, ncol, 1L))) > 1L) return(integer(0))

        if (length(unique(lapply(x, colnames))) > 1L) return(integer(0))

        return(vapply(x, nrow, 1L))

    }

    .unvec_helper <- function(x) # for unnamed vectors

    {

        ## check whether all components of list array 'x'

        ## - are atomic vectors

        ## - have no names

        ## If TRUE, return value is a vector of corresponding nrow()-s

        ## If FALSE, return value is integer(0)

        if (!is.list(x)) return(integer(0))

        if (!all(vapply(x, is.atomic, TRUE))) return(integer(0))

        if (!all(vapply(x, function(v) is.null(names(v)), TRUE))) return(integer(0))

        return(vapply(x, length, 1L))

    }

    keys <-

        do.call(expand.grid,

                c(dimnames(provideDimnames(x, sep = sep, base = base)),

                  KEEP.OUT.ATTRS = FALSE, stringsAsFactors = FALSE))

    vals <- NULL

    if(simplify) {

        ## handle data frames with identical colnames

        dfrows <- .df_helper(x)

        if (length(dfrows))

            return(cbind(keys[ rep(seq_along(dfrows), dfrows), , drop = FALSE],

                         do.call(rbind, x)))

        ## handle unnamed vectors

        if (allowLong) {

            unvecrows <- .unvec_helper(x)

            if (length(unvecrows))

                return(cbind(keys[ rep(seq_along(unvecrows), unvecrows), , drop = FALSE],

                             structure(data.frame(V = do.call(c, x)),

                                       names = responseName)))

        }

        ## handle generic case

        x <- simplify2array(c(x))

        if(is.array(x)) {

            vals <- asplit(x, 1L)

            if(is.null(names(vals)))

                names(vals) <-

                    paste0(responseName, sep, seq_along(vals))

        }

    }

    if(is.null(vals)) {

        vals <- list(c(x))

        names(vals) <- responseName

    }

    cbind(keys, list2DF(vals))

}