R/generate.R

In reactorlabs/genthat:

#' @title Test Case generator based on capture files
#'
#' @description This function works with the trace information generated by instrumented GNU-R.
#'
#' It is strictly oriented to that, please see readme for more information.
#'
#' @param root a directory containg capture information or capture file
#' @param output_dir directory where generated test cases will be saved
#' @param verbose wheater display debug output
#' @param timed whether result is dependent on time of generation
test_gen <- function(root, output_dir, timed = F, verbose=testr_options("verbose")) {
  if (verbose) {
    cat("Output:", output_dir, "\n")
    cat("Root:", root, "\n")
  }
  # input dir checks
  if (missing(root) || !file.exists(root)) {
    warning("Input dir/file doesn't exist!")
    return(invisible())
  }
  if (file.info(root)$isdir){
    all.capture <- lapply(list.files(root, recursive=TRUE, all.files = TRUE), function(x) file.path(root,x))
  } else {
    all.capture <- root
  }
  # output dir checks
  if (missing(output_dir)) stop("A output directory must be provided!");
  if (!file.exists(output_dir) || !file.info(output_dir)$isdir) dir.create(output_dir)
  if (timed)
    output_dir <- file.path(output_dir, format(Sys.time(), "%Y-%m-%d %H:%M:%S"))
  cache$output_dir <- output_dir
  # bad.arguments file to store incorrect arguments
  cache$bad_argv <- file.path(cache$output_dir, "bad_arguments");
  if (!file.exists(cache$bad_argv)
      && !file.create(cache$bad_argv))
      stop("Unable to create file: ", cache$bad_argv)
  cache$tid <- list()
  Map(function(x) { process_capture(x) }, all.capture)
  cache$tid <- NULL
  cache$output_dir <- NULL
  cache$bad_argv <- NULL
}

#' @title Manage Test Case file
#'
#' @description This function creates a test case file if one does not exist already
#' @param name directory where generated test cases will be saved
#' @seealso test_gen
ensure_file <- function(name) {

    fname <- gsub(.Platform$file.sep, "sep", name)
    # replace ::: with ___ so that we work on Windows too
    fname <- gsub(":::", "___", fname)
    # check if the folder for the function exists and create it if not
    tc.folder = file.path(cache$output_dir, fname, fsep = .Platform$file.sep)
    dir.create(tc.folder, showWarnings = FALSE)
    # get the index of the file, based on number of files in the folder (but use the cache information for it)
    cache$tid[[name]] <- ifelse(is.null(cache$tid[[name]]), 0, cache$tid[[name]] + 1)
    tc.file = file.path(tc.folder, paste("test-", cache$tid[[name]], ".R", sep=""), fsep = .Platform$file.sep)
    # the file should not exist
    if (!file.create(tc.file))
        stop("Unable to create file: ", tc.file)
    # TODO perhaps this is not needed for testthat
    write("library(testthat)\n", file = tc.file, append = TRUE)
    # write context information (the function name)
    write(paste("context(\"",name,"\")\n", sep=""), file = tc.file, append = TRUE)
    return(tc.file)
}

#' @title Process File with Closure capture information
#'
#' @description This function parses file with closure capture information and generates test cases
#' @param cap_file path to closure capture file
process_capture <- function(cap_file){
  lines <- readLines(cap_file)
  cache$i <- 1
  while (cache$i < length(lines)){
    # read test case information
    symbol.values <- read_symbol_values(lines)
    symb <- symbol.values[[1]]
    vsym <- symbol.values[[2]]
    func <- read_value(lines, kFuncPrefix)
    args <- read_value(lines, kArgsPrefix)

    tc.file <- ensure_file(func)
    feedback <- generate_tc(symb, vsym, func, args)

    #### see what we get
    if (feedback$type == "err") {
      #### the captured information is not usable
      write(feedback$msg, file=cache$bad_argv, append=TRUE);
    } else if (feedback$type == "src") {
      #### good, we get the source code
      write(feedback$msg, file=tc.file, append=TRUE);
    } else {
      stop("Not reached!");
    }
    cache$i <- cache$i + 1
  }
}


