fake-tribble.R

#' 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
#' @param assign character; if non-NA, then the printed string
#'   includes assignment of the tribble to this name
#' @param all_na logical, whether to append a pipe/transform to
#'   properly class a column of all NA
#' @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,
                         assign = NA, all_na = TRUE) {
  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)
  xclass <- sapply(x, function(z) class(z)[1])
  for (nm in names(isfctr)[isfctr]) x[[nm]] <- as.character(x[[nm]])
  ischar <- sapply(x, is.character)
  aligns <- ifelse(ischar, "-", "")
  allna <- sapply(x, function(z) all(is.na(z)))
  for (nm in names(ischar)[ischar]) {
    x[[nm]] <- ifelse(is.na(x[[nm]]), NA_character_, dQuote(x[[nm]], FALSE))
  }
  cellwidths <- suppressWarnings(sapply(x, function(col) max(nchar(col), na.rm = TRUE)))
  cellwidths[!is.finite(cellwidths)] <- 12 # arbitrary
  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,
    ")"
  )
  if (isTRUE(all_na) && any(allna)) {
    out[length(out)] <- ") |>"
    funs <- paste0("as.", xclass[allna])
    funs_exist <- sapply(funs,
                         function(fun) tryCatch({ match.fun(fun); TRUE; },
                                                error = function(e) FALSE))
    allna[allna] <- allna[allna] & funs_exist
    exprs <- sprintf("%s = %s(%s)", names(allna)[allna], funs, names(allna)[allna])
    exprs[-length(exprs)] <- paste0("    ", exprs[-length(exprs)], ",")
    exprs <- paste(exprs, collapse = ", ")
    out <- c(out[-length(out)], ") |>",
             paste0("  transform(", exprs, ")"))
  }
  if (!anyNA(assign)) out[1] <- paste(assign, "<-", out[1])
  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
  }
  keep_tail <- cumsum(trimws(x) %in% c(")", ") |>")) > 0
  cat(c(
    x[1],
    gsub("^", strrep(" ", indent), head(x[!keep_tail][-1], n = n)),
    if (n < length(x) - 3L) sprintf("# ... with %d more rows", length(x) - n - 3L),
    x[keep_tail]
  ), sep = sep)
}