R/methods.R

In strboul/paste.output: 'RStudio' Addin for pasting output and tests into the editor

### ----------------------------------------------------------------- ###
### Paste output ----
### ----------------------------------------------------------------- ###

#' Tests
#' 
#' @param type The name of the test as a \code{character}.
#' @param expr (a valid) R expression as a character vector with a length of
#'   one.
#' 
#' @section Public methods:
#' 
#' \itemize{
#' 
#' \item \code{initialize} checks argument types and register in the public
#' fields.
#' 
#' }
#' 
#' @section Private methods: 
#' 
#' \itemize{
#' 
#' \item \code{expect_} , \code{error}, \code{warning} and \code{message} have
#' similar structure because they are considered as \emph{conditions} in R.
#' 
#' \item \code{expect_s3_class} is in \sQuote{inheritance-expectations}
#' category.
#' 
#' }
#' 
#' @details 
#' All methods are evaluated once before pasting to check if it is valid R
#' expression. Unless it is the case, the pasting process continues but throws
#' an explanatory warning.
#'
#' This behavior is especially useful for the testthat methods e.g. when an
#' expression produced no error or no output.
#' 
NULL

### ----------------------------------------------------------------- ###
### Tests ----
### ----------------------------------------------------------------- ###

R6::R6Class(
  classname = "testthat",
  public = list(
    
    expr = NULL,
    cond.msg = NULL,
    test.name = NULL,
    
    initialize = function(expr) {
      stop_if_pkg_not_installed("testthat")
      is_valid_expression(expr)
      self$expr <- expr
    },
  
    # methods (condition specific):
    expect_error = function() {
      self$test.name <- "expect_error"
      private$condition()
    },
    
    expect_warning = function() {
      self$test.name <- "expect_warning"
      private$condition()
    },
    
    expect_message = function() {
      self$test.name <- "expect_message"
      private$condition()
    },
    
    expect_output = function() {
      self$test.name <- "expect_output"
      private$condition()
    },
    
    # methods:
    
    expect_equal = function() {
      res <- utils::capture.output(dput(eval(self$expr)))
      sprintf("%s(%s, %s)", "expect_equal", self$expr, res)
    },
    
    expect_s3_class = function() {
      res <- utils::capture.output(dput(class(eval(self$expr))))
      sprintf("%s(%s, %s)", "expect_s3_class", self$expr, res)
    }
    
  ),
  private = list(
    
    condition = function() {
      switch (
        self$test.name,
        "expect_error" = {
          tryCatch(eval(self$expr), error = function(e) e)
        },
        "expect_warning" = {
          tryCatch(eval(self$expr), warning = function(w) w)  
        },
        "expect_message" = {
          tryCatch(eval(self$expr), message = function(m) m)  
        }
      ) -> cond
      
      
      tnsame <- private$construct_test_name(ns = TRUE)
      if (is_valid_result(tnsame)) {
        cond.msg <- conditionMessage(cond)
        cond.msg <- private$escape_regexps(cond.msg)
        self$cond.msg <- cond.msg
        private$construct_test_name(regexp.arg = TRUE)
      } else {
        private$construct_test_name()
      }
    },
    
    escape_regexps = function(cond.msg) {
      stopifnot(is.character(cond.msg))
      # escape regexp characters (e.g. parentheses):
      p.escp <- gsub("(\\(|\\))", "\\\\\\1", cond.msg, perl = TRUE)
      p.escp
    },
    
    #' Test name for testthat
    #' 
    #' @param ns should namespace be added?
    #' @param regexp.arg regexp arg from \code{\link[testthat]{expect_condition}}
    #' @details Both ns and regexp.arg cannot be TRUE.
    #' @noRd
    construct_test_name = function(ns = FALSE, regexp.arg = FALSE) {
      stopifnot(!(ns && regexp.arg))
      if (ns) {
        sprintf("%s::%s(%s)", "testthat", self$test.name, self$expr)
      } else {
        if (regexp.arg) {
          sprintf("%s(%s, regexp = \"%s\")", self$test.name, self$expr, self$cond.msg)
        } else {
          sprintf("%s(%s)", self$test.name, self$expr)
        }
      }
      
    }
    
  )
) -> testthat

