diff --git a/R/add_badge.R b/R/add_badge.R new file mode 100644 index 0000000..8a011b9 --- /dev/null +++ b/R/add_badge.R @@ -0,0 +1,76 @@ +#' **Add a badge to the README.Rmd** +#' +#' @param badge a Markdown expression. +#' @param pattern a special tag (i.e. 'LifeCycle', 'Project Status', +#' 'CRAN status', 'License', 'R-CMD-check') +#' +#' @noRd + +add_badge <- function(badge, pattern) { + path <- build_abs_path() + + ## Checks ---- + + if (missing(badge)) { + stop("No badge to add in the 'README.Rmd'.") + } + if (missing(pattern)) { + stop("Argument 'pattern' is missing.") + } + + if (!file.exists(file.path(path, "README.Rmd"))) { + stop("The file 'README.Rmd' cannot be found.") + } + + ## Read README.Rmd ---- + + read_me <- readLines(con = file.path(path, "README.Rmd")) + + ## Check if Badges Locations are present ---- + + badge_start <- grep("", read_me) + badge_end <- grep("", read_me) + + if (!length(badge_start) || !length(badge_end)) { + stop( + "Unable to parse badges location in 'README.Rmd' file.\n", + "Did you remove the tag '' and/or ", + "''?" + ) + } + + ## Extract existing badges (if exist) ---- + + if ((badge_start + 1) == badge_end) { + badges <- character(0) + } else { + badges <- paste0( + read_me[(badge_start + 1):(badge_end - 1)], + collapse = "\n" + ) + badges <- unlist(strsplit(badges, "\n")) + badges <- badges[!(badges == "")] + } + + ## Replace/Add badge ---- + + pos <- grep(paste0("^\\s{0,}\\[!\\[", pattern), badges) + + if (length(pos)) { + badges[pos] <- badge + } else { + badges <- c(badges, badge) + } + + read_me <- c( + read_me[1:badge_start], + badges, + read_me[badge_end:length(read_me)] + ) + + ## Replace README.Rmd ---- + + writeLines(read_me, con = file.path(path, "README.Rmd")) + + invisible(NULL) +} diff --git a/R/add_citation.R b/R/add_citation.R index c9a2659..28d4557 100644 --- a/R/add_citation.R +++ b/R/add_citation.R @@ -43,11 +43,13 @@ add_citation <- function( ) { stop_if_not_project() - stop_if_not_logical(open, overwrite, quiet) + stop_if_not_logical(open) + stop_if_not_logical(overwrite) + stop_if_not_logical(quiet) path <- build_abs_path("inst", "CITATION") - assert_file_not_exists_or_overwrite(path, overwrite) + stop_if_file_exists(path, overwrite) meta <- resolve_project_meta( given = given, @@ -55,11 +57,11 @@ add_citation <- function( organisation = organisation ) - stop_if_null_or_empty(meta$given, "given") - stop_if_null_or_empty(meta$family, "family") + stop_if_not_string(meta$given) + stop_if_not_string(meta$family) if (should_create_file(path, overwrite)) { - ensure_dir_exists(dirname(path)) + create_folder_if_needed(dirname(path)) create_template("package/CITATION", path, meta) diff --git a/R/add_code_of_conduct.R b/R/add_code_of_conduct.R index 9dacc53..884e313 100644 --- a/R/add_code_of_conduct.R +++ b/R/add_code_of_conduct.R @@ -27,20 +27,22 @@ add_code_of_conduct <- function( ) { stop_if_not_project() - stop_if_not_logical(open, overwrite, quiet) + stop_if_not_logical(open) + stop_if_not_logical(overwrite) + stop_if_not_logical(quiet) path <- build_abs_path("CODE_OF_CONDUCT.md") - assert_file_not_exists_or_overwrite(path, overwrite) + stop_if_file_exists(path, overwrite) meta <- resolve_project_meta( email = email ) - stop_if_null_or_empty(meta$email, "email") + stop_if_not_string(meta$email) if (should_create_file(path, overwrite)) { - ensure_dir_exists(dirname(path)) + create_folder_if_needed(dirname(path)) create_template("contributing/CODE_OF_CONDUCT.md", path, meta) diff --git a/R/add_codeowners.R b/R/add_codeowners.R index d9bccdc..6d15a95 100644 --- a/R/add_codeowners.R +++ b/R/add_codeowners.R @@ -27,20 +27,22 @@ add_codeowners <- function( ) { stop_if_not_project() - stop_if_not_logical(open, overwrite, quiet) + stop_if_not_logical(open) + stop_if_not_logical(overwrite) + stop_if_not_logical(quiet) path <- build_abs_path(".github", "CODEOWNERS") - assert_file_not_exists_or_overwrite(path, overwrite) + stop_if_file_exists(path, overwrite) meta <- resolve_project_meta( github_user = github_user ) - stop_if_null_or_empty(meta$github_user, "github_user") + stop_if_not_string(meta$github_user) if (should_create_file(path, overwrite)) { - ensure_dir_exists(dirname(path)) + create_folder_if_needed(dirname(path)) writeLines( text = paste0("* @", meta$github_user), diff --git a/R/add_contributing.R b/R/add_contributing.R index 5dfbf7f..ea2f6e4 100644 --- a/R/add_contributing.R +++ b/R/add_contributing.R @@ -27,21 +27,23 @@ add_contributing <- function( ) { stop_if_not_project() - stop_if_not_logical(open, overwrite, quiet) + stop_if_not_logical(open) + stop_if_not_logical(overwrite) + stop_if_not_logical(quiet) path <- build_abs_path("CONTRIBUTING.md") - assert_file_not_exists_or_overwrite(path, overwrite) + stop_if_file_exists(path, overwrite) meta <- resolve_project_meta( email = email, organisation = organisation ) - stop_if_null_or_empty(meta$email, "email") + stop_if_not_string(meta$email) if (should_create_file(path, overwrite)) { - ensure_dir_exists(dirname(path)) + create_folder_if_needed(dirname(path)) create_template("contributing/CONTRIBUTING.md", path, meta) diff --git a/R/add_dependabot.R b/R/add_dependabot.R index a597472..ceaceb5 100644 --- a/R/add_dependabot.R +++ b/R/add_dependabot.R @@ -29,14 +29,15 @@ add_dependabot <- function( ) { stop_if_not_project() - stop_if_not_logical(overwrite, quiet) + stop_if_not_logical(overwrite) + stop_if_not_logical(quiet) path <- build_abs_path(".github", "dependabot.yaml") meta <- resolve_project_meta() if (should_create_file(path, overwrite)) { - ensure_dir_exists(dirname(path)) + create_folder_if_needed(dirname(path)) create_template(paste0("actions/", basename(path)), path, meta) diff --git a/R/add_description.R b/R/add_description.R index 4faeff1..a699b0c 100644 --- a/R/add_description.R +++ b/R/add_description.R @@ -34,11 +34,13 @@ add_description <- function( ) { stop_if_not_project() - stop_if_not_logical(open, overwrite, quiet) + stop_if_not_logical(open) + stop_if_not_logical(overwrite) + stop_if_not_logical(quiet) path <- build_abs_path("DESCRIPTION") - assert_file_not_exists_or_overwrite(path, overwrite) + stop_if_file_exists(path, overwrite) meta <- resolve_project_meta( given = given, @@ -48,12 +50,12 @@ add_description <- function( organisation = organisation ) - stop_if_null_or_empty(meta$given, "given") - stop_if_null_or_empty(meta$family, "family") - stop_if_null_or_empty(meta$email, "email") + stop_if_not_string(meta$given) + stop_if_not_string(meta$family) + stop_if_not_string(meta$email) if (should_create_file(path, overwrite)) { - ensure_dir_exists(dirname(path)) + create_folder_if_needed(dirname(path)) create_template("package/DESCRIPTION", path, meta) diff --git a/R/add_dockerfile.R b/R/add_dockerfile.R index 90474a7..404883b 100644 --- a/R/add_dockerfile.R +++ b/R/add_dockerfile.R @@ -57,7 +57,9 @@ add_dockerfile <- function( overwrite = FALSE, quiet = FALSE ) { - stop_if_not_logical(open, overwrite, quiet) + stop_if_not_logical(open) + stop_if_not_logical(overwrite) + stop_if_not_logical(quiet) path <- build_abs_path("Dockerfile") @@ -70,7 +72,7 @@ add_dockerfile <- function( "replace it, please use `overwrite = TRUE`." ) } else { - edit_file(path) + open_file_if_needed(path, open) return(invisible(NULL)) } } @@ -87,7 +89,9 @@ add_dockerfile <- function( email <- getOption("email") } - stop_if_not_string(given, family, email) + stop_if_not_string(given) + stop_if_not_string(family) + stop_if_not_string(email) r_version <- paste( utils::sessionInfo()$"R.version"$"major", @@ -202,9 +206,7 @@ add_dockerfile <- function( add_to_buildignore("Dockerfile", quiet = quiet) add_to_buildignore(".dockerignore", quiet = quiet) - if (open) { - edit_file(path) - } + open_file_if_needed(path, open) invisible(NULL) } diff --git a/R/add_github_action.R b/R/add_github_action.R index 6e199e6..2f09a89 100644 --- a/R/add_github_action.R +++ b/R/add_github_action.R @@ -88,18 +88,21 @@ add_github_action <- function( ) { stop_if_not_project() - stop_if_not_logical(open, overwrite, quiet) + stop_if_not_logical(open) + stop_if_not_logical(overwrite) + stop_if_not_logical(quiet) + stop_if_not_string(name) - assert_valid_gh_action_name(name) + stop_if_invalid_gh_action_name(name) path <- build_abs_path(".github", "workflows", paste0(name, ".yaml")) - assert_file_not_exists_or_overwrite(path, overwrite) + stop_if_file_exists(path, overwrite) meta <- resolve_project_meta() if (should_create_file(path, overwrite)) { - ensure_dir_exists(dirname(path)) + create_folder_if_needed(dirname(path)) create_template(paste0("actions/", basename(path)), path, meta) diff --git a/R/add_issue_template.R b/R/add_issue_template.R index 272fa49..821e7b7 100644 --- a/R/add_issue_template.R +++ b/R/add_issue_template.R @@ -31,18 +31,21 @@ add_issue_template <- function( ) { stop_if_not_project() - stop_if_not_logical(open, overwrite, quiet) + stop_if_not_logical(open) + stop_if_not_logical(overwrite) + stop_if_not_logical(quiet) + stop_if_not_string(name) - assert_valid_issue_template_name(name) + stop_if_invalid_issue_template_name(name) path <- build_abs_path(".github", "ISSUE_TEMPLATE", paste0(name, ".md")) - assert_file_not_exists_or_overwrite(path, overwrite) + stop_if_file_exists(path, overwrite) meta <- resolve_project_meta() if (should_create_file(path, overwrite)) { - ensure_dir_exists(dirname(path)) + create_folder_if_needed(dirname(path)) create_template(paste0("issues/", basename(path)), path, meta) diff --git a/R/add_license.R b/R/add_license.R index 230452c..cea50ad 100644 --- a/R/add_license.R +++ b/R/add_license.R @@ -31,8 +31,7 @@ add_license <- function( stop_if_not_project() stop_if_not_logical(quiet) - stop_if_not_string(license) - assert_valid_license_name(license) + stop_if_invalid_license_name(license) path <- build_abs_path("LICENSE.md") @@ -41,7 +40,7 @@ add_license <- function( family = family ) - assert_valid_mit_meta(license, meta) + stop_if_invalid_mit_meta(license, meta) if (should_update_license(license)) { update_license_field_in_desc(license, quiet) diff --git a/R/add_makefile.R b/R/add_makefile.R index c4c3485..5ed55cd 100644 --- a/R/add_makefile.R +++ b/R/add_makefile.R @@ -30,11 +30,13 @@ add_makefile <- function( ) { stop_if_not_project() - stop_if_not_logical(open, overwrite, quiet) + stop_if_not_logical(open) + stop_if_not_logical(overwrite) + stop_if_not_logical(quiet) path <- build_abs_path("make.R") - assert_file_not_exists_or_overwrite(path, overwrite) + stop_if_file_exists(path, overwrite) meta <- resolve_project_meta( given = given, @@ -42,12 +44,12 @@ add_makefile <- function( email = email ) - stop_if_null_or_empty(meta$given, "given") - stop_if_null_or_empty(meta$family, "family") - stop_if_null_or_empty(meta$email, "email") + stop_if_not_string(meta$given) + stop_if_not_string(meta$family) + stop_if_not_string(meta$email) if (should_create_file(path, overwrite)) { - ensure_dir_exists(dirname(path)) + create_folder_if_needed(dirname(path)) create_template("others/make.R", path, meta) diff --git a/R/add_package_doc.R b/R/add_package_doc.R index b0a1f1f..3205e05 100644 --- a/R/add_package_doc.R +++ b/R/add_package_doc.R @@ -26,16 +26,18 @@ add_package_doc <- function( ) { stop_if_not_project() - stop_if_not_logical(open, overwrite, quiet) + stop_if_not_logical(open) + stop_if_not_logical(overwrite) + stop_if_not_logical(quiet) meta <- resolve_project_meta() path <- build_abs_path("R", paste0(meta$project_name, "-package.R")) - assert_file_not_exists_or_overwrite(path, overwrite) + stop_if_file_exists(path, overwrite) if (should_create_file(path, overwrite)) { - ensure_dir_exists(dirname(path)) + create_folder_if_needed(dirname(path)) create_template("package/package-package.R", path, meta) diff --git a/R/add_readme_rmd.R b/R/add_readme_rmd.R index 0167055..1289ca7 100644 --- a/R/add_readme_rmd.R +++ b/R/add_readme_rmd.R @@ -34,13 +34,15 @@ add_readme_rmd <- function( ) { stop_if_not_project() - stop_if_not_logical(open, overwrite, quiet) - stop_if_not_string(type) - assert_valid_project_type(type) + stop_if_not_logical(open) + stop_if_not_logical(overwrite) + stop_if_not_logical(quiet) + + stop_if_invalid_project_type(type) path <- build_abs_path("README.Rmd") - assert_file_not_exists_or_overwrite(path, overwrite) + stop_if_file_exists(path, overwrite) meta <- resolve_project_meta( given = given, @@ -48,11 +50,11 @@ add_readme_rmd <- function( organisation = organisation ) - stop_if_null_or_empty(meta$given, "given") - stop_if_null_or_empty(meta$family, "family") + stop_if_not_string(meta$given) + stop_if_not_string(meta$family) if (should_create_file(path, overwrite)) { - ensure_dir_exists(dirname(path)) + create_folder_if_needed(dirname(path)) create_template(paste0("readme/README-", type, ".Rmd"), path, meta) diff --git a/R/add_sticker.R b/R/add_sticker.R new file mode 100644 index 0000000..1e29cb1 --- /dev/null +++ b/R/add_sticker.R @@ -0,0 +1,114 @@ +#' **Add Template sticker** +#' +#' @param overwrite a logical value. If a file is already present and +#' `overwrite = TRUE`, it will be erased and replaced. +#' +#' @param quiet a logical value. If `TRUE` messages are deleted. Default is +#' `FALSE`. +#' +#' @noRd + +add_sticker <- function(type, overwrite = FALSE, quiet = FALSE) { + if (missing(type)) { + stop("Argument 'type' is required.") + } + + if (is.null(type)) { + stop("Argument 'type' must be 'package' or 'compendium'.") + } + + if (length(type) != 1) { + stop("Argument 'type' must be 'package' or 'compendium'.") + } + + if (!(tolower(type) %in% c("package", "compendium"))) { + stop("Argument 'type' must be 'package' or 'compendium'.") + } + + type <- tolower(type) + + stop_if_not_logical(overwrite) + stop_if_not_logical(quiet) + + if (type == "package") { + path <- build_abs_path( + "man", + "figures", + "logo.png" + ) + + pathdir <- build_abs_path("man", "figures") + } else { + path <- build_abs_path( + "figures", + "readme", + "logo.png" + ) + + pathdir <- file.path("figures", "readme") + } + + if (file.exists(path) && !overwrite) { + stop(paste0( + "A '", + pathdir, + "/", + "logo.png' is already present. ", + "If you want to replace it, please use `overwrite = TRUE`." + )) + } + + if (!dir.exists(build_abs_path(pathdir))) { + dir.create( + build_abs_path(pathdir), + showWarnings = FALSE, + recursive = TRUE + ) + } + + download_template( + slug = paste0("hexsticker/", type, "-sticker.png"), + filename = build_abs_path(pathdir, "logo.png") + ) + + if (type == "package") { + if (!dir.exists(build_abs_path("inst", "package-sticker"))) { + dir.create( + build_abs_path("inst", "package-sticker"), + showWarnings = FALSE, + recursive = TRUE + ) + } + + path <- build_abs_path("inst", "package-sticker", "r_logo.png") + + if (!file.exists(path)) { + download_template( + slug = "hexsticker/r_logo.png", + filename = path + ) + } + + path <- build_abs_path( + "inst", + "package-sticker", + "create_package_sticker.R" + ) + + if (!file.exists(path)) { + download_template( + slug = "hexsticker/create_package_sticker.R", + filename = path + ) + } + } + + if (!quiet) { + ui_done(paste0( + "Adding {ui_value('package-sticker.png')} to ", + "{ui_value('README.Rmd')}" + )) + } + + invisible(NULL) +} diff --git a/R/add_testthat.R b/R/add_testthat.R index 13d1739..ce50efd 100644 --- a/R/add_testthat.R +++ b/R/add_testthat.R @@ -18,6 +18,8 @@ #' } add_testthat <- function() { + stop_if_not_project() + if (!file.exists(build_abs_path("tests", "testthat.R"))) { usethis::use_testthat() diff --git a/R/add_to_buildignore.R b/R/add_to_buildignore.R index bbe80bf..edc6621 100644 --- a/R/add_to_buildignore.R +++ b/R/add_to_buildignore.R @@ -27,11 +27,14 @@ #' } add_to_buildignore <- function(x, open = FALSE, quiet = FALSE) { + stop_if_not_project() + if (missing(x) && !open) { stop("Argument 'x' is missing.") } - stop_if_not_logical(open, quiet) + stop_if_not_logical(open) + stop_if_not_logical(quiet) path <- build_abs_path(".Rbuildignore") @@ -75,9 +78,7 @@ add_to_buildignore <- function(x, open = FALSE, quiet = FALSE) { } } - if (open) { - edit_file(path) - } + open_file_if_needed(path, open) invisible(NULL) } diff --git a/R/add_to_gitignore.R b/R/add_to_gitignore.R index 9ffed46..ae8d9e2 100644 --- a/R/add_to_gitignore.R +++ b/R/add_to_gitignore.R @@ -27,7 +27,10 @@ #' } add_to_gitignore <- function(x, open = FALSE, quiet = FALSE) { - stop_if_not_logical(open, quiet) + stop_if_not_project() + + stop_if_not_logical(open) + stop_if_not_logical(quiet) path <- build_abs_path(".gitignore") @@ -66,9 +69,7 @@ add_to_gitignore <- function(x, open = FALSE, quiet = FALSE) { } } - if (open) { - edit_file(path) - } + open_file_if_needed(path, open) invisible(NULL) } diff --git a/R/add_vignette.R b/R/add_vignette.R index f741b92..b0c7ce9 100644 --- a/R/add_vignette.R +++ b/R/add_vignette.R @@ -45,7 +45,11 @@ add_vignette <- function( overwrite = FALSE, quiet = FALSE ) { - stop_if_not_logical(open, overwrite, quiet) + stop_if_not_project() + + stop_if_not_logical(open) + stop_if_not_logical(overwrite) + stop_if_not_logical(quiet) path <- build_abs_path() package_name <- get_project_name() @@ -80,7 +84,7 @@ add_vignette <- function( "to replace it, please use `overwrite = TRUE`." ) } else { - edit_file(path) + open_file_if_needed(path, open) return(invisible(NULL)) } } @@ -188,9 +192,7 @@ add_vignette <- function( write_descr(descr) - if (open) { - edit_file(path) - } + open_file_if_needed(path, open) invisible(NULL) } diff --git a/R/create_new_compendium.R b/R/create_new_compendium.R index 2eb548d..1df6e8c 100644 --- a/R/create_new_compendium.R +++ b/R/create_new_compendium.R @@ -254,8 +254,10 @@ create_new_compendium <- function( ## Check for inceptions ---- - git_in_git() - proj_in_proj() + stop_if_git_in_git() + stop_if_proj_in_proj() + + stop_if_invalid_project_name() ## Check if git is well configured ---- @@ -419,10 +421,7 @@ create_new_compendium <- function( ## Init GIT (if required) ---- - if (!is_git()) { - gert::git_init(build_abs_path()) - ui_done("Init {ui_value('git')} versioning") - } + initialize_git() ## Add/Replace R-specific gitignore ---- diff --git a/R/create_new_package.R b/R/create_new_package.R index 8667fc1..d61ba82 100644 --- a/R/create_new_package.R +++ b/R/create_new_package.R @@ -346,12 +346,10 @@ create_new_package <- function( ## Check for inceptions ---- - git_in_git() - proj_in_proj() + stop_if_git_in_git() + stop_if_proj_in_proj() - if (!is_valid_name()) { - stop("Invalid package name.") - } + stop_if_invalid_project_name() ## Check if git is well configured ---- @@ -511,10 +509,7 @@ create_new_package <- function( ## Init GIT (if required) ---- - if (!is_git()) { - gert::git_init(build_abs_path()) - ui_done("Init {ui_value('git')} versioning") - } + initialize_git() ## Add/Replace R-specific gitignore ---- diff --git a/R/get_available_gh_actions.R b/R/get_available_gh_actions.R index c84b3aa..c2c5d66 100644 --- a/R/get_available_gh_actions.R +++ b/R/get_available_gh_actions.R @@ -16,7 +16,7 @@ #' get_available_gh_actions() get_available_gh_actions <- function() { - actions <- list_template_gh_repo_content("actions") + actions <- list_template_files("actions") actions <- actions[-which(actions == "dependabot.yaml")] gsub("\\.(yaml|yml)$", "", actions) } diff --git a/R/get_available_issue_template.R b/R/get_available_issue_template.R index 0682027..01b7886 100644 --- a/R/get_available_issue_template.R +++ b/R/get_available_issue_template.R @@ -16,6 +16,6 @@ #' get_available_issue_templates() get_available_issue_templates <- function() { - issues <- list_template_gh_repo_content("issues") + issues <- list_template_files("issues") gsub("\\.md$", "", issues) } diff --git a/R/set_credentials.R b/R/set_credentials.R index 63c5f39..3f311a1 100644 --- a/R/set_credentials.R +++ b/R/set_credentials.R @@ -63,8 +63,8 @@ set_credentials <- function( ) { credentials <- as.list(match.call())[-1] - assert_valid_credentials(credentials) - assert_valid_git_protocol(credentials) + stop_if_invalid_credentials(credentials) + stop_if_invalid_git_protocol(credentials) if (should_edit_r_profile(credentials)) { credentials <- set_default_git_protocol(credentials) diff --git a/R/utils-action.R b/R/utils-action.R new file mode 100644 index 0000000..0dc233c --- /dev/null +++ b/R/utils-action.R @@ -0,0 +1,35 @@ +#' Error if the GH Action name if not available +#' @param name a character of length of 1. The name of the GH Action. +#' @noRd +stop_if_invalid_gh_action_name <- function(name) { + available_actions <- get_available_gh_actions() + + if (!(name %in% available_actions)) { + stop( + paste0( + "The action '", + name, + "' is not available. Please run ", + "`get_available_gh_actions()` to list available GitHub Actions." + ) + ) + } + + invisible(NULL) +} + + +#' List templates of a directory +#' @param directory a character of length of 1. The name of the GH directory. +#' @noRd +list_template_files <- function(directory = NULL) { + content <- gh::gh( + endpoint = paste0(get_template_repo_url(), directory), + .send_headers = c( + `Accept` = "application/vnd.github.raw+json", + `Content-Type` = "application/json" + ) + ) + + unlist(lapply(content, function(x) x[["name"]])) +} diff --git a/R/utils-args.R b/R/utils-args.R new file mode 100644 index 0000000..3fe4bb4 --- /dev/null +++ b/R/utils-args.R @@ -0,0 +1,99 @@ +#' Check if an argument is a logical of length 1 +#' @param x a logical of length 1. Otherwise, an error is returned. +#' @noRd +stop_if_not_logical <- function(x) { + expr <- substitute(x) + arg_name <- get_arg_name(expr) + + if (is.null(x)) { + stop( + sprintf("The argument '%s' cannot be NULL.", arg_name), + call. = FALSE + ) + } + + if (!is.logical(x)) { + stop( + sprintf("The argument '%s' must be a logical of length 1.", arg_name), + call. = FALSE + ) + } + + if (length(x) != 1) { + stop( + sprintf("The argument '%s' must be a logical of length 1.", arg_name), + call. = FALSE + ) + } + + if (is.na(x)) { + stop( + sprintf("The argument '%s' cannot be NA.", arg_name), + call. = FALSE + ) + } + + invisible(TRUE) +} + + +#' Check if an argument is a character of length 1 +#' @param x a character of length 1. Otherwise, an error is returned. +#' @noRd +stop_if_not_string <- function(x) { + expr <- substitute(x) + arg_name <- get_arg_name(expr) + + if (is.null(x)) { + stop( + sprintf("The argument '%s' cannot be NULL.", arg_name), + call. = FALSE + ) + } + + if (!is.character(x)) { + stop( + sprintf("The argument '%s' must be a character of length 1.", arg_name), + call. = FALSE + ) + } + + if (length(x) != 1) { + stop( + sprintf("The argument '%s' must be a character of length 1.", arg_name), + call. = FALSE + ) + } + + if (is.na(x)) { + stop( + sprintf("The argument '%s' cannot be NA.", arg_name), + call. = FALSE + ) + } + + if (identical(x, "")) { + stop( + sprintf("The argument '%s' cannot be empty.", arg_name), + call. = FALSE + ) + } + + invisible(TRUE) +} + + +#' Get the name of an argument (works w/ list) +#' @param x a named object. +#' @noRd +get_arg_name <- function(expr) { + if (is.symbol(expr)) { + return(as.character(expr)) + } + + if (is.call(expr)) { + return(as.character(expr[[length(expr)]])) + } + + deparse(expr) +} diff --git a/R/utils-checks.R b/R/utils-checks.R deleted file mode 100644 index ceb3b89..0000000 --- a/R/utils-checks.R +++ /dev/null @@ -1,72 +0,0 @@ -## Utilities functions - Inputs Checks ---- - -#' **Check if arguments are logical of length 1** -#' -#' @param ... one or several arguments -#' -#' @noRd - -stop_if_not_logical <- function(...) { - args_values <- list(...) - names(args_values) <- as.list(match.call())[-1] - - if (length(args_values)) { - is_logical <- unlist(lapply(args_values, length)) - - if (any(is_logical != 1)) { - stop( - "Argument '", - names(is_logical[is_logical != 1])[1], - "' must be a logical of length 1." - ) - } - - is_logical <- unlist(lapply(args_values, is.logical)) - - if (any(!is_logical)) { - stop( - "Argument '", - names(is_logical[!is_logical])[1], - "' must be a logical of length 1." - ) - } - } - - invisible(NULL) -} - - -#' **Check if arguments are character of length 1** -#' -#' @param ... one or several arguments -#' -#' @noRd - -stop_if_not_string <- function(...) { - args_values <- list(...) - names(args_values) <- as.list(match.call())[-1] - - if (length(args_values)) { - is_string <- unlist(lapply(args_values, length)) - - if (any(is_string != 1)) { - stop( - "Argument '", - names(is_string[is_string != 1])[1], - "' must be a character of length 1." - ) - } - - is_string <- unlist(lapply(args_values, is.character)) - - if (any(!is_string)) { - stop( - "Argument '", - names(is_string[!is_string])[1], - "' must be a character of length 1." - ) - } - } - - invisible(NULL) -} diff --git a/R/utils-desc.R b/R/utils-desc.R new file mode 100644 index 0000000..e413dd8 --- /dev/null +++ b/R/utils-desc.R @@ -0,0 +1,37 @@ +#' Import DESCRIPTION content +#' @noRd +read_descr <- function() { + path <- build_abs_path("DESCRIPTION") + + if (!file.exists(path)) { + stop("The file 'DESCRIPTION' does not exist.", call. = FALSE) + } + + col_names <- colnames(read.dcf(path)) + descr <- read.dcf(path, keep.white = col_names) + + if (nrow(descr) != 1) { + stop("Malformed 'DESCRIPTION' file") + } + + as.data.frame(descr, stringsAsFactors = FALSE) +} + + +#' Write DESCRIPTION (erase content) +#' @noRd +write_descr <- function(descr_file) { + stop_if_not_project() + + path <- build_abs_path("DESCRIPTION") + + write.dcf( + descr_file, + file = path, + indent = 4, + width = 80, + keep.white = colnames(descr_file) + ) + + invisible(NULL) +} diff --git a/R/utils-file.R b/R/utils-file.R new file mode 100644 index 0000000..7404ccc --- /dev/null +++ b/R/utils-file.R @@ -0,0 +1,76 @@ +#' Open a file in editor +#' @noRd +edit_file <- function(path) { + if (rstudioapi::isAvailable() && rstudioapi::hasFun("navigateToFile")) { + rstudioapi::navigateToFile(path) + } else { + utils::file.edit(path) + } + + invisible(NULL) +} + + +#' Open a file if required +#' @param path a character of length of 1. The absolute path of the file. +#' @param open a logical of length 1. +#' @noRd +open_file_if_needed <- function(path, open) { + if (open) { + edit_file(path) + } + + invisible(NULL) +} + + +#' Search and replace strings in files +#' +#' File version of [gsub()]. Modified from [xfun::gsub_file()] allowing to +#' search for strings in multiple lines. +#' @param file Path of a single file. +#' @param ... Arguments passed to [gsub()]. +#' @noRd +gsub_in_file <- function(file, ...) { + if (!(file.access(file, 2) == 0 && file.access(file, 4) == 0)) { + stop("Unable to read or write to ", file) + } + + x1 <- tryCatch(xfun::read_utf8(file, error = TRUE), error = function(e) { + stop(e) + }) + + if (is.null(x1)) { + return(invisible(NULL)) + } + + x1 <- paste0(x1, collapse = "\n") + x2 <- gsub(x = x1, ...) + + if (!identical(x1, x2)) { + xfun::write_utf8(x2, file) + } + + invisible(NULL) +} + + +#' Create a directory if required +#' @param path a character of length of 1. The absolute path of the directory. +#' @noRd +create_folder_if_needed <- function(path) { + if (!dir.exists(path)) { + dir.create(path, recursive = TRUE) + } + + invisible(NULL) +} + + +#' Return TRUE if a file does not exist or if overwrite is TRUE +#' @param path a character of length of 1. The absolute path of the file. +#' @param overwrite a logical of length 1. +#' @noRd +should_create_file <- function(path, overwrite) { + !file.exists(path) || overwrite +} diff --git a/R/utils-funs.R b/R/utils-funs.R new file mode 100644 index 0000000..52d6b1c --- /dev/null +++ b/R/utils-funs.R @@ -0,0 +1,116 @@ +#' Main function to extract, clean and return function names +#' (exported & internal) +#' @noRd +detect_r_function_names <- function() { + funs <- list( + "external" = NULL, + "internal" = NULL + ) + + r_files <- get_r_file_paths() + r_functions <- read_r_files(r_files) + r_functions <- extract_r_function_names(r_functions) + + if (length(r_functions) > 0) { + exported_r_functions <- extract_exported_r_function_names() + + if (length(exported_r_functions) > 0) { + funs$"external" <- r_functions[(r_functions %in% exported_r_functions)] + + funs$"internal" <- r_functions[!(r_functions %in% exported_r_functions)] + } else { + funs$"internal" <- r_functions + } + } + + funs +} + + +#' Extract the name of the exported functions in the NAMESPACE +#' @noRd +extract_exported_r_function_names <- function() { + path <- build_abs_path("NAMESPACE") + + if (file.exists(path)) { + namespace <- readLines( + con = path, + warn = FALSE + ) + + exported_r_functions <- gsub( + "export\\(|\\)", + "", + namespace[grep("^export", namespace)] + ) + + if (length(exported_r_functions) == 0) { + return(NULL) + } + } else { + exported_r_functions <- NULL + } + + exported_r_functions +} + + +#' Error if the R/ directory does not exist +#' @noRd +stop_if_missing_r_dir <- function() { + if (!dir.exists(build_abs_path("R"))) { + stop("The directory 'R/' cannot be found.", call. = FALSE) + } + + invisible(NULL) +} + + +#' List the path of all R files in R/ +#' @noRd +get_r_file_paths <- function() { + list.files( + path = build_abs_path("R"), + pattern = "\\.R$", + full.names = TRUE, + ignore.case = TRUE + ) +} + + +#' Error if the R/ directory is empty +#' @noRd +stop_if_missing_r_files <- function() { + if (length(get_r_file_paths()) == 0) { + stop("The 'R/' folder is empty.", call. = FALSE) + } +} + + +#' Import the content of all R files in R/ +#' @param path a vector of the R file paths +#' @noRd +read_r_files <- function(path) { + lapply(path, function(x) readLines(con = x, warn = FALSE)) +} + + +#' Extract (regex) and clean R function names +#' @param x a list of function definitions +#' @noRd +extract_r_function_names <- function(x) { + x <- lapply(x, function(x) { + x[grep("\\s{0,}(<-|=)\\s{0,}function\\s{0,}\\(", x)] + }) + + x <- lapply(x, function(x) gsub("\\s", "", x)) + x <- lapply(x, function(x) gsub("(<-|=)function.*", "", x)) + x <- unlist(x) + + pos <- grep("\\(|^error$", x) + if (length(pos) > 0) { + x <- x[-pos] + } + + sort(unique(x)) +} diff --git a/R/utils-gh.R b/R/utils-gh.R index 7cfe168..a8e6401 100644 --- a/R/utils-gh.R +++ b/R/utils-gh.R @@ -1,12 +1,5 @@ ## Utilities functions - GITHUB ---- -#' **Check if project is versioned** -#' -#' @noRd - -is_git <- function() dir.exists(build_abs_path(".git")) - - #' **Update GitHub Repository Informations** #' #' @description @@ -32,7 +25,8 @@ is_git <- function() dir.exists(build_abs_path(".git")) update_gh_repo <- function(owner, repo, website = TRUE, quiet = FALSE) { stop_if_not_project() - stop_if_not_logical(website, quiet) + stop_if_not_logical(website) + stop_if_not_logical(quiet) ## Checks inputs ---- @@ -43,7 +37,8 @@ update_gh_repo <- function(owner, repo, website = TRUE, quiet = FALSE) { stop("Argument 'repo' is missing.") } - stop_if_not_string(owner, repo) + stop_if_not_string(owner) + stop_if_not_string(repo) ## Is GITHUB PAT ---- @@ -175,86 +170,11 @@ is_gh_repo <- function(owner, repo) { stop("Argument 'repo' is missing.") } - stop_if_not_string(owner, repo) + stop_if_not_string(owner) + stop_if_not_string(repo) tryCatch( gh::gh("GET /repos/{owner}/{repo}", repo = repo, owner = owner), error = function(e) NULL ) } - - -#' **Get current/default git branch name** -#' -#' @noRd - -get_git_branch_name <- function() { - is_git() - - current_branch <- gert::git_branch() - - if (is.null(current_branch)) { - config <- as.data.frame(gert::git_config_global()) - - default_global <- config[ - which( - config$"name" == "init.defaultbranch" & - config$"level" == "global" - ), - "value" - ] - - if (length(default_global) == 1) { - current_branch <- default_global - } else { - default_system <- config[ - which( - config$"name" == "init.defaultbranch" & - config$"level" == "system" - ), - "value" - ] - - if (length(default_system) == 0) { - current_branch <- "master" - } else { - current_branch <- default_system - } - } - } - - current_branch -} - - -#' **URL of the templates repo** -#' -#' @noRd - -template_repo_url <- function() { - "/repos/frbcesab/r-templates/contents/" -} - - -#' **Clean GitHub action names** -#' -#' @noRd - -clean_gh_action_name <- function(x) { - x <- tolower(x) - x <- gsub("\\.(yaml|yml)$", "", x) - x -} - - -list_template_gh_repo_content <- function(directory = NULL) { - content <- gh::gh( - endpoint = paste0(template_repo_url(), directory), - .send_headers = c( - `Accept` = "application/vnd.github.raw+json", - `Content-Type` = "application/json" - ) - ) - - unlist(lapply(content, function(x) x[["name"]])) -} diff --git a/R/utils-git.R b/R/utils-git.R new file mode 100644 index 0000000..782c694 --- /dev/null +++ b/R/utils-git.R @@ -0,0 +1,91 @@ +#' Get current/default git branch name +#' @noRd +get_git_branch_name <- function() { + if (should_init_git()) { + stop("The project is not versioned by git.", call. = FALSE) + } + + current_branch <- gert::git_branch() + + if (is.null(current_branch)) { + config <- as.data.frame(gert::git_config_global()) + + default_global <- config[ + which( + config$"name" == "init.defaultbranch" & + config$"level" == "global" + ), + "value" + ] + + if (length(default_global) == 1) { + current_branch <- default_global + } else { + default_system <- config[ + which( + config$"name" == "init.defaultbranch" & + config$"level" == "system" + ), + "value" + ] + + if (length(default_system) == 0) { + current_branch <- "master" + } else { + current_branch <- default_system + } + } + } + + current_branch +} + + +#' Assert git protocol +#' @param meta a list of the user information. +#' @noRd +stop_if_invalid_git_protocol <- function(meta) { + if (!is.null(meta$protocol)) { + if (!(meta$protocol %in% c("https", "ssh"))) { + stop( + "Argument 'protocol' must be equal to 'https' or 'ssh'", + call. = FALSE + ) + } + } + + invisible(NULL) +} + + +#' Check if project is versioned +#' @noRd +should_init_git <- function() { + !dir.exists(build_abs_path(".git")) +} + +#' Initialize git if required +#' @noRd +initialize_git <- function() { + if (should_init_git()) { + gert::git_init(build_abs_path()) + ui_done("Initialize {ui_value('git')} versioning") # TODO: change ui + } + + invisible(NULL) +} + + +#' Set default git protocol to https and/or rename to 'usethis.protocol' +#' @param meta a list of the user information. +#' @noRd +set_default_git_protocol <- function(meta) { + if (!("protocol" %in% names(meta))) { + meta[["usethis.protocol"]] <- "https" + } else { + meta[["usethis.protocol"]] <- meta[["protocol"]] + meta <- meta[!(names(meta) %in% "protocol")] + } + + meta +} diff --git a/R/utils-init.R b/R/utils-init.R new file mode 100644 index 0000000..d14673f --- /dev/null +++ b/R/utils-init.R @@ -0,0 +1,89 @@ +#' Check if the project name is valid +#' Inspired from `usethis:::valid_package_name()` - Thanks guys!. +#' @noRd + +stop_if_invalid_project_name <- function() { + pkg <- get_project_name() + + if (!(grepl("^[a-zA-Z][a-zA-Z0-9.]+$", pkg) && !grepl("\\.$", pkg))) { + stop( + "The project name is invalid. ", + "Only letters, numbers and the dot are allowed.", + call. = FALSE + ) + } +} + + +#' Git Inception +#' @noRd +stop_if_git_in_git <- function() { + paths <- unlist(strsplit(build_abs_path(), .Platform$file.sep)) + + for (i in 1:(length(paths) - 1)) { + recursive_path <- paste0( + c(paths[1:i], ".git"), + collapse = .Platform$file.sep + ) + + if (dir.exists(recursive_path)) { + stop( + "You are going to create a '.git' inside a folder that is ", + "already versioned.\n < ", + recursive_path, + " >" + ) + } + } + + invisible(NULL) +} + + +#' Rproj Inception +#' @noRd +stop_if_proj_in_proj <- function() { + paths <- unlist(strsplit(build_abs_path(), .Platform$file.sep)) + + for (i in 1:(length(paths) - 1)) { + recursive_path <- paste0(paths[1:i], collapse = .Platform$file.sep) + recursive_path <- paste0(recursive_path, .Platform$file.sep) + + if (length(list.files(recursive_path, pattern = "\\.Rproj$"))) { + stop( + "You have created an 'RStudio Project' inside a folder that ", + "is already an 'RStudio Project'." + ) + } + } + + invisible(NULL) +} + + +#' Initialize project (create .here if required) +#' @param quiet a logical of length 1. +#' @noRd +initialize_project <- function(quiet = FALSE) { + ui_title("Initializing project", quiet) + + if (is.null(resolve_project_root())) { + content <- list.files(getwd(), all.files = TRUE, no.. = TRUE) + + if (length(content) == 0) { + invisible(file.create(".here")) + ui_file_written(".here", quiet) + } else { + stop( + paste0( + "The path '", + getwd(), + "' is not empty and does not appear to be an R project." + ) + ) + } + } + + ui_project_initialized(getwd(), quiet) + invisible(NULL) +} diff --git a/R/utils-io.R b/R/utils-io.R deleted file mode 100644 index 0fd2418..0000000 --- a/R/utils-io.R +++ /dev/null @@ -1,317 +0,0 @@ -## Utilities functions - Handle files ---- - -#' **Open a file in editor** -#' -#' @noRd - -edit_file <- function(path) { - if (rstudioapi::isAvailable() && rstudioapi::hasFun("navigateToFile")) { - rstudioapi::navigateToFile(path) - } else { - utils::file.edit(path) - } - - invisible(NULL) -} - - -#' **Import DESCRIPTION content** -#' -#' @noRd - -read_descr <- function() { - stop_if_not_project() - - path <- build_abs_path() - - col_names <- colnames(read.dcf(file.path(path, "DESCRIPTION"))) - - descr <- read.dcf(file.path(path, "DESCRIPTION"), keep.white = col_names) - - if (nrow(descr) != 1) { - stop("Malformed 'DESCRIPTION' file") - } - - as.data.frame(descr, stringsAsFactors = FALSE) -} - - -#' **Write DESCRIPTION (erase content)** -#' -#' @noRd - -write_descr <- function(descr_file) { - stop_if_not_project() - - path <- build_abs_path() - - write.dcf( - descr_file, - file = file.path(path, "DESCRIPTION"), - indent = 4, - width = 80, - keep.white = colnames(descr_file) - ) - - invisible(NULL) -} - - -#' **Add a badge to the README.Rmd** -#' -#' @param badge a Markdown expression. -#' @param pattern a special tag (i.e. 'LifeCycle', 'Project Status', -#' 'CRAN status', 'License', 'R-CMD-check') -#' -#' @noRd - -add_badge <- function(badge, pattern) { - path <- build_abs_path() - - ## Checks ---- - - if (missing(badge)) { - stop("No badge to add in the 'README.Rmd'.") - } - if (missing(pattern)) { - stop("Argument 'pattern' is missing.") - } - - if (!file.exists(file.path(path, "README.Rmd"))) { - stop("The file 'README.Rmd' cannot be found.") - } - - ## Read README.Rmd ---- - - read_me <- readLines(con = file.path(path, "README.Rmd")) - - ## Check if Badges Locations are present ---- - - badge_start <- grep("", read_me) - badge_end <- grep("", read_me) - - if (!length(badge_start) || !length(badge_end)) { - stop( - "Unable to parse badges location in 'README.Rmd' file.\n", - "Did you remove the tag '' and/or ", - "''?" - ) - } - - ## Extract existing badges (if exist) ---- - - if ((badge_start + 1) == badge_end) { - badges <- character(0) - } else { - badges <- paste0( - read_me[(badge_start + 1):(badge_end - 1)], - collapse = "\n" - ) - badges <- unlist(strsplit(badges, "\n")) - badges <- badges[!(badges == "")] - } - - ## Replace/Add badge ---- - - pos <- grep(paste0("^\\s{0,}\\[!\\[", pattern), badges) - - if (length(pos)) { - badges[pos] <- badge - } else { - badges <- c(badges, badge) - } - - read_me <- c( - read_me[1:badge_start], - badges, - read_me[badge_end:length(read_me)] - ) - - ## Replace README.Rmd ---- - - writeLines(read_me, con = file.path(path, "README.Rmd")) - - invisible(NULL) -} - - -#' **Add Template sticker** -#' -#' @param overwrite a logical value. If a file is already present and -#' `overwrite = TRUE`, it will be erased and replaced. -#' -#' @param quiet a logical value. If `TRUE` messages are deleted. Default is -#' `FALSE`. -#' -#' @noRd - -add_sticker <- function(type, overwrite = FALSE, quiet = FALSE) { - if (missing(type)) { - stop("Argument 'type' is required.") - } - - if (is.null(type)) { - stop("Argument 'type' must be 'package' or 'compendium'.") - } - - if (length(type) != 1) { - stop("Argument 'type' must be 'package' or 'compendium'.") - } - - if (!(tolower(type) %in% c("package", "compendium"))) { - stop("Argument 'type' must be 'package' or 'compendium'.") - } - - type <- tolower(type) - - stop_if_not_logical(overwrite, quiet) - - if (type == "package") { - path <- build_abs_path( - "man", - "figures", - "logo.png" - ) - - pathdir <- build_abs_path("man", "figures") - } else { - path <- build_abs_path( - "figures", - "readme", - "logo.png" - ) - - pathdir <- file.path("figures", "readme") - } - - if (file.exists(path) && !overwrite) { - stop(paste0( - "A '", - pathdir, - "/", - "logo.png' is already present. ", - "If you want to replace it, please use `overwrite = TRUE`." - )) - } - - if (!dir.exists(build_abs_path(pathdir))) { - dir.create( - build_abs_path(pathdir), - showWarnings = FALSE, - recursive = TRUE - ) - } - - download_template( - slug = paste0("hexsticker/", type, "-sticker.png"), - filename = build_abs_path(pathdir, "logo.png") - ) - - if (type == "package") { - if (!dir.exists(build_abs_path("inst", "package-sticker"))) { - dir.create( - build_abs_path("inst", "package-sticker"), - showWarnings = FALSE, - recursive = TRUE - ) - } - - path <- build_abs_path("inst", "package-sticker", "r_logo.png") - - if (!file.exists(path)) { - download_template( - slug = "hexsticker/r_logo.png", - filename = path - ) - } - - path <- build_abs_path( - "inst", - "package-sticker", - "create_package_sticker.R" - ) - - if (!file.exists(path)) { - download_template( - slug = "hexsticker/create_package_sticker.R", - filename = path - ) - } - } - - if (!quiet) { - ui_done(paste0( - "Adding {ui_value('package-sticker.png')} to ", - "{ui_value('README.Rmd')}" - )) - } - - invisible(NULL) -} - - -#' **Search and replace strings in files** -#' -#' File version of [gsub()]. Modified from [xfun::gsub_file()] allowing to -#' search for strings in multiple lines. -#' -#' @param file Path of a single file. -#' -#' @param ... Arguments passed to [gsub()]. -#' -#' @noRd - -gsub_in_file <- function(file, ...) { - if (!(file.access(file, 2) == 0 && file.access(file, 4) == 0)) { - stop("Unable to read or write to ", file) - } - - x1 <- tryCatch(xfun::read_utf8(file, error = TRUE), error = function(e) { - stop(e) - }) - - if (is.null(x1)) { - return(invisible(NULL)) - } - - x1 <- paste0(x1, collapse = "\n") - x2 <- gsub(x = x1, ...) - - if (!identical(x1, x2)) { - xfun::write_utf8(x2, file) - } - - invisible(NULL) -} - - -#' **URL of the template GitHub repository** -#' -#' @noRd - -template_url <- function() { - "https://raw.githubusercontent.com/FRBCesab/r-templates/refs/heads/main/" -} - - -#' **Helper function to download a file from the template GitHub repo** -#' -#' @param slug a character of length 1. End of the file URL -#' (e.g. `package/CITATION`) -#' -#' @param filename a character of length 1. The absolute path of the file. -#' -#' @noRd - -download_template <- function(slug, filename) { - stop_if_not_string(slug, filename) - - utils::download.file( - url = paste0(template_url(), slug), - destfile = filename, - mode = "wb", - quiet = TRUE - ) - - invisible(NULL) -} diff --git a/R/utils-issue.R b/R/utils-issue.R new file mode 100644 index 0000000..bab9265 --- /dev/null +++ b/R/utils-issue.R @@ -0,0 +1,19 @@ +#' Error if the Issue Template name if not available +#' @param name a character of length of 1. The name of the Issue Template. +#' @noRd +stop_if_invalid_issue_template_name <- function(name) { + available_issues <- get_available_issue_templates() + + if (!(name %in% available_issues)) { + stop( + paste0( + "The issue template '", + name, + "' is not available. Please run ", + "`get_available_issue_templates()` to list available Issue Templates." + ) + ) + } + + invisible(NULL) +} diff --git a/R/utils-license.R b/R/utils-license.R new file mode 100644 index 0000000..8e08e22 --- /dev/null +++ b/R/utils-license.R @@ -0,0 +1,149 @@ +#' Error if the license name if not available +#' @param license a character of length of 1. The name of the license. +#' @noRd +stop_if_invalid_license_name <- function(license) { + stop_if_not_string(license) + + license_id <- which(licenses$tag == license) + + if (length(license_id) == 0) { + stop( + "Invalid license. Please use `get_licenses()` to select an ", + "appropriate one." + ) + } + + invisible(NULL) +} + + +#' Error if given & family are not provided (MIT only) +#' @param license a character of length of 1. The name of the license. +#' @param meta a list of the project metadata. +#' @noRd +stop_if_invalid_mit_meta <- function(license, meta) { + if (license == "MIT") { + if (is.null(meta$given)) { + stop( + "Given name of the coypright holder is mandatory with the ", + "license MIT. Please use the argument `given` or the function ", + "`set_credentials()`.", + call. = FALSE + ) + } + + if (is.null(meta$family)) { + stop( + "Family name of the coypright holder is mandatory with the ", + "license MIT. Please use the argument `family` or the function ", + "`set_credentials()`.", + call. = FALSE + ) + } + + stop_if_not_string(meta$given) + stop_if_not_string(meta$family) + } + + invisible(NULL) +} + + +#' Update the License field in the DESCRIPTION file +#' @param license a character of length of 1. The name of the license. +#' @param meta a list of the project metadata. +#' @noRd +create_mit_copyright_holder_file <- function(license, meta, quiet = FALSE) { + path <- build_abs_path("LICENSE") + + if (license == "MIT") { + content <- c( + paste("YEAR:", meta$year), + paste("COPYRIGHT HOLDER:", meta$given, meta$family) + ) + + writeLines(text = content, con = path) + + ui_file_written("LICENSE", quiet = quiet) + } else { + if (file.exists(path)) { + invisible( + file.remove(path) + ) + } + } + + invisible(NULL) +} + + +#' Retrieve license information (file name, url, etc.) +#' @param license a character of length of 1. The name of the license. +#' @noRd +get_license_meta <- function(license) { + if (!is.null(license)) { + license_id <- which(licenses$tag == license) + return(as.list(licenses[license_id, ])) + } else { + return(NULL) + } +} + + +#' Retrieve the name of the license used in the project +#' @noRd +get_project_license_name <- function() { + if (file.exists(build_abs_path("DESCRIPTION"))) { + descr_file <- read_descr() + return(gsub(" \\+ file LICENSE", "", descr_file$License)) + } else { + return(NULL) + } +} + + +#' Retrieve the URL of the license used in the project +#' @noRd +get_project_license_url <- function() { + license <- get_project_license_name() + + if (!is.null(license)) { + return(get_license_meta(license)$url) + } else { + return(NULL) + } +} + + +#' Update the License field in the DESCRIPTION file +#' @param license a character of length of 1. The name of the license. +#' @noRd +update_license_field_in_desc <- function(license, quiet = FALSE) { + descr <- read_descr() + descr$"License" <- ifelse(license == "MIT", "MIT + file LICENSE", license) + write_descr(descr) + + if (!quiet) { + cli::cli_alert_success( + "Setting {.field License} field in DESCRIPTION to {.val {license}}" + ) + } + + invisible(NULL) +} + + +#' Return TRUE if the license should be added/updated +#' @param license a character of length of 1. The name of the license. +#' @noRd +should_update_license <- function(license) { + descr_license <- get_project_license_name() + + if (!is.null(descr_license)) { + if (descr_license == license) { + return(FALSE) + } else { + return(TRUE) + } + } +} diff --git a/R/utils-meta.R b/R/utils-meta.R new file mode 100644 index 0000000..954b1f5 --- /dev/null +++ b/R/utils-meta.R @@ -0,0 +1,130 @@ +#' Retrieve and assert project metadata +#' @param ... any metadata options (given, email, etc.) or empty +#' @noRd +resolve_project_meta <- function(...) { + args <- list(...) + + given <- args$given %||% getOption("given") + family <- args$family %||% getOption("family") + email <- args$email %||% getOption("email") + orcid <- args$orcid %||% getOption("orcid") + github_user <- args$github_user %||% getOption("github_user") + github_account <- args$organisation %||% github_user + + list( + given = given, + family = family, + email = email, + orcid = orcid, + + project_name = get_project_name(), + project_version = get_project_version(), + license = get_project_license_name(), + license_url = get_project_license_url(), + + github_user = github_user, + github_account = github_account, + git_branch = get_git_branch_name(), + + r_version = get_r_version(), + roxygen2_version = get_roxygen2_version(), + renv_version = utils::packageVersion("renv"), + + year = format(Sys.Date(), "%Y"), + date = format(Sys.time(), "%Y/%m/%d") + ) +} + + +#' Assert user information +#' @param meta a list of the user information. +#' @noRd +stop_if_invalid_credentials <- function(meta) { + if (!is.null(meta)) { + if ("given" %in% names(meta)) { + stop_if_not_string(meta$given) + } + + if ("family" %in% names(meta)) { + stop_if_not_string(meta$family) + } + + if ("email" %in% names(meta)) { + stop_if_not_string(meta$email) + } + + if ("orcid" %in% names(meta)) { + stop_if_not_string(meta$orcid) + } + + if ("github_user" %in% names(meta)) { + stop_if_not_string(meta$github_user) + } + + if (!is.null(meta[["protocol"]])) { + if ("protocol" %in% names(meta)) { + stop_if_not_string(meta$protocol) + } + } + } + + invisible(NULL) +} + + +#' Error if the project is not package or compendium +#' @param type a character of length of 1. The type of the project. +#' @noRd +stop_if_invalid_project_type <- function(type) { + stop_if_not_string(type) + + if (!(type %in% c("package", "compendium"))) { + stop("Argument 'type' must be 'package' or 'compendium'.", call. = FALSE) + } + + invisible(NULL) +} + + +#' Get the project name +#' @noRd +get_project_name <- function() { + dirname(build_abs_path()) +} + + +#' Get the project version +#' @noRd +get_project_version <- function() { + if (file.exists(build_abs_path("DESCRIPTION"))) { + return(read_descr()$"Version") + } else { + return(NULL) + } +} + + +#' Get roxygen2 version +#' @noRd +get_roxygen2_version <- function() { + if (!length(find.package("roxygen2", quiet = TRUE))) { + stop("The package 'roxygen2' is required.", call. = FALSE) + } + + as.character(utils::packageVersion("roxygen2")) +} + + +#' Get installed R version +#' @noRd +get_r_version <- function() { + r_version <- paste( + utils::sessionInfo()["R.version"][[1]]["major"], + utils::sessionInfo()["R.version"][[1]]["minor"], + sep = "." + ) + + r_version <- unlist(strsplit(r_version, "\\.")) + r_version <- paste(r_version[1], r_version[2], sep = ".") + r_version +} diff --git a/R/utils-new.R b/R/utils-new.R deleted file mode 100644 index 4cd055d..0000000 --- a/R/utils-new.R +++ /dev/null @@ -1,680 +0,0 @@ -#' Error if a file exists and if overwrite is FALSE -#' @param path a character of length of 1. The relative path of the file -#' @param overwrite a logical of length 1. -#' @noRd -assert_file_not_exists_or_overwrite <- function(path, overwrite) { - if (file.exists(path) && !overwrite) { - stop( - paste0( - "The file '", - extract_rel_path(path), - "' already exists. ", - "To replace it, please use `overwrite = TRUE`." - ), - call. = FALSE - ) - } - - invisible(NULL) -} - - -#' Retrieve and assert project metadata -#' @param ... any metadata options (given, email, etc.) or empty -#' @noRd -resolve_project_meta <- function(...) { - args <- list(...) - - given <- args$given %||% getOption("given") - family <- args$family %||% getOption("family") - email <- args$email %||% getOption("email") - orcid <- args$orcid %||% getOption("orcid") - github_user <- args$github_user %||% getOption("github_user") - github_account <- args$organisation %||% github_user - - list( - given = given, - family = family, - email = email, - orcid = orcid, - - project_name = get_project_name(), - project_version = get_project_version(), - license = get_project_license_name(), - license_url = get_project_license_url(), - - github_user = github_user, - github_account = github_account, - git_branch = get_git_branch_name(), - - r_version = paste( - utils::sessionInfo()$"R.version"$"major", - utils::sessionInfo()$"R.version"$"minor", - sep = "." - ), - roxygen2_version = get_roxygen2_version(), - renv_version = utils::packageVersion("renv"), - - year = format(Sys.Date(), "%Y"), - date = format(Sys.time(), "%Y/%m/%d") - ) -} - - -#' Return TRUE if a file does not exist or if overwrite is TRUE -#' @param path a character of length of 1. The absolute path of the file. -#' @param overwrite a logical of length 1. -#' @noRd -should_create_file <- function(path, overwrite) { - !file.exists(path) || overwrite -} - - -#' Create a directory if required -#' @param path a character of length of 1. The absolute path of the directory. -#' @noRd -ensure_dir_exists <- function(path) { - if (!dir.exists(path)) { - dir.create(path, recursive = TRUE) - } - - invisible(NULL) -} - - -#' Download a file template and replace default values -#' @param slug a character of length of 1. The URL slug of the file template. -#' @param path a character of length of 1. The absolute path of the file. -#' @param meta a list of the project metadata. -#' @noRd -create_template <- function(slug, path, meta) { - download_template(slug, path) - populate_template(path, meta) - - invisible(NULL) -} - - -#' Replace default values in templates -#' @param path a character of length of 1. The absolute path of the file. -#' @param meta a list of the project metadata. -#' @noRd -populate_template <- function(path, meta) { - for (name in names(meta)) { - value <- meta[[name]] - - if (!is.null(value)) { - placeholder <- paste0("{{", name, "}}") - - xfun::gsub_file( - path, - pattern = placeholder, - replacement = as.character(value), - fixed = TRUE - ) - } - } - - invisible(NULL) -} - - -#' Inform user that a file has been written -#' @param path a character of length of 1. The absolute path of the file. -#' @param quiet a logical of length 1. -#' @noRd -ui_file_written <- function(path, quiet = FALSE) { - if (!quiet) { - path <- extract_rel_path(path) - cli::cli_alert_success("Writing {.file {path}} file") - } - - invisible(NULL) -} - - -#' Inform user that a file has been written -#' @param path a character of length of 1. The absolute path of the file. -#' @param quiet a logical of length 1. -#' @noRd -ui_file_not_written <- function(path, quiet = FALSE) { - if (!quiet) { - cli::cli_alert_danger("The {.file {path}} file already exists") - } - - invisible(NULL) -} - -#' Open a file if required -#' @param path a character of length of 1. The absolute path of the file. -#' @param open a logical of length 1. -#' @noRd -open_file_if_needed <- function(path, open) { - if (open) { - edit_file(path) - } - - invisible(NULL) -} - - -#' Helper: if x is NULL then y -#' @noRd -`%||%` <- function(x, y) { - if (is.null(x)) y else x -} - - -#' Error if an argument is NULL or empty -#' @noRd -stop_if_null_or_empty <- function(value, name) { - if (is.null(value) || identical(value, "") || length(value) == 0) { - stop( - paste0( - "Argument '", - name, - "' is required but is NULL or empty." - ) - ) - } - - invisible(NULL) -} - - -#' Error if the license name if not available -#' @param license a character of length of 1. The name of the license. -#' @noRd -assert_valid_license_name <- function(license) { - stop_if_null_or_empty(license) - stop_if_not_string(license) - - license_id <- which(licenses$tag == license) - - if (length(license_id) == 0) { - stop( - "Invalid license. Please use `get_licenses()` to select an ", - "appropriate one." - ) - } - - invisible(NULL) -} - - -#' Error if given & family are not provided (MIT only) -#' @param license a character of length of 1. The name of the license. -#' @param meta a list of the project metadata. -#' @noRd -assert_valid_mit_meta <- function(license, meta) { - if (license == "MIT") { - if (is.null(meta$given)) { - stop( - "Given name of the coypright holder is mandatory with the ", - "license MIT. Please use the argument `given` or the function ", - "`set_credentials()`.", - call. = FALSE - ) - } - - if (is.null(meta$family)) { - stop( - "Family name of the coypright holder is mandatory with the ", - "license MIT. Please use the argument `family` or the function ", - "`set_credentials()`.", - call. = FALSE - ) - } - - stop_if_not_string(meta$given) - stop_if_not_string(meta$family) - } - - invisible(NULL) -} - - -#' Return TRUE if the license should be added/updated -#' @param license a character of length of 1. The name of the license. -#' @noRd -should_update_license <- function(license) { - descr_license <- get_project_license_name() - - if (!is.null(descr_license)) { - if (descr_license == license) { - return(FALSE) - } else { - return(TRUE) - } - } -} - - -#' Update the License field in the DESCRIPTION file -#' @param license a character of length of 1. The name of the license. -#' @noRd -update_license_field_in_desc <- function(license, quiet = FALSE) { - descr <- read_descr() - descr$"License" <- ifelse(license == "MIT", "MIT + file LICENSE", license) - write_descr(descr) - - if (!quiet) { - cli::cli_alert_success( - "Setting {.field License} field in DESCRIPTION to {.val {license}}" - ) - } - - invisible(NULL) -} - - -#' Update the License field in the DESCRIPTION file -#' @param license a character of length of 1. The name of the license. -#' @param meta a list of the project metadata. -#' @noRd -create_mit_copyright_holder_file <- function(license, meta, quiet = FALSE) { - full_path <- build_abs_path("LICENSE") - - if (license == "MIT") { - content <- c( - paste("YEAR:", meta$year), - paste("COPYRIGHT HOLDER:", meta$given, meta$family) - ) - - writeLines(text = content, con = full_path) - - ui_file_written("LICENSE", quiet = quiet) - } else { - if (file.exists(full_path)) { - invisible( - file.remove(full_path) - ) - } - } - - invisible(NULL) -} - - -#' Retrive license information (file name, url, etc.) -#' @param license a character of length of 1. The name of the license. -#' @noRd -get_license_meta <- function(license) { - license_id <- which(licenses$tag == license) - as.list(licenses[license_id, ]) -} - - -#' Error if the GH Action name if not available -#' @param name a character of length of 1. The name of the GH Action. -#' @noRd -assert_valid_gh_action_name <- function(name) { - available_actions <- get_available_gh_actions() - - if (!(name %in% available_actions)) { - stop( - paste0( - "The action '", - name, - "' is not available. Please run ", - "`get_available_gh_actions()` to list available GitHub Actions." - ) - ) - } - - invisible(NULL) -} - - -#' Error if the project is not package or compendium -#' @param type a character of length of 1. The type of the project. -#' @noRd -assert_valid_project_type <- function(type) { - stop_if_null_or_empty(type) - stop_if_not_string(type) - - if (!(type %in% c("package", "compendium"))) { - stop("Argument 'type' must be 'package' or 'compendium'.", call. = FALSE) - } - - invisible(NULL) -} - - -#' Retrieve the name of the license used in the project -#' @noRd -get_project_license_name <- function() { - descr_file <- read_descr() - gsub(" \\+ file LICENSE", "", descr_file$License) -} - - -#' Retrieve the URL of the license used in the project -#' @noRd -get_project_license_url <- function() { - license <- get_project_license_name() - get_license_meta(license)$url -} - - -#' Error if the Issue Template name if not available -#' @param name a character of length of 1. The name of the Issue Template. -#' @noRd -assert_valid_issue_template_name <- function(name) { - available_issues <- get_available_issue_templates() - - if (!(name %in% available_issues)) { - stop( - paste0( - "The issue template '", - name, - "' is not available. Please run ", - "`get_available_issue_templates()` to list available Issue Templates." - ) - ) - } - - invisible(NULL) -} - - -#' Assert git protocol -#' @param meta a list of the user information. -#' @noRd -assert_valid_git_protocol <- function(meta) { - if (!is.null(meta$protocol)) { - if (!(meta$protocol %in% c("https", "ssh"))) { - stop( - "Argument 'protocol' must be equal to 'https' or 'ssh'", - call. = FALSE - ) - } - } - - invisible(NULL) -} - - -#' Assert user information -#' @param meta a list of the user information. -#' @noRd -assert_valid_credentials <- function(meta) { - if (!is.null(meta)) { - if ("given" %in% names(meta)) { - given <- meta[["given"]] - stop_if_not_string(given) - } - - if ("family" %in% names(meta)) { - family <- meta[["family"]] - stop_if_not_string(family) - } - - if ("email" %in% names(meta)) { - email <- meta[["email"]] - stop_if_not_string(email) - } - - if ("orcid" %in% names(meta)) { - orcid <- meta[["orcid"]] - stop_if_not_string(orcid) - } - - if ("github_user" %in% names(meta)) { - github_user <- meta[["github_user"]] - stop_if_not_string(github_user) - } - - if (!is.null(meta[["protocol"]])) { - if ("protocol" %in% names(meta)) { - protocol <- meta[["protocol"]] - stop_if_not_string(protocol) - } - } - } - - invisible(NULL) -} - - -#' Set default git protocol to https and/or rename to 'usethis.protocol' -#' @param meta a list of the user information. -#' @noRd -set_default_git_protocol <- function(meta) { - if (!("protocol" %in% names(meta))) { - meta[["usethis.protocol"]] <- "https" - } else { - meta[["usethis.protocol"]] <- meta[["protocol"]] - meta <- meta[!(names(meta) %in% "protocol")] - } - - meta -} - - -#' Return TRUE if the user provide information -#' @param meta a list of the user information. -#' @noRd -should_edit_r_profile <- function(meta) { - if (length(meta) > 0) { - return(TRUE) - } else { - return(FALSE) - } -} - - -#' Create information message to edit the user .Rprofile -#' @param meta a list of the user information. -#' @noRd -create_r_profile_content <- function(meta) { - r_prof <- "## rcompendium credentials ----" - - opts <- paste0("\n ", names(meta), " = \"", unlist(meta), "\"") - opts <- paste0(opts, collapse = ", ") - - c(r_prof, paste0("options(", opts, "\n)", "")) -} - - -#' Display information message to edit the user .Rprofile -#' @param content a character of length 1. -#' @noRd -ui_r_profile_content <- function(content) { - cli::cli_alert_warning( - paste0( - "Please copy and paste the following lines to the ", - "{.file {build_r_profile_path()}}:" - ) - ) - - cat("\n") - cli::cli_code(format(content)) - - invisible(NULL) -} - - -#' Build the path to the user .Rprofile -#' @noRd -build_r_profile_path <- function() { - custom_r_profile_path <- Sys.getenv("R_PROFILE_USER") - if (custom_r_profile_path != "") { - r_profile_path <- custom_r_profile_path - } else { - r_profile_path <- file.path(fs::path_home_r(), ".Rprofile") - } - - r_profile_path -} - - -#' Create the user .Rprofile (if required) and return the path -#' @noRd -create_r_profile_if_needed <- function() { - r_profile_path <- build_r_profile_path() - if (!file.exists((r_profile_path))) { - invisible(file.create(r_profile_path)) - } - - invisible(r_profile_path) -} - - -#' Initialize project (create .here if require) -#' @param quiet a logical of length 1. -#' @noRd -initialize_project <- function(quiet = FALSE) { - ui_title("Initializing project", quiet) - - if (is.null(resolve_project_root())) { - content <- list.files(getwd(), all.files = TRUE, no.. = TRUE) - - if (length(content) == 0) { - invisible(file.create(".here")) - ui_file_written(".here", quiet) - } else { - stop( - paste0( - "The path '", - getwd(), - "' is not empty and does not appear to be an R project." - ) - ) - } - } - - ui_project_initialized(getwd(), quiet) - invisible(NULL) -} - - -#' Inform user that the project has been initiliazed -#' @param path a character of length of 1. The absolute path of the project. -#' @param quiet a logical of length 1. -#' @noRd -ui_project_initialized <- function(path, quiet = FALSE) { - if (!quiet) { - cli::cli_alert_success("Setting active project to {.val {path}}") - } - - invisible(NULL) -} - - -#' Error if the R/ directory does not exist -#' @noRd -stop_if_missing_r_dir <- function() { - if (!dir.exists(build_abs_path("R"))) { - stop("The directory 'R/' cannot be found.", call. = FALSE) - } - - invisible(NULL) -} - - -#' List the path of all R files in R/ -#' @noRd -get_r_file_paths <- function() { - list.files( - path = build_abs_path("R"), - pattern = "\\.R$", - full.names = TRUE, - ignore.case = TRUE - ) -} - - -#' Error if the R/ directory is empty -#' @noRd -stop_if_missing_r_files <- function() { - if (length(get_r_file_paths()) == 0) { - stop("The 'R/' folder is empty.", call. = FALSE) - } -} - - -#' Import the content of all R files in R/ -#' @param path a vector of the R file paths -#' @noRd -read_r_files <- function(path) { - lapply(path, function(x) readLines(con = x, warn = FALSE)) -} - - -#' Extract (regex) and clean R function names -#' @param x a list of function definitions -#' @noRd -extract_r_function_names <- function(x) { - x <- lapply(x, function(x) { - x[grep("\\s{0,}(<-|=)\\s{0,}function\\s{0,}\\(", x)] - }) - - x <- lapply(x, function(x) gsub("\\s", "", x)) - x <- lapply(x, function(x) gsub("(<-|=)function.*", "", x)) - x <- unlist(x) - - pos <- grep("\\(|^error$", x) - if (length(pos) > 0) { - x <- x[-pos] - } - - sort(unique(x)) -} - - -#' Extract the name of the exported functions in the NAMESPACE -#' @noRd -extract_exported_r_function_names <- function() { - path <- build_abs_path("NAMESPACE") - - if (file.exists(path)) { - namespace <- readLines( - con = path, - warn = FALSE - ) - - exported_r_functions <- gsub( - "export\\(|\\)", - "", - namespace[grep("^export", namespace)] - ) - - if (length(exported_r_functions) == 0) { - return(NULL) - } - } else { - exported_r_functions <- NULL - } - - exported_r_functions -} - - -#' Main function to extract, clean and return function names -#' (exported & internal) -#' @noRd -detect_r_function_names <- function() { - funs <- list( - "external" = NULL, - "internal" = NULL - ) - - r_files <- get_r_file_paths() - r_functions <- read_r_files(r_files) - r_functions <- extract_r_function_names(r_functions) - - if (length(r_functions) > 0) { - exported_r_functions <- extract_exported_r_function_names() - - if (length(exported_r_functions) > 0) { - funs$"external" <- r_functions[(r_functions %in% exported_r_functions)] - - funs$"internal" <- r_functions[!(r_functions %in% exported_r_functions)] - } else { - funs$"internal" <- r_functions - } - } - - funs -} diff --git a/R/utils-rprof.R b/R/utils-rprof.R new file mode 100644 index 0000000..d882b0f --- /dev/null +++ b/R/utils-rprof.R @@ -0,0 +1,49 @@ +#' Return TRUE if the user provide information +#' @param meta a list of the user information. +#' @noRd +should_edit_r_profile <- function(meta) { + if (length(meta) > 0) { + return(TRUE) + } else { + return(FALSE) + } +} + + +#' Create information message to edit the user .Rprofile +#' @param meta a list of the user information. +#' @noRd +create_r_profile_content <- function(meta) { + r_prof <- "## rcompendium credentials ----" + + opts <- paste0("\n ", names(meta), " = \"", unlist(meta), "\"") + opts <- paste0(opts, collapse = ", ") + + c(r_prof, paste0("options(", opts, "\n)", "")) +} + + +#' Build the path to the user .Rprofile +#' @noRd +build_r_profile_path <- function() { + custom_r_profile_path <- Sys.getenv("R_PROFILE_USER") + if (custom_r_profile_path != "") { + r_profile_path <- custom_r_profile_path + } else { + r_profile_path <- file.path(fs::path_home_r(), ".Rprofile") + } + + r_profile_path +} + + +#' Create the user .Rprofile (if required) and return the path +#' @noRd +create_r_profile_if_needed <- function() { + r_profile_path <- build_r_profile_path() + if (!file.exists((r_profile_path))) { + invisible(file.create(r_profile_path)) + } + + invisible(r_profile_path) +} diff --git a/R/utils-sys.R b/R/utils-sys.R deleted file mode 100644 index c8dc9b2..0000000 --- a/R/utils-sys.R +++ /dev/null @@ -1,179 +0,0 @@ -## Utilities Functions - Get Project/System Infos ---- - -#' **Get project name** -#' -#' @noRd - -get_project_name <- function() { - path <- build_abs_path() - - exploded_path <- unlist(strsplit(path, .Platform$"file.sep")) - exploded_path[length(exploded_path)] -} - - -#' **Get project version** -#' -#' @noRd - -get_project_version <- function() { - stop_if_not_project() - - read_descr()$"Version" -} - - -#' **Get `roxygen2` version** -#' -#' @noRd - -get_roxygen2_version <- function() { - if (!length(find.package("roxygen2", quiet = TRUE))) { - stop("The package 'roxygen2' cannot be found.") - } - - as.character(utils::packageVersion("roxygen2")) -} - - -#' **Get System R version** -#' -#' @noRd - -get_r_version <- function() { - r_version <- paste( - utils::sessionInfo()["R.version"][[1]]["major"], - utils::sessionInfo()["R.version"][[1]]["minor"], - sep = "." - ) - - r_version <- unlist(strsplit(r_version, "\\.")) - r_version <- paste(r_version[1], r_version[2], sep = ".") - - paste0("R (>= ", r_version, ")") -} - - -#' **Git Inception** -#' -#' @noRd - -git_in_git <- function() { - paths <- unlist(strsplit(build_abs_path(), .Platform$file.sep)) - - for (i in 1:(length(paths) - 1)) { - recursive_path <- paste0( - c(paths[1:i], ".git"), - collapse = .Platform$file.sep - ) - - if (dir.exists(recursive_path)) { - stop( - "You are going to create a '.git' inside a folder that is ", - "already versioned.\n < ", - recursive_path, - " >" - ) - } - } - - invisible(NULL) -} - - -#' **Rproj Inception** -#' -#' @noRd - -proj_in_proj <- function() { - paths <- unlist(strsplit(build_abs_path(), .Platform$file.sep)) - - for (i in 1:(length(paths) - 1)) { - recursive_path <- paste0(paths[1:i], collapse = .Platform$file.sep) - recursive_path <- paste0(recursive_path, .Platform$file.sep) - - if (length(list.files(recursive_path, pattern = "\\.Rproj$"))) { - stop( - "You have created an 'RStudio Project' inside a folder that ", - "is already an 'RStudio Project'." - ) - } - } - - invisible(NULL) -} - - -#' **Custom ui_*() message** -#' -#' @noRd - -ui_title <- function(texte, quiet = FALSE) { - if (!quiet) { - cli::cat_line() - cat(cli::symbol$radio_on, cli::style_bold(cli::style_underline(texte))) - cli::cat_line() - cli::cat_line() - } - - invisible(NULL) -} - - -#' **List all Rd functions families** -#' -#' @description -#' This function parses all R functions to detect `@family` tag. For internal -#' purpose. -#' -#' @return A vector of Rd function families. -#' -#' @noRd - -get_rd_families <- function() { - path <- build_abs_path() - - if (!dir.exists(file.path(path, "R"))) { - stop("The directory 'R/' cannot be found.") - } - - x <- list.files( - path = file.path(path, "R"), - pattern = "\\.R$", - full.names = TRUE, - ignore.case = TRUE - ) - - if (!length(x)) { - ui_oops("The {ui_value('R/')} folder is empty") - - return(NULL) - } else { - ## Read R files ---- - - x <- lapply(x, function(x) readLines(con = x, warn = FALSE)) - - ## Extract families names ---- - - x <- lapply(x, function(x) x[grep("#'\\s{0,}@family", x)]) - x <- lapply(x, function(x) gsub("#'\\s{0,}@family ", "", x)) - - return(sort(unique(unlist(x)))) - } -} - - -#' **Check if package name is valid** -#' -#' @description -#' This function checks if the package name is valid. -#' Inspired from `usethis:::valid_package_name()` - Thanks guys!. -#' -#' @return `TRUE` or `FALSE`. -#' -#' @noRd - -is_valid_name <- function() { - pkg <- get_project_name() - grepl("^[a-zA-Z][a-zA-Z0-9.]+$", pkg) && !grepl("\\.$", pkg) -} diff --git a/R/utils-template.R b/R/utils-template.R new file mode 100644 index 0000000..2b0bf93 --- /dev/null +++ b/R/utils-template.R @@ -0,0 +1,90 @@ +#' Error if a file exists and if overwrite is FALSE +#' @param path a character of length of 1. The relative path of the file +#' @param overwrite a logical of length 1. +#' @noRd +stop_if_file_exists <- function(path, overwrite) { + if (file.exists(path) && !overwrite) { + stop( + paste0( + "The file '", + extract_rel_path(path), + "' already exists. ", + "To replace it, please use `overwrite = TRUE`." + ), + call. = FALSE + ) + } + + invisible(NULL) +} + + +#' Download a file template and replace default values +#' @param slug a character of length of 1. The URL slug of the file template. +#' @param path a character of length of 1. The absolute path of the file. +#' @param meta a list of the project metadata. +#' @noRd +create_template <- function(slug, path, meta) { + download_template(slug, path) + populate_template(path, meta) + + invisible(NULL) +} + + +#' Helper function to download a file from the template GitHub repo +#' @param slug a character of length 1. End of the file URL +#' (e.g. `package/CITATION`) +#' @param filename a character of length 1. The absolute path of the file. +#' @noRd +download_template <- function(slug, filename) { + stop_if_not_string(slug) + stop_if_not_string(filename) + + utils::download.file( + url = paste0(get_template_file_url(), slug), + destfile = filename, + mode = "wb", + quiet = TRUE + ) + + invisible(NULL) +} + + +#' Replace default values in templates +#' @param path a character of length of 1. The absolute path of the file. +#' @param meta a list of the project metadata. +#' @noRd +populate_template <- function(path, meta) { + for (name in names(meta)) { + value <- meta[[name]] + + if (!is.null(value)) { + placeholder <- paste0("{{", name, "}}") + + xfun::gsub_file( + path, + pattern = placeholder, + replacement = as.character(value), + fixed = TRUE + ) + } + } + + invisible(NULL) +} + + +#' URL of the templates repo (API) +#' @noRd +get_template_repo_url <- function() { + "/repos/frbcesab/r-templates/contents/" +} + + +#' URL of the template GitHub repository +#' @noRd +get_template_file_url <- function() { + "https://raw.githubusercontent.com/FRBCesab/r-templates/refs/heads/main/" +} diff --git a/R/utils-ui.R b/R/utils-ui.R new file mode 100644 index 0000000..78f86d8 --- /dev/null +++ b/R/utils-ui.R @@ -0,0 +1,70 @@ +#' Display information message to edit the user .Rprofile +#' @param content a character of length 1. +#' @noRd +ui_r_profile_content <- function(content) { + cli::cli_alert_warning( + paste0( + "Please copy and paste the following lines to the ", + "{.file {build_r_profile_path()}}:" + ) + ) + + cat("\n") + cli::cli_code(format(content)) + + invisible(NULL) +} + + +#' Inform user that a file has been written +#' @param path a character of length of 1. The absolute path of the file. +#' @param quiet a logical of length 1. +#' @noRd +ui_file_written <- function(path, quiet = FALSE) { + if (!quiet) { + path <- extract_rel_path(path) + cli::cli_alert_success("Writing {.file {path}} file") + } + + invisible(NULL) +} + + +#' Inform user that a file has been written +#' @param path a character of length of 1. The absolute path of the file. +#' @param quiet a logical of length 1. +#' @noRd +ui_file_not_written <- function(path, quiet = FALSE) { + if (!quiet) { + cli::cli_alert_danger("The {.file {path}} file already exists") + } + + invisible(NULL) +} + + +#' Inform user that the project has been initiliazed +#' @param path a character of length of 1. The absolute path of the project. +#' @param quiet a logical of length 1. +#' @noRd +ui_project_initialized <- function(path, quiet = FALSE) { + if (!quiet) { + cli::cli_alert_success("Setting active project to {.val {path}}") + } + + invisible(NULL) +} + + +#' Custom ui_*() message +#' @noRd +ui_title <- function(texte, quiet = FALSE) { + if (!quiet) { + cli::cat_line() + cat(cli::symbol$radio_on, cli::style_bold(cli::style_underline(texte))) + cli::cat_line() + cli::cat_line() + } + + invisible(NULL) +} diff --git a/R/utils.R b/R/utils.R new file mode 100644 index 0000000..d63711e --- /dev/null +++ b/R/utils.R @@ -0,0 +1,5 @@ +#' Helper: if x is NULL then y +#' @noRd +`%||%` <- function(x, y) { + if (is.null(x)) y else x +} diff --git a/tests/testthat/_snaps/ui_file_not_written.md b/tests/testthat/_snaps/ui_file_not_written.md new file mode 100644 index 0000000..9c3fadb --- /dev/null +++ b/tests/testthat/_snaps/ui_file_not_written.md @@ -0,0 +1,7 @@ +# ui_file_not_written() works - No quiet + + Code + ui_file_not_written(path, quiet = FALSE) + Message + x The '.github/dependabot.yaml' file already exists + diff --git a/tests/testthat/_snaps/ui_file_written.md b/tests/testthat/_snaps/ui_file_written.md new file mode 100644 index 0000000..e98c454 --- /dev/null +++ b/tests/testthat/_snaps/ui_file_written.md @@ -0,0 +1,7 @@ +# ui_file_written() works - No quiet + + Code + ui_file_written(path, quiet = FALSE) + Message + v Writing '.github/dependabot.yaml' file + diff --git a/tests/testthat/_snaps/ui_project_initialized.md b/tests/testthat/_snaps/ui_project_initialized.md new file mode 100644 index 0000000..e641c4d --- /dev/null +++ b/tests/testthat/_snaps/ui_project_initialized.md @@ -0,0 +1,7 @@ +# ui_project_initialized() works - No quiet + + Code + ui_project_initialized(path, quiet = FALSE) + Message + v Setting active project to "pkgtest" + diff --git a/tests/testthat/_snaps/ui_r_profile_content.md b/tests/testthat/_snaps/ui_r_profile_content.md new file mode 100644 index 0000000..3ec33d5 --- /dev/null +++ b/tests/testthat/_snaps/ui_r_profile_content.md @@ -0,0 +1,11 @@ +# ui_r_profile_content() works - No quiet + + Code + ui_r_profile_content("This is a message") + Message + ! Please copy and paste the following lines to the '.Rprofile': + Output + + Message + This is a message + diff --git a/tests/testthat/_snaps/ui_title.md b/tests/testthat/_snaps/ui_title.md new file mode 100644 index 0000000..742aa9e --- /dev/null +++ b/tests/testthat/_snaps/ui_title.md @@ -0,0 +1,9 @@ +# ui_title() works - No quiet + + Code + ui_title(texte, quiet = FALSE) + Output + + (*) Initialize project + + diff --git a/tests/testthat/helpers.R b/tests/testthat/helpers.R index 2167f70..5dd0d95 100644 --- a/tests/testthat/helpers.R +++ b/tests/testthat/helpers.R @@ -38,3 +38,9 @@ expect_path_equal <- function(object, expected) { testthat::expect_equal(norm(object), norm(expected)) } + + +get_arg_label <- function(x) { + expr <- substitute(x) + get_arg_name(expr) +} diff --git a/tests/testthat/test-assert_file_not_exists_or_overwrite.R b/tests/testthat/test-assert_file_not_exists_or_overwrite.R deleted file mode 100644 index 6987bd4..0000000 --- a/tests/testthat/test-assert_file_not_exists_or_overwrite.R +++ /dev/null @@ -1,56 +0,0 @@ -## assert_file_not_exists_or_overwrite() ---- - -test_that("assert_file_not_exists_or_overwrite() errors", { - with_local_project({ - initialize_project(quiet = TRUE) - - invisible(file.create("README")) - - expect_error( - assert_file_not_exists_or_overwrite("README", overwrite = FALSE), - paste0( - "The file 'README' already exists. ", - "To replace it, please use `overwrite = TRUE`." - ), - fixed = TRUE - ) - }) -}) - -test_that("assert_file_not_exists_or_overwrite() works - overwrite is TRUE", { - with_local_project({ - initialize_project(quiet = TRUE) - - expect_silent( - assert_file_not_exists_or_overwrite("README", overwrite = TRUE) - ) - - expect_null( - x <- assert_file_not_exists_or_overwrite("README", overwrite = TRUE) - ) - - invisible(file.create("README")) - - expect_silent( - assert_file_not_exists_or_overwrite("README", overwrite = TRUE) - ) - - expect_null( - x <- assert_file_not_exists_or_overwrite("README", overwrite = TRUE) - ) - }) -}) - -test_that("assert_file_not_exists_or_overwrite() works - file not exists", { - with_local_project({ - initialize_project(quiet = TRUE) - - expect_silent( - assert_file_not_exists_or_overwrite("README", overwrite = FALSE) - ) - - expect_null( - x <- assert_file_not_exists_or_overwrite("README", overwrite = FALSE) - ) - }) -}) diff --git a/tests/testthat/test-assert_valid_credentials.R b/tests/testthat/test-assert_valid_credentials.R deleted file mode 100644 index 84166d5..0000000 --- a/tests/testthat/test-assert_valid_credentials.R +++ /dev/null @@ -1,212 +0,0 @@ -## assert_valid_credentials() ---- - -test_that("assert_valid_credentials() errors", { - expect_error( - assert_valid_credentials(list(given = 12)), - "Argument 'given' must be a character of length 1.", - fixed = TRUE - ) - - expect_error( - assert_valid_credentials(list(given = TRUE)), - "Argument 'given' must be a character of length 1.", - fixed = TRUE - ) - - expect_error( - assert_valid_credentials(list(given = letters)), - "Argument 'given' must be a character of length 1.", - fixed = TRUE - ) - - expect_error( - assert_valid_credentials(list(family = 12)), - "Argument 'family' must be a character of length 1.", - fixed = TRUE - ) - - expect_error( - assert_valid_credentials(list(family = TRUE)), - "Argument 'family' must be a character of length 1.", - fixed = TRUE - ) - - expect_error( - assert_valid_credentials(list(family = letters)), - "Argument 'family' must be a character of length 1.", - fixed = TRUE - ) - - expect_error( - assert_valid_credentials(list(given = "John", family = letters)), - "Argument 'family' must be a character of length 1.", - fixed = TRUE - ) - - expect_error( - assert_valid_credentials(list(email = 12)), - "Argument 'email' must be a character of length 1.", - fixed = TRUE - ) - - expect_error( - assert_valid_credentials(list(email = TRUE)), - "Argument 'email' must be a character of length 1.", - fixed = TRUE - ) - - expect_error( - assert_valid_credentials(list(email = letters)), - "Argument 'email' must be a character of length 1.", - fixed = TRUE - ) - - expect_error( - assert_valid_credentials(list(given = "John", email = letters)), - "Argument 'email' must be a character of length 1.", - fixed = TRUE - ) - - expect_error( - assert_valid_credentials(list(orcid = 12)), - "Argument 'orcid' must be a character of length 1.", - fixed = TRUE - ) - - expect_error( - assert_valid_credentials(list(orcid = TRUE)), - "Argument 'orcid' must be a character of length 1.", - fixed = TRUE - ) - - expect_error( - assert_valid_credentials(list(orcid = letters)), - "Argument 'orcid' must be a character of length 1.", - fixed = TRUE - ) - - expect_error( - assert_valid_credentials(list(given = "John", orcid = letters)), - "Argument 'orcid' must be a character of length 1.", - fixed = TRUE - ) - - expect_error( - assert_valid_credentials(list(github_user = 12)), - "Argument 'github_user' must be a character of length 1.", - fixed = TRUE - ) - - expect_error( - assert_valid_credentials(list(github_user = TRUE)), - "Argument 'github_user' must be a character of length 1.", - fixed = TRUE - ) - - expect_error( - assert_valid_credentials(list(github_user = letters)), - "Argument 'github_user' must be a character of length 1.", - fixed = TRUE - ) - - expect_error( - assert_valid_credentials(list(given = "John", github_user = letters)), - "Argument 'github_user' must be a character of length 1.", - fixed = TRUE - ) - - expect_error( - assert_valid_credentials(list(protocol = 12)), - "Argument 'protocol' must be a character of length 1.", - fixed = TRUE - ) - - expect_error( - assert_valid_credentials(list(protocol = TRUE)), - "Argument 'protocol' must be a character of length 1.", - fixed = TRUE - ) - - expect_error( - assert_valid_credentials(list(protocol = letters)), - "Argument 'protocol' must be a character of length 1.", - fixed = TRUE - ) - - expect_error( - assert_valid_credentials(list(given = "John", protocol = letters)), - "Argument 'protocol' must be a character of length 1.", - fixed = TRUE - ) -}) - -test_that("assert_valid_credentials() works", { - meta <- list() - - expect_silent(assert_valid_credentials(meta)) - expect_null(x <- assert_valid_credentials(meta)) - - meta <- list(given = "John") - expect_silent(assert_valid_credentials(meta)) - expect_null(x <- assert_valid_credentials(meta)) - - meta <- list(family = "Doe") - expect_silent(assert_valid_credentials(meta)) - expect_null(x <- assert_valid_credentials(meta)) - - meta <- list(given = "John", family = "Doe") - expect_silent(assert_valid_credentials(meta)) - expect_null(x <- assert_valid_credentials(meta)) - - meta <- list(email = "john.doe@mail.com") - expect_silent(assert_valid_credentials(meta)) - expect_null(x <- assert_valid_credentials(meta)) - - meta <- list(email = "john.doe@mail.com", family = "Doe") - expect_silent(assert_valid_credentials(meta)) - expect_null(x <- assert_valid_credentials(meta)) - - meta <- list(orcid = "0000-0000-0000-0000") - expect_silent(assert_valid_credentials(meta)) - expect_null(x <- assert_valid_credentials(meta)) - - meta <- list(given = "John", orcid = "0000-0000-0000-0000") - expect_silent(assert_valid_credentials(meta)) - expect_null(x <- assert_valid_credentials(meta)) - - meta <- list(github_user = "jdoe") - expect_silent(assert_valid_credentials(meta)) - expect_null(x <- assert_valid_credentials(meta)) - - meta <- list(github_user = "jdoe", family = "Doe") - expect_silent(assert_valid_credentials(meta)) - expect_null(x <- assert_valid_credentials(meta)) - - meta <- list(protocol = "https") - expect_silent(assert_valid_credentials(meta)) - expect_null(x <- assert_valid_credentials(meta)) - - meta <- list(protocol = "https", family = "Doe") - expect_silent(assert_valid_credentials(meta)) - expect_null(x <- assert_valid_credentials(meta)) - - meta <- list(protocol = "ssh") - expect_silent(assert_valid_credentials(meta)) - expect_null(x <- assert_valid_credentials(meta)) - - meta <- list(protocol = "ssh", family = "Doe") - expect_silent(assert_valid_credentials(meta)) - expect_null(x <- assert_valid_credentials(meta)) - - meta <- list( - given = "John", - family = "Doe", - email = "john.doe@mail.com", - orcid = "0000-0000-0000-0000", - github_user = "jdoe", - protocol = "ssh" - ) - - expect_silent(assert_valid_credentials(meta)) - expect_null(x <- assert_valid_credentials(meta)) -}) diff --git a/tests/testthat/test-assert_valid_git_protocol.R b/tests/testthat/test-assert_valid_git_protocol.R deleted file mode 100644 index a0d5fc0..0000000 --- a/tests/testthat/test-assert_valid_git_protocol.R +++ /dev/null @@ -1,27 +0,0 @@ -## assert_valid_git_protocol() ---- - -test_that("assert_valid_git_protocol() errors", { - expect_error( - assert_valid_git_protocol(list(protocol = "ftp")), - "Argument 'protocol' must be equal to 'https' or 'ssh'", - fixed = TRUE - ) - - expect_error( - assert_valid_git_protocol(list(protocol = "SSH")), - "Argument 'protocol' must be equal to 'https' or 'ssh'", - fixed = TRUE - ) - - expect_error( - assert_valid_git_protocol(list(protocol = "")), - "Argument 'protocol' must be equal to 'https' or 'ssh'", - fixed = TRUE - ) -}) - -test_that("assert_valid_git_protocol() works", { - expect_silent(assert_valid_git_protocol(list(protocol = "https"))) - expect_silent(assert_valid_git_protocol(list(protocol = "ssh"))) - expect_null(x <- assert_valid_git_protocol(list(protocol = "ssh"))) -}) diff --git a/tests/testthat/test-ensure_dir_exists.R b/tests/testthat/test-create_folder_if_needed.R similarity index 50% rename from tests/testthat/test-ensure_dir_exists.R rename to tests/testthat/test-create_folder_if_needed.R index 7eda7c9..a52bd98 100644 --- a/tests/testthat/test-ensure_dir_exists.R +++ b/tests/testthat/test-create_folder_if_needed.R @@ -1,39 +1,39 @@ -## ensure_dir_exists() ---- +## create_folder_if_needed() ---- -test_that("ensure_dir_exists() works - dir not exists", { +test_that("create_folder_if_needed() works - dir not exists", { with_local_project({ initialize_project(quiet = TRUE) path <- build_abs_path("R") - expect_silent(ensure_dir_exists(path)) - expect_null(x <- ensure_dir_exists(path)) + expect_silent(create_folder_if_needed(path)) + expect_null(x <- create_folder_if_needed(path)) expect_true(dir.exists(path)) path <- build_abs_path("tests", "testthat") - expect_silent(ensure_dir_exists(path)) - expect_null(x <- ensure_dir_exists(path)) + expect_silent(create_folder_if_needed(path)) + expect_null(x <- create_folder_if_needed(path)) expect_true(dir.exists(path)) }) }) -test_that("ensure_dir_exists() works - dir exists", { +test_that("create_folder_if_needed() works - dir exists", { with_local_project({ initialize_project(quiet = TRUE) path <- build_abs_path("man") dir.create(path, recursive = TRUE, showWarnings = FALSE) - expect_silent(ensure_dir_exists(path)) - expect_null(x <- ensure_dir_exists(path)) + expect_silent(create_folder_if_needed(path)) + expect_null(x <- create_folder_if_needed(path)) expect_true(dir.exists(path)) path <- build_abs_path("man", "figures") dir.create(path, recursive = TRUE, showWarnings = FALSE) - expect_silent(ensure_dir_exists(path)) - expect_null(x <- ensure_dir_exists(path)) + expect_silent(create_folder_if_needed(path)) + expect_null(x <- create_folder_if_needed(path)) expect_true(dir.exists(path)) }) }) diff --git a/tests/testthat/test-get_arg_name.R b/tests/testthat/test-get_arg_name.R new file mode 100644 index 0000000..7ad4951 --- /dev/null +++ b/tests/testthat/test-get_arg_name.R @@ -0,0 +1,28 @@ +## get_arg_name() ---- + +test_that("get_arg_name() works - Character", { + given <- "John" + expect_equal(get_arg_label(given), "given") + + meta <- list() + meta$given <- "John" + expect_equal(get_arg_label(meta$given), "given") +}) + +test_that("get_arg_name() works - Logical", { + open <- TRUE + expect_equal(get_arg_label(open), "open") + + meta <- list() + meta$open <- TRUE + expect_equal(get_arg_label(meta$open), "open") +}) + + +test_that("get_arg_name() works - Direct call", { + expect_equal(get_arg_name(quote(x)), "x") + expect_equal(get_arg_name(quote(mean(x))), "x") + expect_equal(get_arg_name(42), "42") + expect_equal(get_arg_name("texte"), "\"texte\"") + expect_equal(get_arg_name(NULL), "NULL") +}) diff --git a/tests/testthat/test-stop_if_file_exists.R b/tests/testthat/test-stop_if_file_exists.R new file mode 100644 index 0000000..f01d7ca --- /dev/null +++ b/tests/testthat/test-stop_if_file_exists.R @@ -0,0 +1,56 @@ +## stop_if_file_exists() ---- + +test_that("stop_if_file_exists() errors", { + with_local_project({ + initialize_project(quiet = TRUE) + + invisible(file.create("README")) + + expect_error( + stop_if_file_exists("README", overwrite = FALSE), + paste0( + "The file 'README' already exists. ", + "To replace it, please use `overwrite = TRUE`." + ), + fixed = TRUE + ) + }) +}) + +test_that("stop_if_file_exists() works - overwrite is TRUE", { + with_local_project({ + initialize_project(quiet = TRUE) + + expect_silent( + stop_if_file_exists("README", overwrite = TRUE) + ) + + expect_null( + x <- stop_if_file_exists("README", overwrite = TRUE) + ) + + invisible(file.create("README")) + + expect_silent( + stop_if_file_exists("README", overwrite = TRUE) + ) + + expect_null( + x <- stop_if_file_exists("README", overwrite = TRUE) + ) + }) +}) + +test_that("stop_if_file_exists() works - file not exists", { + with_local_project({ + initialize_project(quiet = TRUE) + + expect_silent( + stop_if_file_exists("README", overwrite = FALSE) + ) + + expect_null( + x <- stop_if_file_exists("README", overwrite = FALSE) + ) + }) +}) diff --git a/tests/testthat/test-stop_if_invalid_credentials.R b/tests/testthat/test-stop_if_invalid_credentials.R new file mode 100644 index 0000000..85acceb --- /dev/null +++ b/tests/testthat/test-stop_if_invalid_credentials.R @@ -0,0 +1,278 @@ +## stop_if_invalid_credentials() ---- + +test_that("stop_if_invalid_credentials() errors", { + expect_error( + stop_if_invalid_credentials(list(given = NULL)), + "The argument 'given' cannot be NULL.", + fixed = TRUE + ) + + expect_error( + stop_if_invalid_credentials(list(given = NA_character_)), + "The argument 'given' cannot be NA.", + fixed = TRUE + ) + + expect_error( + stop_if_invalid_credentials(list(given = 12)), + "The argument 'given' must be a character of length 1.", + fixed = TRUE + ) + + expect_error( + stop_if_invalid_credentials(list(given = TRUE)), + "The argument 'given' must be a character of length 1.", + fixed = TRUE + ) + + expect_error( + stop_if_invalid_credentials(list(given = letters)), + "The argument 'given' must be a character of length 1.", + fixed = TRUE + ) + + expect_error( + stop_if_invalid_credentials(list(family = NULL)), + "The argument 'family' cannot be NULL.", + fixed = TRUE + ) + + expect_error( + stop_if_invalid_credentials(list(family = NA_character_)), + "The argument 'family' cannot be NA.", + fixed = TRUE + ) + + expect_error( + stop_if_invalid_credentials(list(family = 12)), + "The argument 'family' must be a character of length 1.", + fixed = TRUE + ) + + expect_error( + stop_if_invalid_credentials(list(family = TRUE)), + "The argument 'family' must be a character of length 1.", + fixed = TRUE + ) + + expect_error( + stop_if_invalid_credentials(list(family = letters)), + "The argument 'family' must be a character of length 1.", + fixed = TRUE + ) + + expect_error( + stop_if_invalid_credentials(list(given = "John", family = letters)), + "The argument 'family' must be a character of length 1.", + fixed = TRUE + ) + + expect_error( + stop_if_invalid_credentials(list(email = NULL)), + "The argument 'email' cannot be NULL.", + fixed = TRUE + ) + + expect_error( + stop_if_invalid_credentials(list(email = NA_character_)), + "The argument 'email' cannot be NA.", + fixed = TRUE + ) + + expect_error( + stop_if_invalid_credentials(list(email = 12)), + "The argument 'email' must be a character of length 1.", + fixed = TRUE + ) + + expect_error( + stop_if_invalid_credentials(list(email = TRUE)), + "The argument 'email' must be a character of length 1.", + fixed = TRUE + ) + + expect_error( + stop_if_invalid_credentials(list(email = letters)), + "The argument 'email' must be a character of length 1.", + fixed = TRUE + ) + + expect_error( + stop_if_invalid_credentials(list(given = "John", email = letters)), + "The argument 'email' must be a character of length 1.", + fixed = TRUE + ) + + expect_error( + stop_if_invalid_credentials(list(orcid = NULL)), + "The argument 'orcid' cannot be NULL.", + fixed = TRUE + ) + + expect_error( + stop_if_invalid_credentials(list(orcid = NA_character_)), + "The argument 'orcid' cannot be NA.", + fixed = TRUE + ) + + expect_error( + stop_if_invalid_credentials(list(orcid = 12)), + "The argument 'orcid' must be a character of length 1.", + fixed = TRUE + ) + + expect_error( + stop_if_invalid_credentials(list(orcid = TRUE)), + "The argument 'orcid' must be a character of length 1.", + fixed = TRUE + ) + + expect_error( + stop_if_invalid_credentials(list(orcid = letters)), + "The argument 'orcid' must be a character of length 1.", + fixed = TRUE + ) + + expect_error( + stop_if_invalid_credentials(list(given = "John", orcid = letters)), + "The argument 'orcid' must be a character of length 1.", + fixed = TRUE + ) + + expect_error( + stop_if_invalid_credentials(list(github_user = NULL)), + "The argument 'github_user' cannot be NULL.", + fixed = TRUE + ) + + expect_error( + stop_if_invalid_credentials(list(github_user = NA_character_)), + "The argument 'github_user' cannot be NA.", + fixed = TRUE + ) + + expect_error( + stop_if_invalid_credentials(list(github_user = 12)), + "The argument 'github_user' must be a character of length 1.", + fixed = TRUE + ) + + expect_error( + stop_if_invalid_credentials(list(github_user = TRUE)), + "The argument 'github_user' must be a character of length 1.", + fixed = TRUE + ) + + expect_error( + stop_if_invalid_credentials(list(github_user = letters)), + "The argument 'github_user' must be a character of length 1.", + fixed = TRUE + ) + + expect_error( + stop_if_invalid_credentials(list(given = "John", github_user = letters)), + "The argument 'github_user' must be a character of length 1.", + fixed = TRUE + ) + + expect_error( + stop_if_invalid_credentials(list(protocol = NA_character_)), + "The argument 'protocol' cannot be NA.", + fixed = TRUE + ) + + expect_error( + stop_if_invalid_credentials(list(protocol = 12)), + "The argument 'protocol' must be a character of length 1.", + fixed = TRUE + ) + + expect_error( + stop_if_invalid_credentials(list(protocol = TRUE)), + "The argument 'protocol' must be a character of length 1.", + fixed = TRUE + ) + + expect_error( + stop_if_invalid_credentials(list(protocol = letters)), + "The argument 'protocol' must be a character of length 1.", + fixed = TRUE + ) + + expect_error( + stop_if_invalid_credentials(list(given = "John", protocol = letters)), + "The argument 'protocol' must be a character of length 1.", + fixed = TRUE + ) +}) + +test_that("stop_if_invalid_credentials() works", { + meta <- list() + + expect_silent(stop_if_invalid_credentials(meta)) + expect_null(x <- stop_if_invalid_credentials(meta)) + + meta <- list(given = "John") + expect_silent(stop_if_invalid_credentials(meta)) + expect_null(x <- stop_if_invalid_credentials(meta)) + + meta <- list(family = "Doe") + expect_silent(stop_if_invalid_credentials(meta)) + expect_null(x <- stop_if_invalid_credentials(meta)) + + meta <- list(given = "John", family = "Doe") + expect_silent(stop_if_invalid_credentials(meta)) + expect_null(x <- stop_if_invalid_credentials(meta)) + + meta <- list(email = "john.doe@mail.com") + expect_silent(stop_if_invalid_credentials(meta)) + expect_null(x <- stop_if_invalid_credentials(meta)) + + meta <- list(email = "john.doe@mail.com", family = "Doe") + expect_silent(stop_if_invalid_credentials(meta)) + expect_null(x <- stop_if_invalid_credentials(meta)) + + meta <- list(orcid = "0000-0000-0000-0000") + expect_silent(stop_if_invalid_credentials(meta)) + expect_null(x <- stop_if_invalid_credentials(meta)) + + meta <- list(given = "John", orcid = "0000-0000-0000-0000") + expect_silent(stop_if_invalid_credentials(meta)) + expect_null(x <- stop_if_invalid_credentials(meta)) + + meta <- list(github_user = "jdoe") + expect_silent(stop_if_invalid_credentials(meta)) + expect_null(x <- stop_if_invalid_credentials(meta)) + + meta <- list(github_user = "jdoe", family = "Doe") + expect_silent(stop_if_invalid_credentials(meta)) + expect_null(x <- stop_if_invalid_credentials(meta)) + + meta <- list(protocol = "https") + expect_silent(stop_if_invalid_credentials(meta)) + expect_null(x <- stop_if_invalid_credentials(meta)) + + meta <- list(protocol = "https", family = "Doe") + expect_silent(stop_if_invalid_credentials(meta)) + expect_null(x <- stop_if_invalid_credentials(meta)) + + meta <- list(protocol = "ssh") + expect_silent(stop_if_invalid_credentials(meta)) + expect_null(x <- stop_if_invalid_credentials(meta)) + + meta <- list(protocol = "ssh", family = "Doe") + expect_silent(stop_if_invalid_credentials(meta)) + expect_null(x <- stop_if_invalid_credentials(meta)) + + meta <- list( + given = "John", + family = "Doe", + email = "john.doe@mail.com", + orcid = "0000-0000-0000-0000", + github_user = "jdoe", + protocol = "ssh" + ) + + expect_silent(stop_if_invalid_credentials(meta)) + expect_null(x <- stop_if_invalid_credentials(meta)) +}) diff --git a/tests/testthat/test-stop_if_invalid_git_protocol.R b/tests/testthat/test-stop_if_invalid_git_protocol.R new file mode 100644 index 0000000..5452228 --- /dev/null +++ b/tests/testthat/test-stop_if_invalid_git_protocol.R @@ -0,0 +1,27 @@ +## stop_if_invalid_git_protocol() ---- + +test_that("stop_if_invalid_git_protocol() errors", { + expect_error( + stop_if_invalid_git_protocol(list(protocol = "ftp")), + "Argument 'protocol' must be equal to 'https' or 'ssh'", + fixed = TRUE + ) + + expect_error( + stop_if_invalid_git_protocol(list(protocol = "SSH")), + "Argument 'protocol' must be equal to 'https' or 'ssh'", + fixed = TRUE + ) + + expect_error( + stop_if_invalid_git_protocol(list(protocol = "")), + "Argument 'protocol' must be equal to 'https' or 'ssh'", + fixed = TRUE + ) +}) + +test_that("stop_if_invalid_git_protocol() works", { + expect_silent(stop_if_invalid_git_protocol(list(protocol = "https"))) + expect_silent(stop_if_invalid_git_protocol(list(protocol = "ssh"))) + expect_null(x <- stop_if_invalid_git_protocol(list(protocol = "ssh"))) +}) diff --git a/tests/testthat/test-stop_if_not_logical.R b/tests/testthat/test-stop_if_not_logical.R index a742bdc..65631f0 100644 --- a/tests/testthat/test-stop_if_not_logical.R +++ b/tests/testthat/test-stop_if_not_logical.R @@ -1,102 +1,92 @@ ## stop_if_not_logical() ---- -test_that("stop_if_not_logical() errors", { - quiet <- 12 - overwrite <- TRUE +test_that("stop_if_not_logical() errors - Vector", { + quiet <- NULL expect_error( stop_if_not_logical(quiet), - "Argument 'quiet' must be a logical of length 1.", - fixed = TRUE - ) - - expect_error( - stop_if_not_logical(quiet, overwrite), - "Argument 'quiet' must be a logical of length 1.", - fixed = TRUE - ) - - expect_error( - stop_if_not_logical(overwrite, quiet), - "Argument 'quiet' must be a logical of length 1.", + "The argument 'quiet' cannot be NULL.", fixed = TRUE ) quiet <- "string" - overwrite <- TRUE expect_error( stop_if_not_logical(quiet), - "Argument 'quiet' must be a logical of length 1.", + "The argument 'quiet' must be a logical of length 1.", fixed = TRUE ) - expect_error( - stop_if_not_logical(quiet, overwrite), - "Argument 'quiet' must be a logical of length 1.", - fixed = TRUE - ) + quiet <- c(TRUE, TRUE) expect_error( - stop_if_not_logical(overwrite, quiet), - "Argument 'quiet' must be a logical of length 1.", + stop_if_not_logical(quiet), + "The argument 'quiet' must be a logical of length 1.", fixed = TRUE ) - quiet <- NULL - overwrite <- TRUE + quiet <- NA expect_error( stop_if_not_logical(quiet), - "Argument 'quiet' must be a logical of length 1.", + "The argument 'quiet' cannot be NA.", fixed = TRUE ) +}) - expect_error( - stop_if_not_logical(quiet, overwrite), - "Argument 'quiet' must be a logical of length 1.", - fixed = TRUE - ) +test_that("stop_if_not_logical() errors - Vector", { + meta <- list() + meta$quiet <- NULL expect_error( - stop_if_not_logical(overwrite, quiet), - "Argument 'quiet' must be a logical of length 1.", + stop_if_not_logical(meta$quiet), + "The argument 'quiet' cannot be NULL.", fixed = TRUE ) - quiet <- c(TRUE, TRUE) - overwrite <- TRUE + meta <- list() + meta$quiet <- "string" expect_error( - stop_if_not_logical(quiet), - "Argument 'quiet' must be a logical of length 1.", + stop_if_not_logical(meta$quiet), + "The argument 'quiet' must be a logical of length 1.", fixed = TRUE ) + meta <- list() + meta$quiet <- c(TRUE, TRUE) + expect_error( - stop_if_not_logical(quiet, overwrite), - "Argument 'quiet' must be a logical of length 1.", + stop_if_not_logical(meta$quiet), + "The argument 'quiet' must be a logical of length 1.", fixed = TRUE ) + meta <- list() + meta$quiet <- NA + expect_error( - stop_if_not_logical(overwrite, quiet), - "Argument 'quiet' must be a logical of length 1.", + stop_if_not_logical(meta$quiet), + "The argument 'quiet' cannot be NA.", fixed = TRUE ) }) -test_that("stop_if_not_logical() works", { - quiet <- TRUE - overwrite <- FALSE - open <- FALSE - expect_silent(stop_if_not_logical()) - expect_null(x <- stop_if_not_logical()) +test_that("stop_if_not_logical() works - Vector", { + quiet <- TRUE + expect_silent(stop_if_not_logical(quiet)) + quiet <- FALSE expect_silent(stop_if_not_logical(quiet)) - expect_null(x <- stop_if_not_logical(quiet)) +}) + +test_that("stop_if_not_logical() works - List", { + meta <- list() + meta$quiet <- TRUE + expect_silent(stop_if_not_logical(meta$quiet)) - expect_silent(stop_if_not_logical(quiet, overwrite, open)) - expect_null(x <- stop_if_not_logical(quiet, open, overwrite)) + meta <- list() + meta$quiet <- FALSE + expect_silent(stop_if_not_logical(meta$quiet)) }) diff --git a/tests/testthat/test-stop_if_not_string.R b/tests/testthat/test-stop_if_not_string.R index 5f4d06f..3455327 100644 --- a/tests/testthat/test-stop_if_not_string.R +++ b/tests/testthat/test-stop_if_not_string.R @@ -1,102 +1,123 @@ ## stop_if_not_string() ---- -test_that("stop_if_not_string() errors", { - given <- 12 - family <- "Doe" +test_that("stop_if_not_string() errors - Vector", { + given <- NULL expect_error( stop_if_not_string(given), - "Argument 'given' must be a character of length 1.", + "The argument 'given' cannot be NULL.", fixed = TRUE ) + given <- 12 + expect_error( - stop_if_not_string(given, family), - "Argument 'given' must be a character of length 1.", + stop_if_not_string(given), + "The argument 'given' must be a character of length 1.", fixed = TRUE ) + given <- TRUE + expect_error( - stop_if_not_string(family, given), - "Argument 'given' must be a character of length 1.", + stop_if_not_string(given), + "The argument 'given' must be a character of length 1.", fixed = TRUE ) - given <- TRUE - family <- "Doe" + given <- c("Marie", "Jeanne") expect_error( stop_if_not_string(given), - "Argument 'given' must be a character of length 1.", + "The argument 'given' must be a character of length 1.", fixed = TRUE ) + given <- NA_character_ + expect_error( - stop_if_not_string(given, family), - "Argument 'given' must be a character of length 1.", + stop_if_not_string(given), + "The argument 'given' cannot be NA.", fixed = TRUE ) + given <- "" + expect_error( - stop_if_not_string(family, given), - "Argument 'given' must be a character of length 1.", + stop_if_not_string(given), + "The argument 'given' cannot be empty.", fixed = TRUE ) +}) - given <- NULL - family <- "Doe" + +test_that("stop_if_not_string() errors - List", { + meta <- list() + meta$given <- NULL expect_error( - stop_if_not_string(given), - "Argument 'given' must be a character of length 1.", + stop_if_not_string(meta$given), + "The argument 'given' cannot be NULL.", fixed = TRUE ) + meta <- list() + meta$given <- 12 + expect_error( - stop_if_not_string(given, family), - "Argument 'given' must be a character of length 1.", + stop_if_not_string(meta$given), + "The argument 'given' must be a character of length 1.", fixed = TRUE ) + meta <- list() + meta$given <- TRUE + expect_error( - stop_if_not_string(family, given), - "Argument 'given' must be a character of length 1.", + stop_if_not_string(meta$given), + "The argument 'given' must be a character of length 1.", fixed = TRUE ) - given <- c("Marie", "Jeanne") - family <- "Doe" + meta <- list() + meta$given <- c("Marie", "Jeanne") expect_error( - stop_if_not_string(given), - "Argument 'given' must be a character of length 1.", + stop_if_not_string(meta$given), + "The argument 'given' must be a character of length 1.", fixed = TRUE ) + meta <- list() + meta$given <- NA_character_ + expect_error( - stop_if_not_string(given, family), - "Argument 'given' must be a character of length 1.", + stop_if_not_string(meta$given), + "The argument 'given' cannot be NA.", fixed = TRUE ) + meta <- list() + meta$given <- "" + expect_error( - stop_if_not_string(family, given), - "Argument 'given' must be a character of length 1.", + stop_if_not_string(meta$given), + "The argument 'given' cannot be empty.", fixed = TRUE ) }) -test_that("stop_if_not_string() works", { - given <- "John" - family <- "Doe" - orcid <- "0000-0000-0000-0000" - expect_silent(stop_if_not_string()) - expect_null(x <- stop_if_not_string()) +test_that("stop_if_not_string() works - Vector", { + given <- "John" expect_silent(stop_if_not_string(given)) - expect_null(x <- stop_if_not_string(given)) +}) + + +test_that("stop_if_not_string() works - List", { + meta <- list() + meta$given <- "John" - expect_silent(stop_if_not_string(given, family, orcid)) - expect_null(x <- stop_if_not_string(given, orcid, family)) + expect_silent(stop_if_not_string(meta$given)) }) diff --git a/tests/testthat/test-stop_if_null_or_empty.R b/tests/testthat/test-stop_if_null_or_empty.R deleted file mode 100644 index d10b5bb..0000000 --- a/tests/testthat/test-stop_if_null_or_empty.R +++ /dev/null @@ -1,31 +0,0 @@ -## stop_if_null_or_empty() ---- - -test_that("stop_if_null_or_empty() errors", { - expect_error( - stop_if_null_or_empty(NULL, "given"), - "Argument 'given' is required but is NULL or empty.", - fixed = TRUE - ) - - expect_error( - stop_if_null_or_empty("", "given"), - "Argument 'given' is required but is NULL or empty.", - fixed = TRUE - ) - - expect_error( - stop_if_null_or_empty(character(0), "given"), - "Argument 'given' is required but is NULL or empty.", - fixed = TRUE - ) -}) - -test_that("stop_if_null_or_empty() works", { - expect_silent( - stop_if_null_or_empty("John", "given") - ) - - expect_null( - x <- stop_if_null_or_empty("John", "given") - ) -}) diff --git a/tests/testthat/test-ui_file_not_written.R b/tests/testthat/test-ui_file_not_written.R index 8b93888..6a072c4 100644 --- a/tests/testthat/test-ui_file_not_written.R +++ b/tests/testthat/test-ui_file_not_written.R @@ -1,25 +1,29 @@ ## ui_file_not_written() ---- -test_that("ui_file_not_written() works - verbose", { +test_that("ui_file_not_written() works - No quiet", { with_local_project({ - path <- file.path(".github", "dependabot.yaml") + initialize_project(quiet = TRUE) - expect_no_message(suppressMessages(ui_file_not_written(path))) - expect_null(x <- suppressMessages(ui_file_not_written(path))) + path <- file.path(".github", "dependabot.yaml") - expect_no_message(suppressMessages(ui_file_not_written( - path, - quiet = FALSE - ))) - expect_null(x <- suppressMessages(ui_file_not_written(path, quiet = FALSE))) + expect_snapshot({ + ui_file_not_written(path, quiet = FALSE) + }) }) }) -test_that("ui_file_not_written() works - quiet", { +test_that("ui_file_not_written() works - Quiet", { with_local_project({ + initialize_project(quiet = TRUE) + path <- file.path(".github", "dependabot.yaml") - expect_silent(ui_file_not_written(path, quiet = TRUE)) - expect_null(x <- ui_file_not_written(path, quiet = TRUE)) + expect_no_message({ + ui_file_not_written(path, quiet = TRUE) + }) + + expect_silent({ + ui_file_not_written(path, quiet = TRUE) + }) }) }) diff --git a/tests/testthat/test-ui_file_written.R b/tests/testthat/test-ui_file_written.R index 846b1ef..0238126 100644 --- a/tests/testthat/test-ui_file_written.R +++ b/tests/testthat/test-ui_file_written.R @@ -1,25 +1,29 @@ ## ui_file_written() ---- -test_that("ui_file_written() works - verbose", { +test_that("ui_file_written() works - No quiet", { with_local_project({ initialize_project(quiet = TRUE) - path <- build_abs_path(".github", "dependabot.yaml") - expect_no_message(suppressMessages(ui_file_written(path))) - expect_null(x <- suppressMessages(ui_file_written(path))) + path <- file.path(".github", "dependabot.yaml") - expect_no_message(suppressMessages(ui_file_written(path, quiet = FALSE))) - expect_null(x <- suppressMessages(ui_file_written(path, quiet = FALSE))) + expect_snapshot({ + ui_file_written(path, quiet = FALSE) + }) }) }) -test_that("ui_file_written() works - quiet", { +test_that("ui_file_written() works - Quiet", { with_local_project({ initialize_project(quiet = TRUE) - path <- build_abs_path(".github", "dependabot.yaml") + path <- file.path(".github", "dependabot.yaml") - expect_silent(ui_file_written(path, quiet = TRUE)) - expect_null(x <- ui_file_written(path, quiet = TRUE)) + expect_no_message({ + ui_file_written(path, quiet = TRUE) + }) + + expect_silent({ + ui_file_written(path, quiet = TRUE) + }) }) }) diff --git a/tests/testthat/test-ui_project_initialized.R b/tests/testthat/test-ui_project_initialized.R new file mode 100644 index 0000000..e8f9299 --- /dev/null +++ b/tests/testthat/test-ui_project_initialized.R @@ -0,0 +1,29 @@ +## ui_project_initialized() ---- + +test_that("ui_project_initialized() works - No quiet", { + with_local_project({ + initialize_project(quiet = TRUE) + + path <- basename(build_abs_path()) + + expect_snapshot({ + ui_project_initialized(path, quiet = FALSE) + }) + }) +}) + +test_that("ui_project_initialized() works - Quiet", { + with_local_project({ + initialize_project(quiet = TRUE) + + path <- basename(build_abs_path()) + + expect_no_message({ + ui_project_initialized(path, quiet = TRUE) + }) + + expect_silent({ + ui_project_initialized(path, quiet = TRUE) + }) + }) +}) diff --git a/tests/testthat/test-ui_r_profile_content.R b/tests/testthat/test-ui_r_profile_content.R index 4c78838..5f0b2d5 100644 --- a/tests/testthat/test-ui_r_profile_content.R +++ b/tests/testthat/test-ui_r_profile_content.R @@ -1,19 +1,15 @@ ## ui_r_profile_content() ---- -test_that("ui_r_profile_content() works", { +test_that("ui_r_profile_content() works - No quiet", { with_local_project({ - r_profile <- file.path(getwd(), ".Rprofile") + r_profile <- file.path(".Rprofile") withr::local_envvar( list(R_PROFILE_USER = r_profile) ) - expect_no_message(suppressMessages(ui_r_profile_content( - "This is a message" - ))) - - expect_null( - x <- suppressMessages(ui_r_profile_content("This is a message")) - ) + expect_snapshot({ + ui_r_profile_content("This is a message") + }) }) }) diff --git a/tests/testthat/test-ui_title.R b/tests/testthat/test-ui_title.R new file mode 100644 index 0000000..dcc27ea --- /dev/null +++ b/tests/testthat/test-ui_title.R @@ -0,0 +1,29 @@ +## ui_title() ---- + +test_that("ui_title() works - No quiet", { + with_local_project({ + initialize_project(quiet = TRUE) + + texte <- "Initialize project" + + expect_snapshot({ + ui_title(texte, quiet = FALSE) + }) + }) +}) + +test_that("ui_title() works - Quiet", { + with_local_project({ + initialize_project(quiet = TRUE) + + texte <- "Initialize project" + + expect_no_message({ + ui_title(texte, quiet = TRUE) + }) + + expect_silent({ + ui_title(texte, quiet = TRUE) + }) + }) +})