read_symbol_values <- function(lines){
  k_sym <- 1
  k_value <- 1
  symb <- vector()
  vsym <- vector()
  symb[k_sym] <- ""
  vsym[k_value] <- ""
  while (starts_with(kSymbPrefix, lines[cache$i])){
    symb[k_sym] <- paste(symb[k_sym], substr_line(lines[cache$i]), sep = "")
    cache$i <- cache$i + 1
    k_sym <- k_sym + 1
    symb[k_sym] <- ""
    vsym[k_value] <- read_value(lines, kValSPrefix)
    k_value <- k_value + 1
    vsym[k_value] <- ""
  }
  length(symb) <- length(symb) - 1
  length(vsym) <- length(vsym) - 1
  return(list(symb, vsym))
}

read_value <- function(lines, prefix){
  value <- vector()
  j <- cache$i
  while (starts_with(prefix, lines[j])){
    value <- c(value, substr_line(lines[j]))
    j <- j + 1
  }
  cache$i <- j
  return(paste(value, collapse="\n", sep=""))
}

#' @title Generates a testcase for closure function
#'
#' @description This function generates a test case for builtin function using supplied arguments. All elements should be given as text.
#' @param symb symbols to be initialized before the call
#' @param vsym values of the symbols
#' @param func function name
#' @param argv input arguments for a closure function call
#' @seealso test_gen ProcessClosure
generate_tc <- function(symb, vsym, func, argv) {
  # check validity of symbol values and construct part of the test
  invalid.symbols <- vector()
  variables <- ""
  if (length(symb) > 0 && symb[1] != ""){
    for (i in 1:length(vsym)){
      symbol <- paste(symb[i], "<-", vsym[i])
      if (!parse_eval(symbol)){
        invalid.symbols <- c(invalid.symbols, i)
      } else {
        variables <- paste(variables, symbol, "\n")
      }
    }
    if (length(invalid.symbols) != 0){
      symb <- symb[-invalid.symbols]
      vsym <- vsym[-invalid.symbols]
    }
  }
  # check validity of arguments
  valid.argv <- parse_eval(argv)

  # proper argument should always be packed in a list
  if (!valid.argv)
    return(list(type="err", msg=paste("func:", func, "\nargv:", argv, "\n")))

  # TODO: potentially good arguments, alter it
  #  argv.obj.lst <- alter.arguments(argv.obj);

  call <- ""

  args <- eval(parse(text=argv));
  if (length(args) > 0) {
    args <- lapply(args, function(x) paste(deparse(x), collapse = "\n"))
    if (!is.null(names(args)) && length(names(args)) == length(args)) {
      call.args <- ""
      arg_names <- names(args)
      for (i in 1:length(args)) {
        if (arg_names[i] != "")
          call.args <- paste(call.args, arg_names[i], "=", sep = "")
        call.args <- paste(call.args, args[[i]], ",", sep="")
      }
      call.args <- substr(call.args, 1, nchar(call.args) - 1)
      call <- paste(call, sprintf("%s(%s)", func, call.args), "\n", sep="")
    } else
      call <- paste(call, sprintf("%s(%s)", func, paste(args, collapse=",")), "\n", sep="")
  } else {
    call <- paste(call, func, "()", "\n", sep="")
  }

  if (length(symb) > 0 && symb[1] != "")
    call <- paste(variables, call, sep="")
  cache$warns <- NULL
  cache$errs <- NULL
  retv <- withCallingHandlers(tryCatch(eval(parse(text=call), envir = new.env()),
                                       error=function(e) cache$errs <- e$message, silent = TRUE),
                   warning=function(w) {
                     cache$warns <- ifelse(is.null(cache$warns), w$message, paste(cache$warns, w$message, sep="; "))
                     invokeRestart("muffleWarning")
                     })
    retv <- quoter(retv)

    # testhat formatter
    src <- paste("test_that(", shQuote(cache$tid[[func]]), ", {\n")
    if (! is.null(cache$errs)) {
        call <- paste("expect_error({\n", call, "}\n,", shQuote(cache$errs), ")")
    } else {
        src <- paste(src, "\nexpected <-", paste(deparse(retv), collapse = "\n"), "\n")
        call <- paste("expect_equal({", call, "}, expected)")
    }
    if (! is.null(cache$warns)) {
        call <- paste("expect_warning(", call, ", ", shQuote(cache$warns), ")")
    }
    src <- paste(src, call, "\n})")
    src = deparse(parse(text = src)[[1]])
    list(type="src", msg=src);
}