### ----------------------------------------------------------------- ###
### RStudio API ----
### ----------------------------------------------------------------- ###

#' Capture selection and paste
#' 
#' @importFrom rstudioapi modifyRange insertText getActiveDocumentContext documentSave
#' @importFrom utils capture.output
NULL

R6::R6Class(
  
  classname = "CapturePaste",
  
  public = list(
    
    initialize = function(call.name) {
      selected <- private$get_selection_context()
      if (!is.null(selected[["details"]])) {
        
        expr <- as.expression(selected[["details"]][["text"]])
        testthat <- testthat$new(E)
        
        output <- testthat[[call.name]]()
        
        if (!is.null(output)) {
          private$paste_editor(selected, output)
          if (getOption("paste.output.save.paste")) {
            private$save_current_file(selected)
          }
        }
      }
    }
  ),
  private = list(
    
    save_current_file = function(context) {
      
      if (!context[["path"]] == "") {
        rstudioapi::documentSave(context[["id"]])
      }
      
    },
    
    paste_editor = function(actual, modified) {
      
      rstudioapi::modifyRange(
        id = actual[["details"]][["id"]],
        location = actual[["details"]][["range"]],
        text = ""
      )
      
      rstudioapi::insertText(
        id = actual[["details"]][["id"]],
        location = actual[["details"]][["range"]],
        text = paste(modified, collapse = "")
      )
      
    },
    
    get_selection_context = function() {
      
      context <- rstudioapi::getActiveDocumentContext()
      selection <- context[["selection"]]
      
      lapply(selection, function(s) {
        
        start <- s[["range"]][["start"]]
        end <- s[["range"]][["end"]]
        if (!identical(s[["text"]], "") && !identical(start, end)) {
          c(range = list(s[["range"]]), text = s[["text"]])
        } else {
          cat(paste("paste.output:", "select in the editor..."), sep = "\n")
          invisible(NULL)
        }
        
      }) -> details
      
      c(id = context[["id"]], path = context[["path"]], details = details)
    }
    
  )
) -> CapturePaste

### ----------------------------------------------------------------- ###
### Utils ----
### ----------------------------------------------------------------- ###

#' Stop wrapper without displaying the call message
#' @noRd
stopcf <- function(...) {
  stop(..., call. = FALSE)
}

#' #' Warning wrapper without displaying the call message
#' #' @noRd
#' warningcf <- function(...) {
#'   warning(..., call. = FALSE)
#' }

#' Is valid expression?
#' @noRd
is_valid_expression <- function(x) {
  if (is.expression(x)) {
    if (identical(length(x), 1L)) {
      TRUE
    } else {
      FALSE
    }
  } else {
    FALSE
  }
}

#' @importFrom utils installed.packages
#' @noRd
stop_if_pkg_not_installed <- function(pkg.name) {
  stopifnot(is.character(pkg.name))
  if (!pkg.name %in% rownames(utils::installed.packages())) {
    stopcf(pkg.name, " package not found in the libraries.")
  }
}

#' Is the constructed test a valid result?
#' 
#' @param x character string as a text body.
#' @return a logical value \code{TRUE} or \code{FALSE}.
#' @details As a side effect, prints a warning message.
#' @noRd
is_valid_result <- function(x) {
  stopifnot(is.character(x))
  
  p <- tryCatch(eval(parse(text = x)), error = function(e) e)
  
  if ("expectation_failure" %in% class(p)) {
    exp_fail_message(p[["message"]])
    FALSE
  } else {
    TRUE
  }
}

#' Produce expectation fail output
#' 
#' @param message expectation message.
#' @param info information message to send as an output.
#' @details Only creates a side effect outputing message to console. The message
#'   includes ASCII escape sequences (yellow color).
#' @noRd
exp_fail_message <- function(message = NULL, info) {
  if (getOption("paste.output.verbose")) {
    default <- "There're some issues but pasting anyway..."
    msg <- if (!missing(info)) info else default
    cat(
      sprintf(
        "\033[33m%s: %s\033[39m\n%s", 
        "paste.output", 
        msg,
        message
      ),
      sep = "\n")
  }
}