Skip to content

Instantly share code, notes, and snippets.

@r2evans

r2evans/wrap_frame.R

Last active Oct 5, 2018
Embed
What would you like to do?
#' Wrap a frame across multiple columns
#'
#' https://stackoverflow.com/a/52669757/3358272
#' @param x `data.frame`
#' @param nr,nc `integer`; specify only one of these, the number of
#' rows or columns to be fixed
#' @param rownames if `NULL` (default), row names (if found) are
#' discarded; if `character`, then a column is added (on the left of
#' `x`) with this as its title
#' @param byrow `logical`; if `FALSE`, the first column will match the
#' first `nr` rows of `x`; if `TRUE`, then the first `nc` rows of
#' `x` will be in the first row; see Examples
#' @param sep `character`; used for the column names, where the
#' resulting column names will be the original column name appended
#' with this string and the n-th column-set; see Examples
#' @param unique_names `logical`; if `TRUE` (default), then the names
#' are all "legal" column names in R; if `FALSE`, then the names do
#' not ensure uniqueness and are therefore more pleasing
#' aesthetically but more difficult to use in follow-on R functions
#' @return `data.frame`
#' @export
#' @md
#' @examples
#' \dontrun{
#' mt <- mtcars[1:3]
#' wrap_frame(mt, nr = 10)
#' wrap_frame(mt, nc = 7)
#' wrap_frame(mt, nc = 7, byrow = TRUE)
#' wrap_frame(mt, nc = 3, unique_names = FALSE, rownames = "")
#' }
wrap_frame <- function(x, nr, nc, rownames = NULL, byrow = FALSE, sep = "_", unique_names = TRUE) {
if (!xor(missing(nr), missing(nc))) stop("specify exactly one of 'nr' or 'nc'")
has_rownames <- isTRUE(is.character(attr(x, "row.names")))
if (is.null(rownames)) {
if (missing(rownames) && has_rownames) warning("wrap_frame: row names discarded", call. = FALSE)
} else {
x <- cbind.data.frame(list(row.names(x)), x)
colnames(x)[1] <- rownames
}
if (missing(nr)) {
nr <- ceiling(nrow(x) / nc)
ind <- c(rep(seq_len(nc), times = nrow(x) %/% nc),
head(seq_len(nc), n = nrow(x) %% nc))
} else {
nc <- ceiling(nrow(x) / nr)
ind <- c(rep(seq_len(nrow(x) %/% nr), times = nr),
rep(nc, nrow(x) %% nr))
}
if (!byrow) ind <- sort(ind)
lst <- split(x, ind)
lst <- lapply(lst, lapply, `length<-`, nrow(lst[[1]]))
cnames <-
if (unique_names) {
paste(rep(colnames(x), times = nc), rep(seq_len(nc), each = ncol(x)), sep = sep)
} else {
rep(colnames(x), times = nc)
}
out <- do.call("cbind.data.frame", lst)
colnames(out) <- cnames
out
}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment