R/test_roclets_functions.R

In roxytest: Various Tests with 'roxygen2'

# Parse '@tests' tag
# 
# @param x A `roxy_tag` (and `roxy_tag_tests`) object
# 
#' @importFrom roxygen2 roxy_tag_warning
parse_tests_tag <- function(x) {
  if (!inherits(x, "roxy_tag_tests") || 
      !inherits(x, "roxy_tag")) {
    stop("Unexpected x")
  }
  
  if (x$raw == "") {
    return(roxygen2::roxy_tag_warning(x, "requires a value"))
  }
  
  x$val <- gsub("^\n", "", x$raw)
  
  return(x)
}

#' Parse tests tag
#' 
#' @param x Input
#' 
#' @return Parsed tag
#' 
#' @importFrom roxygen2 roxy_tag_parse
#' @export
roxy_tag_parse.roxy_tag_tests <- function(x) {
  return(parse_tests_tag(x))
}

#' @importFrom roxygen2 roxy_tag_rd
#' @export
roxy_tag_rd.roxy_tag_tests <- function(x, base_path, env) {
  NULL
}

#' @importFrom roxygen2 roxy_tag_warning
parse_testexamples_tag <- function(x) {
  if (!inherits(x, "roxy_tag_testexamples") || 
      !inherits(x, "roxy_tag")) {
    stop("Unexpected x")
  }
  
  if (x$raw == "") {
    return(roxygen2::roxy_tag_warning(x, "requires a value"))
  }

  x$val <- gsub("^\n", "", x$raw)
  
  return(x)
}

#' Parse testexamples tag
#' 
#' @param x Input
#' 
#' @return Parsed tag
#' 
#' @importFrom roxygen2 roxy_tag_parse
#' @export
roxy_tag_parse.roxy_tag_testexamples <- function(x) {
  return(parse_testexamples_tag(x))
}

#' @importFrom roxygen2 roxy_tag_rd
#' @export
roxy_tag_rd.roxy_tag_testexamples <- function(x, base_path, env) {
  NULL
}

#' @importFrom roxygen2 block_get_tags
block_to_testthat <- function(block) {
  testthat_file <- list()
  
  tests <- roxygen2::block_get_tags(block, "tests")
  testexamples <- roxygen2::block_get_tags(block, "testexamples")
  
  if (length(tests) == 0L && length(testexamples) == 0L) {
    return(NULL)
  }
  
  testthat_file$tests <- tests
  testthat_file$testexamples <- testexamples
  testthat_file$examples <- roxygen2::block_get_tags(block, "examples")
  
  filename <- basename(block$file)
  
  testthat_file$filename <- filename
  
  testthat_file$functionname <- 
    if (!is.null(block$object) && !is.null(block$object$alias)) {
      paste0('Function ', auto_quote(block$object$alias), '()')
    } else {
      "[unknown alias]"
    }
  
  if (!is.null(block$line)) {
    testthat_file$functionname <- paste0(testthat_file$functionname, ' @ L', block$line)
  }
  
  return(testthat_file)
}

indent_text <- function(x) {
  paste0("  ", gsub("\n", "\n  ", x, fixed = TRUE))
}

prepare_tests <- function(x) {
  gsub("^\\s*(.*?)\\s*$", "\\1", x)
}

# FIXME: Refactor process_testfiles() and process_testexamplesfiles()

process_testfiles <- function(testfiles, 
                              indent_code = FALSE,
                              add_testthat_boilerplate = FALSE,
                              add_context_header = FALSE,
                              ...) {
  if (length(testfiles) == 0L ) {
    return(list())
  }
  
  paths <- names(testfiles)
  
  results <- lapply(seq_along(testfiles), function(i) {
    testfile <- testfiles[[i]]
    
    content <- lapply(testfile, function(x) {
      tests <- lapply(x$tests, function(l) l$val)
      tests <- prepare_tests(tests)
      
      if (indent_code) {
        tests <- indent_text(tests) 
      }
      
      tests_name <- x$functionname
      
      res <- if (add_testthat_boilerplate) {
        paste0('test_that("', tests_name, '", {', "\n", 
               tests, "\n",
               "})\n")
      } else {
        paste0("## ", tests_name, "\n", 
               tests, "\n")
      }
      
      return(res)
    })
    
    content <- paste0(content, collapse = "\n\n")
    
    path_quoted <- if (paths[i] == "<text>") {
      path_quoted <- paths[i]
    } else {
      path_quoted <- paste0('File R/', auto_quote(paths[i]), ': @tests')
    }
    
    content_header <- paste0("# Generated by roxytest: do not edit by hand!\n\n")
    
    content_header <- if (add_context_header) {
      paste0(content_header, 
             'context("', path_quoted, '")', "\n\n")
    } else {
      paste0(content_header, 
             "# ", path_quoted, "\n\n")
    }

    content <- paste0(content_header, content)
    
    return(content)
  })
  
  names(results) <- paths
  
  return(results)
}

