R/format.R

In nseval: Tools for Lazy and Non-Standard Evaluation

#' Formatting methods for dots and quotations.
#'
#' `format.dots` constructs a string representation of a dots
#' object.
#' @param x An object.
#' @param compact Implies `show.environments=FALSE` and
#'   `show.expressions=FALSE`.
#' @param show.environments Whether to show environments for unforced
#'   quotations.
#' @param show.expressions Whether to show expressions for forced
#'   quotations.
#' @param width See [base::format].
#' @rdname format
#' @export
format.dots <- function(x,
                        compact = FALSE,
                        show.environments = !compact,
                        show.expressions = !compact,
                        width = 36,
                        ...) {
  contents <- mapply(
    x,
    names(x) %||% rep("", length(x)),
    FUN=function(x, n) {
      paste0(c(
        if (is.na(n)) "<NA> = " else if (n == "") "" else c(n, " = "),
        format.quotation.inner(x,
                               compact,
                               show.environments,
                               show.expressions,
                               width)),
        collapse="")
    })

  chars <- paste0("c.dots( ",
                  paste0(contents, collapse=", "),
                  " )")

  format.default(chars, ...)
}


#' @rdname format
#' @description
#' `format.quotation` constructs a string representation of a
#' quotation object.
#' @export
format.quotation <- function(x,
                             compact = FALSE,
                             show.environments = !compact,
                             show.expressions = !compact,
                             width = 36,
                             ...) {
  chars <- format.quotation.inner(
    x, compact, show.environments, show.expressions, width = width)
  format.default(chars, ...)
}

#' @rdname format
#' @description
#' `format.oneline` formats a vector or list so that each item is
#' displayed on one line. It is similar to [format.AsIs] but tries
#' harder with language objects. The "oneline" class is used by
#' [as.data.frame.dots].
#' @export
#' @param max.width See [base::format].
#' @param ... Further parameters passed along to [base::format].
format.oneline <- function(x, max.width=50, width=max.width, ...) {
  if ("oneline" %in% class(x)) {
    class(x) <- setdiff(class(x), "oneline")
  }
  one_line(x, format_robust, width=width, max.width=max.width, ...)
}

#' @export
#' @rdname format
print.dots <- function(x, ...) {
  cat(format(x, ...), "\n")
  invisible(x)
}

#' @export
#' @rdname format
print.quotation <- function(x, ...) {
  cat(format(x, ...), "\n")
  invisible(x)
}

one_line <- function(x, f, max.width=50, width=max.width, ...) {
  if (!(is.numeric(x) || is.character(x) || is.list(x))) {
    x <- list(x)
  }
  l <- lapply(x, f)
  vapply(l, function(x) toString(
    {
      if(length(x) > 1)
        paste0(x[[1]], "...")
      else if (length(x) == 1)
        x
      else "?NULL?"
    },
    width=width),
    ""
  )
}

format_robust <- function(x, ...) {
  tryCatch(format(x, ...), error=function(e) "?FORMAT?")
}

format.name <- function(x, ...) {
  format(as.character(x))
}

oneline <- function(x) structure(x, class=union("oneline", class(x)))

format.quotation.inner <- function(x,
                                   compact = FALSE,
                                   show.environments = !compact,
                                   show.expressions = !compact,
                                   width=36) {

  doformat <- function(x) {
    if (is.language(x)) {
      c("quote(", dodeparse(x), ")")
    } else {
      one_line(x, format, width=width)
    }
  }
  dodeparse <- function(x) {
    if (is.language(x) || is.character(x) || is.list(x)) {
      deparse(x, width.cutoff=width, nlines = 1)
    } else {
      doformat(x)
    }
  }
  contents <- paste0(c(
    if(forced(x)) {
      c(if (is.language(expr(x)) && show.expressions) {
          c("forced_quo(", dodeparse(expr(x)), ", val=", dodeparse(value(x)))
        } else {
          c("forced_quo_(", dodeparse(value(x)))
        },
        ")")
    } else {
      c("quo(",
        dodeparse(expr(x)),
        if (show.environments) c(", ", doformat(env(x))),
        ")")
    }
  ), collapse="")
}