Skip to content

Instantly share code, notes, and snippets.

@r2evans

r2evans/fake-tribble.R

Last active Sep 4, 2020
Embed
What would you like to do?
#' Programmatically produce row-independent `tribble`s
#'
#' @param x data.frame
#' @param max_width integer, the widest normalized width; if data or a
#' header is longer than this, it will not be truncated, but it will
#' also not be aligned with the others; can be single number (for
#' all) or a vector (for each column)
#' @param collapse character, the separation text, defaults to `", "`
#' @param compact logical, "no undue spaces"; if `TRUE` then sets
#' `max_width=0`, `collapse=","`, and disallows prepending
#' (aligning) space on the header row
#' @return character vector, printing (`cat`ing) to a copyable block
#' @md
#' @examples
#' dat <- head(iris, n = 10)
#' iris10 <- fake_tribble(dat)
#' iris10
#' print(iris10, n = 3, indent = 10)
#' # can be parsed directly into an actual tibble
#' eval(parse(text = iris10))
#'
#' iris10narrow <- fake_tribble(head(iris, n = 10), compact = TRUE)
#' iris10narrow
#' # can override indentation of compact fake_tribble
#' print(iris10narrow, n = 3, indent = 4)
fake_tribble <- function(x, max_width = NA, collapse = ", ", compact = FALSE) {
if (compact) {
if (missing(max_width)) max_width <- 0
if (missing(collapse)) collapse = ","
}
nr <- nrow(x)
nc <- ncol(x)
cnames <- paste0("~", colnames(x))
cwidths <- nchar(cnames)
isfctr <- sapply(x, is.factor)
for (nm in names(isfctr)[isfctr]) x[[nm]] <- as.character(x[[nm]])
ischar <- sapply(x, is.character)
aligns <- ifelse(ischar, "-", "")
for (nm in names(ischar)[ischar]) x[[nm]] <- dQuote(x[[nm]])
cellwidths <- sapply(x, function(col) max(nchar(col), na.rm = TRUE))
colwidths <- pmax(cwidths, cellwidths)
if (length(max_width) == 1) max_width <- rep(max_width, nc)
if (length(max_width) != nc) stop("'max_width' must be 1 or number of columns")
if (! any(is.na(max_width))) colwidths <- pmin(max_width, colwidths)
outheader <- paste(if (! compact) strrep(" ", nchar(collapse)),
paste(mapply(sprintf, paste0("%", aligns, colwidths, "s"), cnames),
collapse = collapse),
sep = "")
outbody <- sapply(
seq_len(nr),
function(i) paste(mapply(sprintf, paste0("%", aligns, colwidths, "s"), unlist(x[i,,drop=TRUE])),
collapse = collapse)
)
outbody <- gsub("^", collapse, outbody)
out <- c(
"tibble::tribble(",
outheader,
outbody,
")"
)
attr(out, "compact") <- compact
class(out) <- c("fake_tribble", "character")
out
}
#' Print method for fake_tribble
#'
#' @param x character vector of class "fake_tribble", produced by
#' `fake_tribble()`
#' @param ... other arguments, ignored
#' @param indent integer, number of spaces to prepend all header and
#' body rows; the first and last (parenthetic) rows are not indented
#' @param n integer, number of body rows to print; default set to 50
#' @param sep character, newline character(s) to place between
#' @return nothing (`NULL`)
#' @md
print.fake_tribble <- function(x, ..., indent = 2, n = 50, sep = "\n") {
compact <- attr(x, "compact")
if (compact) {
if (missing(indent)) indent <- 0
}
cat(c(
x[1],
gsub("^", strrep(" ", indent), head(x[-c(1L, length(x))], n = n + 1L)),
if (n < length(x) - 3L) sprintf("# ... with %d more rows", length(x) - n - 3L),
tail(x, n = 1)
), sep = sep)
}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment