R/create_new_function.R

In tidylab/tidylab.deployment: Deploy and Support a Standard 'Tidylab' Project

# create_new_function ----------------------------------------------------------
#
#' @title Create a Set of Tests and R Function Skeletons
#'
#' @description Given a function \code{name} when \code{create_new_function} is
#'   called, then a function skeleton is creates and its selected
#'   \code{test_types} tests.
#'
#' @details Choosing where to store the function and unit-test scripts is done
#'   in a manner that:
#'
#' 1. If \code{.project$path_functions} and \code{.project$path_tests} exist,
#' the function stores them there, i.e.
#'   * \code{.project$path_functions/<function-name>.R} and
#'   * \code{.project$path_tests/testthat/test-<function-name>.R}.
#' 2. Otherwise, it stores them in a package strucrue default, i.e.:
#'   * \code{./R/<function-name>.R} and
#'   * \code{./tests/testthat/test-<function-name>.R}.
#'
#' @param name (`character`) The function name without "\code{.R}".
#' @inheritParams setup
#' @param test_types (`character`) The test type. At leatst one of \code{none,
#'   unit, component, integration, all}.
#'
#' @return `NULL`. The function creates two scripts and saves them in the
#'   function and tests folders.
#' @export
#'
#' @examples
#' \dontrun{
#' create_new_function("get_pasta")
#' }
#'
# nocov start
create_new_function <- function(name, path = getwd(), test_types = "unit"){
    is_a_non_empty_string <- function(x) is.character(x) & length(x) == 1 & nchar(x) > 0
    stopifnot(isFALSE(missing(name)), is_a_non_empty_string(name))
    test_types <- match.arg(tolower(test_types),
                            c("none", "unit", "component", "integration", "all"),
                            several.ok = TRUE)

    function_target_path <- file.path(.get_target_functions_dir(path), paste0(name, ".R"))
    unittest_target_path <- file.path(.get_target_tests_dir(path), "testthat", paste0("test-", name, ".R"))
    component_target_path <- file.path(.get_target_tests_dir(path), "component-tests", paste0("test-", name, ".R"))
    integration_target_path <- file.path(.get_target_tests_dir(path), "integration-tests", paste0("test-", name, ".R"))

    if(file.exists(function_target_path) | file.exists(unittest_target_path))
        stop("A function with the same name already exists.")

    function_template_code <- .read_function_template()
    function_template_code <- gsub("foo", name, function_template_code)
    .write_to_target(text = function_template_code, con = function_target_path)
    # if(base::interactive()) fs::file_show(function_target_path)

    if(any(c("unit", "all") %in% test_types)){
        unittest_template_code <- .read_unittest_template()
        unittest_template_code <- gsub("foo", name, unittest_template_code)
        .write_to_target(text = unittest_template_code, con = unittest_target_path)
        # if(base::interactive()) fs::file_show(unittest_target_path)
    }

    if(any(c("component", "all") %in% test_types)){
        component_template_code <- .read_component_template()
        component_template_code <- gsub("dummy", name, component_template_code)
        .write_to_target(text = component_template_code, con = component_target_path)
        # if(base::interactive()) fs::file_show(component_target_path)
    }

    if(any(c("integration", "all") %in% test_types)){
        integration_template_code <- .read_integration_template()
        integration_template_code <- gsub("dummy", name, integration_template_code)
        .write_to_target(text = integration_template_code, con = integration_target_path)
        # if(base::interactive()) fs::file_show(integration_target_path)
    }

    return(invisible())
}

# Helper Functions --------------------------------------------------------
.get_target_functions_dir <- function(path){
    path_functions <- getProject("path_functions")
    if(is.null(path_functions)) return(file.path(path, "R")) else return(path_functions)
}

.get_target_tests_dir <- function(path){
    path_tests <- getProject("path_tests")
    if(is.null(path_tests)) {
        return(file.path(path, "tests"))
    } else {
        return(file.path(path_tests))
    }
}

.read_function_template <- function(){
    file_path <- base::system.file("templates", "package-boilerplate", "R", "foo.R",
                                   package = "tidylab.deployment", mustWork = TRUE)
    return(paste0(readLines(file_path), collapse = "\n"))
}

.read_unittest_template <- function(){
    file_path <- base::system.file("templates", "package-boilerplate", "tests", "testthat", "test-foo.R",
                                   package = "tidylab.deployment", mustWork = TRUE)
    return(paste0(readLines(file_path), collapse = "\n"))
}

.read_component_template <- function(){
    file_path <- base::system.file("templates", "package-boilerplate", "tests", "component-tests", "test-dummy.R",
                                   package = "tidylab.deployment", mustWork = TRUE)
    return(paste0(readLines(file_path), collapse = "\n"))
}

.read_integration_template <- function(){
    file_path <- base::system.file("templates", "package-boilerplate", "tests", "integration-tests", "test-dummy.R",
                                   package = "tidylab.deployment", mustWork = TRUE)
    return(paste0(readLines(file_path), collapse = "\n"))
}

.write_to_target <- function(text, con){
    dir.create(path = dirname(con), showWarnings = FALSE, recursive = TRUE)
    writeLines(text, con)
}
# nocov end