R/wrap.R

In magclass: Data Class and Tools for Handling Spatial-Temporal Data

#' Wrap
#'
#' Reshape an array or a matrix by permuting and/or joining dimensions.
#'
#'
#' @param x An array
#' @param map A list of length equal to the number of dimensions in the
#' reshaped array. Each element should be an integer vectors specifying the
#' dimensions to be joined in corresponding new dimension. One element may
#' equal NA to indicate that that dimension should be a join of all
#' non-specified (remaining) dimensions. Default is to wrap everything into a
#' vector.
#' @param sep A character separating joined dimension names
#' @note This function is extracted from the R.utils library which is licensed
#' under LGPL>=2.1 and written by Henrik Bengtsson.
#' @author Henrik Bengtsson, Jan Philipp Dietrich
#' @seealso \code{\link{unwrap}},\code{\link{fulldim}}
#' @family MAgPIE-Conversions
#' @export
wrap <- function(x, map = list(NA), sep = ".") {
  if (!is.array(x) && !is.matrix(x))
    stop("Argument 'x' is not an array or a matrix: ", class(x)[1])
  if (!is.list(map))
    stop("Argument 'map' is not a list: ", class(map)[1])
  umap <- unlist(map)
  if (any(duplicated(umap))) {
    stop("Argument 'map' contains duplicated dimension indices: ",
         paste(umap[duplicated(umap)], collapse = ", "))
  }
  dim <- dim(x)
  ndims <- length(dim)
  missingDims <- setdiff(1:ndims, umap)
  if (length(missingDims) > 0) {
    wildcard <- is.na(map)
    if (any(wildcard)) {
      map[[which(wildcard)]] <- missingDims
      umap <- unlist(map)
    } else {
      stop("Argument 'map' miss some dimensions: ", paste(missingDims,
                                                          collapse = ", "))
    }
  }
  falseDims <- setdiff(umap, 1:ndims)
  if (length(falseDims) > 0) {
    stop("Argument 'map' contains non-existing dimensions: ",
         paste(falseDims, collapse = ", "))
  }
  if (any(diff(umap) < 0)) {
    perm <- umap
    x <- aperm(x, perm = perm)
    map <- lapply(map, FUN = function(ii) match(ii, perm))
  }
  dim <- dim(x)
  dim2 <- vapply(map, FUN = function(ii) prod(dim[ii]), numeric(1))
  dimnames <- dimnames(x)

  tmpdn <- function(map, dimnames) {
    dimnames2 <- list()
    nn <- NULL
    for (dim in seq_along(map)) {
      names <- NULL
      for (ii in map[[dim]]) {
        if (is.null(names)) {
          names <- dimnames[[ii]]
          nameNames <- names(dimnames)[ii]
        } else {
          names <- paste(names, rep(dimnames[[ii]], each = length(names)),
                         sep = sep)
          nameNames <- paste(nameNames, names(dimnames)[ii], sep = sep)
        }
      }
      dimnames2[[dim]] <- names
      nn <- c(nn, nameNames)
    }
    # Trick to set names even for NULL entries
    dimnames2[[dim + 1]] <- "fake"
    names(dimnames2) <- c(nn, "fake")
    dimnames2[[dim + 1]] <- NULL
    return(dimnames2)
  }

  dim(x) <- dim2
  dimnames <- tmpdn(map, dimnames)
  if (any(dim(x) == 0)) {
    dimnames[dim(x) == 0] <- NULL
  }
  dimnames(x) <- dimnames
  return(x)
}