R/deparse.R

In brodieG/unitizer: Interactive R Unit Tests

# Copyright (C) Brodie Gaslam
#
# This file is part of "unitizer - Interactive R Unit Tests"
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# Go to <https://www.r-project.org/Licenses/GPL-2> for a copy of the license.

# Returns a Character Function Name From A Language Object
#
# Note this doesn't really try to check too hard whether the \code{`x`} is
# indeed a function.
#
# @param x a call or a symbol
# @return character 1 length if a function name, NA if an anonymous function, or
#   character(0L) if neither

deparse_fun <- function(x) {
  if(is.symbol(x)) {
    as.character(x)
  } else if (is.call(x)) {
    NA_character_
  } else {
    character(0L)
  }
}
# Deparse, But Make It Look Like It Would On Prompt
#
# @return character vector

deparse_prompt <- function(item) {
  prompt <- getOption("prompt")
  continue <- getOption("continue")
  pad.len <- max(nchar(c(prompt, continue)))

  # We don't have the reference all available, and we can't parse/deparse due to
  # roundtrip issues with e.g. encodings.
  expr.deparsed <- if(item@reference) {
    unlist(strsplit(item@call.dep, "\n"))
  } else {
    deparse(item@call, width.cutoff=min(60L, (getOption("width") - pad.len)))
  }
  if(length(expr.deparsed) < 1L) {
    # nocov start
    stop("Internal Error: don't know what to do with zero length expr")
    # nocov end
  }
  prompt.vec <- c(prompt, rep(continue, length(expr.deparsed) - 1L))
  paste0(prompt.vec, expr.deparsed)
}
# Remove any comment attributes
#
# Used by the internal deparse functions.  Really removes all attributes.
# Resorting to desperate measures due to the reference like behavior of
# expressions and messing with their attributes, most likely due to the
# srcref style environment attributes.

uncomment <- function(lang) {
  if(is.expression(lang)) {
    # should be a call or symbol or constant, not an expression
    # nocov start
    stop("Internal Error: unexpected expression; contact maintainer")
    # nocov end
  }
  lang.new <- if(!(missing(lang) || is.null(lang)))
   `attr<-`(lang, "comment", NULL) else lang
  if(is.call(lang.new) && length(lang.new) > 1)
    for(i in seq_along(lang.new)) {
      lang.tmp <- lang.new[[i]]
      if(!(missing(lang.tmp) || is.null(lang.tmp)))
        lang.new[[i]] <- Recall(lang.tmp)
    }
  lang.new
}
# Deparse, but only provide first X characters
#
# @param expr a language object
# @param len int a one length integer noting how many characters we want
# @param width passed on to

deparse_peek <- function(expr, len, width=500L) {
  if(!is.integer(len) || length(len) != 1L || len < 4L)
    stop("Argument `len` must be an integer greater than four")
  if(!is.integer(width) || length(width) != 1L || width < 1L)
    stop("Argument `width` must be an integer greater than zero")
  chr <- paste0(sub("\n", " ", deparse(uncomment(expr), width)), collapse="")
  if(nchar(chr) > len) {
    paste0(substr(chr, 1L, len -3L), "...")
  } else {
    chr
  }
}
# Used to generate character values to store in cached deparse list
#
# @param expr language to deparse
# @return character(1L)

deparse_call <- function(expr) paste0(deparse(uncomment(expr)), collapse="\n")

# Special Deparse
#
# Required to deal with language objects that contain non-language objects
# that have attributes.
#
# Not completely fool proof since you can probably created an object that nests
# call and non-call stuff repeatedly that would confuse this thing.
#
# This is just used to generate objects for tests, not actually part of
# \code{unitizer} proper

deparse_mixed <- function(expr, width.cutoff = 500L, control = "all", ...) {

  rec_lang <- function(expr) {
    if(!is.language(expr))
      stop("Internal Error: expecting language object")  # nocov
    if(length(expr) > 1L) {
      for(i in seq_along(expr)) {
        if(!is.language(expr[[i]])) {
          expr[[i]] <-
            parse(
              text=deparse(expr[[i]], width.cutoff, control, ...),
              keep.source=FALSE
            )[[1L]]
        } else expr[[i]] <- Recall(expr[[i]])
    } }
    expr
  }
  rec_norm <- function(expr) {
    if(is.recursive(expr) && !is.environment(expr)) {
      for(i in seq_along(expr)) {
        if(is.language(expr[[i]])) {
          expr[[i]] <- rec_lang(expr[[i]])
        } else {
          expr[[i]] <- Recall(expr[[i]])
    } } }
    expr
  }
  deparse(rec_norm(expr), width.cutoff=width.cutoff, control=control, ...)
}