# \dontrun: Everything is removed
# \donttest: Only tags '\donttest{' and '}' are removed
# \dontshow: Only tags '\dontshow{' and '}' are removed
remove_donts <- function(example) {
  # Remove content in \donttest{} and \dontrun{}
  # https://github.com/mikldk/roxytest/issues/12
  #example <- gsub("\\\\donttest\\{[^}]*?\\}", "", example)
  #example <- gsub("\\\\dontrun\\{[^}]*?\\}", "", example)

  patrn <- '(\\{((?>[^{}]+|(?1))*)\\})'

  # Remove all
  if (grepl('\\dontrun', example, fixed = TRUE)) {
    example <- gsub(paste0("\\\\dontrun", patrn), "", example, perl = TRUE)
  }
  
  # Only remove tag:
  if (grepl('\\donttest', example, fixed = TRUE)) {
    example <- gsub(paste0("\\\\donttest", patrn, ""), "\\2", example, perl = TRUE)
  }
  
  # Only remove tag:
  if (grepl('\\dontshow', example, fixed = TRUE)) {
    example <- gsub(paste0("\\\\dontshow", patrn), "\\2", example, perl = TRUE)
  }
  
  return(example)
}

process_testexamplesfiles <- function(testfiles, 
                                      indent_code = FALSE,
                                      add_testthat_boilerplate = FALSE,
                                      add_context_header = FALSE,
                                      ...) {
  if (length(testfiles) == 0L ) {
    return(list())
  }
  
  paths <- names(testfiles)
  
  results <- lapply(seq_along(testfiles), function(i) {
    testfile <- testfiles[[i]]
    
    content <- lapply(testfile, function(x) {
      examples <- lapply(x$examples, function(l) l$raw)
      examples <- lapply(examples, remove_donts)

      tests <- lapply(x$testexamples, function(l) l$val)
      tests <- prepare_tests(tests)
      
      if (indent_code) {
        examples <- indent_text(examples)
        tests <- indent_text(tests) 
      }
      
      tests_name <- x$functionname
      
      res <- if (add_testthat_boilerplate) {
        paste0('test_that("', tests_name, '", {', "\n", 
               examples, "\n",
               tests, "\n",
               "})\n")
      } else {
        paste0("## ", tests_name, "\n", 
               examples, "\n",
               tests, "\n")
      }
      
      return(res)
    })
    
    content <- paste0(content, collapse = "\n\n")
    
    path_quoted <- if (paths[i] == "<text>") {
      path_quoted <- paths[i]
    } else {
      path_quoted <- paste0('File R/', auto_quote(paths[i]), ': @testexamples')
    }
    
    content_header <- paste0("# Generated by roxytest: do not edit by hand!\n\n")
    
    content_header <- if (add_context_header) {
      paste0(content_header, 
             'context("', path_quoted, '")', "\n\n")
    } else {
      paste0(content_header, 
             "# ", path_quoted, "\n\n")
    }
    
    content <- paste0(content_header, content)
    
    return(content)
  })
  
  names(results) <- paths
  
  return(results)
}

# Process test roclet
internal_tests_roclet_process <- function(blocks, ...) {
  
  blocks <- collect_annotate_rdname(blocks)
  
  testfiles <- list()
  testexamplesfiles <- list()
  
  for (block in blocks) {
    testthat <- block_to_testthat(block)

    if (is.null(testthat$filename)) {
      next
    }
    
    if (length(testthat$tests) > 0L) {
      testfiles[[testthat$filename]] <- c(testfiles[[testthat$filename]], 
                                          list(testthat))
    }
    
    if (length(testthat$testexamples) > 0L) {
      testexamplesfiles[[testthat$filename]] <- c(testexamplesfiles[[testthat$filename]], 
                                                  list(testthat))
    }
  }


  ######################################
  results <- list()
  
  results$tests <- process_testfiles(testfiles, ...)
  results$testexamples <- process_testexamplesfiles(testexamplesfiles, ...)

  return(results)
}

# Has side-effects: writes files to disk
internal_tests_roclet_output <- function(results, base_path, prefix = "test-roxytest-tests-") {
  paths <- names(results)
  
  for (i in seq_along(results)) {    
    path <- file.path(base_path, paste0(prefix, paths[i]))
    
    if (!made_by_roxytest(path)) {
      warning(paste0("The file '", path, "' was not created by roxytest (wrong header), ", 
                     "and hence was not modified as planned. ",
                     "Please be sure that this is intended."))
      next
    }
    
    content <- results[[i]]
    
    writeLines(text = enc2utf8(content), 
               con = path, 
               useBytes = TRUE)
  }
  
  return(paths)
}

# Has side-effects: deletes files on disk
internal_tests_roclet_clean <- function(testfiles) {
  testfiles <- testfiles[!file.info(testfiles)$isdir]
  
  made_by_me <- vapply(testfiles, made_by_roxytest, logical(1))
  
  if (sum(!made_by_me) > 0) {
    warning(paste0("Clean-up: Some files in tests/testthat/ with the file name pattern ", 
                   "test-roxytest-*.R was not created by roxytest (missing header), ", 
                   "and hence was not removed. ",
                   "Please be sure that this is intended."))
  }
  
  unlink(testfiles[made_by_me])
}