From 8579bce59f82e5c348515fcf4ee8ddfdce4b3d62 Mon Sep 17 00:00:00 2001 From: hsonne Date: Mon, 15 Feb 2021 20:34:56 +0100 Subject: [PATCH 01/49] Remove very last new line character --- R/testCreate.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/testCreate.R b/R/testCreate.R index d2a6a2b..88f7a8a 100644 --- a/R/testCreate.R +++ b/R/testCreate.R @@ -304,7 +304,7 @@ get_templates <- function() intro_4 = "# so that real cases are tested. \n#\n", hint_delete = "You should then delete this comment.", test_creator = "kwb.test::create_test_files()", - test_that_call = "test_that(\"() works\", {\n\n})\n", + test_that_call = "test_that(\"() works\", {\n\n})", fun_call = "()", fun_call_alone = " \n", fun_call_error = "expect_error(\n\n)\n", From b59041885fd31ec6af55d77068edd7d8163f8650 Mon Sep 17 00:00:00 2001 From: hsonne Date: Mon, 15 Feb 2021 21:53:42 +0100 Subject: [PATCH 02/49] Update Rd files with new Roxygen version --- DESCRIPTION | 2 +- man/create_test_files.Rd | 9 +++++++-- man/saveArgs.Rd | 7 +++++-- man/test_function.Rd | 7 +++++-- 4 files changed, 18 insertions(+), 7 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 864e5bf..c35f32f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -26,4 +26,4 @@ Remotes: github::kwb-r/kwb.utils Encoding: UTF-8 LazyData: TRUE -RoxygenNote: 6.1.1 +RoxygenNote: 7.1.1 diff --git a/man/create_test_files.Rd b/man/create_test_files.Rd index 5be4c0c..bb3c2d8 100644 --- a/man/create_test_files.Rd +++ b/man/create_test_files.Rd @@ -4,8 +4,13 @@ \alias{create_test_files} \title{Create Test Files} \usage{ -create_test_files(package_dir = getwd(), target_dir = NULL, - file_per_function = TRUE, full = FALSE, dbg = TRUE) +create_test_files( + package_dir = getwd(), + target_dir = NULL, + file_per_function = TRUE, + full = FALSE, + dbg = TRUE +) } \arguments{ \item{package_dir}{path to package directory in which to create the test diff --git a/man/saveArgs.Rd b/man/saveArgs.Rd index bce7975..8d59694 100644 --- a/man/saveArgs.Rd +++ b/man/saveArgs.Rd @@ -4,8 +4,11 @@ \alias{saveArgs} \title{Save the Arguments and Result of a Function Call} \usage{ -saveArgs(functionName, ..., - targetdir = kwb.utils::createDirectory(file.path(tempdir(), "test"))) +saveArgs( + functionName, + ..., + targetdir = kwb.utils::createDirectory(file.path(tempdir(), "test")) +) } \arguments{ \item{functionName}{name of the function to which the arguments to be saved diff --git a/man/test_function.Rd b/man/test_function.Rd index 4c7fd4e..9da047f 100644 --- a/man/test_function.Rd +++ b/man/test_function.Rd @@ -4,8 +4,11 @@ \alias{test_function} \title{Test if Function Reproduces Stored Results} \usage{ -test_function(functionName, testdata = loadArgs(functionName, - file.path(tempdir(), "test")), dbg = TRUE) +test_function( + functionName, + testdata = loadArgs(functionName, file.path(tempdir(), "test")), + dbg = TRUE +) } \arguments{ \item{functionName}{Name of the function to test. It must be callable, i.e. From df89bacb97f6759015946f78870f6d24a8a9b010 Mon Sep 17 00:00:00 2001 From: hsonne Date: Mon, 15 Feb 2021 21:56:44 +0100 Subject: [PATCH 03/49] Use kwb.utils::defaultIfNULL() --- R/testCreate.R | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/R/testCreate.R b/R/testCreate.R index 88f7a8a..5417d2e 100644 --- a/R/testCreate.R +++ b/R/testCreate.R @@ -41,18 +41,17 @@ create_test_files <- function( source_files <- file.path("R", dir("R")) - if (is.null(target_dir)) { - - target_dir <- file.path("tests", "testthat") - target_dir <- kwb.utils::createDirectory(target_dir, dbg = dbg) - } + target_dir <- kwb.utils::defaultIfNULL( + target_dir, + kwb.utils::createDirectory(file.path("tests", "testthat"), dbg = dbg) + ) - #source_file <- source_files[1] + #source_file <- source_files[3] for (source_file in source_files) { create_tests_for_file( - source_file, target_dir, pkg_name, file_per_function, full, dbg + source_file, test_dir = target_dir, pkg_name, file_per_function, full, dbg ) } } From fff9f4d9a9b006b4b8eb8d09bdcf4e0ca3b2c651 Mon Sep 17 00:00:00 2001 From: hsonne Date: Mon, 15 Feb 2021 21:59:34 +0100 Subject: [PATCH 04/49] Return early, avoid helper variable "skip" --- R/testCreate.R | 61 ++++++++++++++++++++++++-------------------------- 1 file changed, 29 insertions(+), 32 deletions(-) diff --git a/R/testCreate.R b/R/testCreate.R index 5417d2e..c8ed22c 100644 --- a/R/testCreate.R +++ b/R/testCreate.R @@ -63,41 +63,39 @@ create_tests_for_file <- function( dbg = TRUE ) { - skip <- FALSE - # One test file per source file? if (! file_per_function) { - filename <- sprintf("test-file-%s", basename(source_file)) - - test_file <- file.path(test_dir, filename) + test_file <- sprintf("%s/test-file-%s", test_dir, basename(source_file)) - skip <- warn_if_file_exists(test_file) + if (isTRUE(warn_if_file_exists(test_file))) { + return() + } } - if (! skip) { - - # Parse the source file, find the function definitions and generate test - # code for each function - codes <- get_test_codes_for_functions_in_file( - file = source_file, pkg_name, full = full - ) + # Parse the source file, find the function definitions and generate test + # code for each function + codes <- get_test_codes_for_functions_in_file( + file = source_file, + pkg_name = pkg_name, + test_dir = test_dir, + full = full + ) - # Get the text to be put as an introduction in each generated file - intro <- kwb.utils::resolve( - "intro", get_templates(), datetime = Sys.time(), user = kwb.utils::user() - ) + # Get the text to be put as an introduction in each generated file + intro <- kwb.utils::resolve( + "intro", get_templates(), datetime = Sys.time(), user = kwb.utils::user() + ) - if (file_per_function) { + if (file_per_function) { - # Write one file for each function in the source file - write_one_file_per_function(codes, test_dir, intro, dbg) + # Write one file for each function in the source file + write_one_file_per_function(codes, test_dir, intro, dbg) - } else { + } else { - # Write one file for all functions in the source file - write_test_file(c(intro, do.call(c, codes)), test_file, dbg) - } + # Write one file for all functions in the source file + write_test_file(c(intro, do.call(c, codes)), test_file, dbg) } } @@ -107,7 +105,6 @@ warn_if_file_exists <- function(test_file) exists <- file.exists(test_file) if (exists) { - message("Skipping exising file ", basename(test_file)) } @@ -158,13 +155,13 @@ get_test_codes_for_functions_in_file <- function(file, pkg_name, ...) # Create a test_that-call for each function lapply(kwb.utils::toNamedList(names(assignments)), function(fun_name) { - get_test_for_function( - fun_name = fun_name, - fun_args = assignments[[fun_name]][[3]][[2]], - pkg_name = pkg_name, - exports = exports, - ... - ) + get_test_for_function( + fun_name = fun_name, + fun_args = assignments[[fun_name]][[3]][[2]], + pkg_name = pkg_name, + exports = exports, + ... + ) }) } From 800d9a4f533b467e6cb84bad595958284b09252d Mon Sep 17 00:00:00 2001 From: hsonne Date: Mon, 15 Feb 2021 22:03:42 +0100 Subject: [PATCH 05/49] Skip functions for which test files exists Extract path_to_testfile() --- R/testCreate.R | 25 +++++++++++++++++-------- 1 file changed, 17 insertions(+), 8 deletions(-) diff --git a/R/testCreate.R b/R/testCreate.R index c8ed22c..2eb521c 100644 --- a/R/testCreate.R +++ b/R/testCreate.R @@ -128,20 +128,22 @@ write_one_file_per_function <- function(codes, test_dir, intro, dbg = TRUE) fun_name <- kwb.utils::getAttribute(code, "fun_name") - filename <- sprintf("test-function-%s.R", fun_name) - - test_file <- file.path(test_dir, filename) + test_file <- path_to_testfile(test_dir, fun_name) if (! warn_if_file_exists(test_file)) { - write_test_file(c(intro, code), test_file, dbg = dbg) } } } +# path_to_testfile ------------------------------------------------------------- +path_to_testfile <- function(test_dir, fun_name) +{ + sprintf("%s/test-function-%s.R", test_dir, fun_name) +} + # get_test_codes_for_functions_in_file ----------------------------------------- -#' @importFrom kwb.utils toNamedList -get_test_codes_for_functions_in_file <- function(file, pkg_name, ...) +get_test_codes_for_functions_in_file <- function(file, pkg_name, test_dir, ...) { # Get the expressions that represent assignments of function definitions assignments <- get_function_assignments(file) @@ -153,7 +155,13 @@ get_test_codes_for_functions_in_file <- function(file, pkg_name, ...) exports <- getNamespaceExports(pkg_name) # Create a test_that-call for each function - lapply(kwb.utils::toNamedList(names(assignments)), function(fun_name) { + kwb.utils::excludeNULL(dbg = FALSE, lapply( + stats::setNames(nm = names(assignments)), + FUN = function(fun_name) { + + if (warn_if_file_exists(path_to_testfile(test_dir, fun_name))) { + return() + } get_test_for_function( fun_name = fun_name, @@ -162,7 +170,8 @@ get_test_codes_for_functions_in_file <- function(file, pkg_name, ...) exports = exports, ... ) - }) + } + )) } # get_function_assignments ----------------------------------------------------- From 1725285a429920824804e7283777bf08d8c7bdfd Mon Sep 17 00:00:00 2001 From: hsonne Date: Mon, 15 Feb 2021 22:05:39 +0100 Subject: [PATCH 06/49] Compress code --- R/testCreate.R | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/R/testCreate.R b/R/testCreate.R index 2eb521c..7442eef 100644 --- a/R/testCreate.R +++ b/R/testCreate.R @@ -349,12 +349,6 @@ eval_text <- function(text, dbg = TRUE) #' @importFrom kwb.utils asColumnList resolve get_function_call_strings <- function(fun_name, arg_combis, pkg_name = "") { - templates <- get_templates() - - templates <- kwb.utils::resolve(templates, fun = fun_name, pkg = pkg_name) - - key <- ifelse(pkg_name == "", "pkg_fun_exported", "pkg_fun_private") - arg_strings <- "" if (nrow(arg_combis) > 0) { @@ -368,7 +362,14 @@ get_function_call_strings <- function(fun_name, arg_combis, pkg_name = "") arg_strings <- do.call(paste, paste_args) } - sprintf("%s(%s)", templates[[key]], arg_strings) + sprintf( + "%s(%s)", + kwb.utils::selectElements( + kwb.utils::resolve(get_templates(), fun = fun_name, pkg = pkg_name), + ifelse(pkg_name == "", "pkg_fun_exported", "pkg_fun_private") + ), + arg_strings + ) } # get_arg_combis --------------------------------------------------------------- From bc52ad200fafc436f33531302254b010f0fc178d Mon Sep 17 00:00:00 2001 From: hsonne Date: Mon, 15 Feb 2021 22:06:43 +0100 Subject: [PATCH 07/49] Use shortcut "f" for function name --- R/testCreate.R | 46 +++++++++++++++++++++++++++++++++++++++------- 1 file changed, 39 insertions(+), 7 deletions(-) diff --git a/R/testCreate.R b/R/testCreate.R index 7442eef..9e00e54 100644 --- a/R/testCreate.R +++ b/R/testCreate.R @@ -236,11 +236,23 @@ get_test_for_function_calls <- function( errors <- sapply(errors, get_error_message) + full_fun_name <- kwb.utils::resolve( + ifelse(exported, "pkg_fun_exported", "pkg_fun_private"), + templates_raw, + fun = fun_name, + pkg = pkg_name + ) + + pattern <- paste0("(^|\\s)", full_fun_name, "\\(") + + use_shortcut <- function(x) gsub(pattern, "f(", x) + expect_calls_fail <- sapply(seq_along(fail_indices), function(i) { kwb.utils::resolve( - "fun_call_error", templates_raw, - fun_call = call_strings[fail_indices[i]], + "fun_call_error", + templates_raw, + fun_call = use_shortcut(call_strings[fail_indices[i]]), quoted_error = gsub("\n", "\n# ", errors[i]) ) }) @@ -248,26 +260,46 @@ get_test_for_function_calls <- function( expect_calls_success <- sapply(success_indices, function(i) { kwb.utils::resolve( - "fun_call_alone", templates_raw, fun_call = call_strings[i] + "fun_call_alone", + templates_raw, + fun_call = use_shortcut(call_strings[i]) ) }) #call_strings[fails] <- sprintf("expect_error(%s)", call_strings[fails]) #test_that_body <- paste0(" ", call_strings, collapse = "\n") - test_that_body <- kwb.utils::collapsed( - c(expect_calls_success, expect_calls_fail) + shortcut <- get_shortcut_assignment(templates_raw, fun_name, pkg_name) + + test_that_body <- paste0( + " ", shortcut, "\n\n", + kwb.utils::collapsed(c(expect_calls_success, expect_calls_fail)) ) test_that_call <- kwb.utils::resolve( - "test_that_call", templates_raw, fun = fun_name, pkg = pkg_name, - pkg_fun = ifelse(exported, "", ""), + "test_that_call", + templates_raw, + fun = fun_name, + #pkg = pkg_name, + #pkg_fun = "f", #ifelse(exported, "", ""), test_that_body = paste0(test_that_body, "\n") ) structure(test_that_call, fun_name = fun_name) } +# get_shortcut_assignment ------------------------------------------------------ +get_shortcut_assignment <- function(templates, fun_name, pkg_name) +{ + sprintf( + "f <- %s", + kwb.utils::selectElements( + kwb.utils::resolve(templates, fun = fun_name, pkg = pkg_name), + ifelse(pkg_name == "", "pkg_fun_exported", "pkg_fun_private") + ) + ) +} + # single_quoted ---------------------------------------------------------------- single_quoted <- function(x) { From 94f932e3c400c98b583be3902950f6df22814ce2 Mon Sep 17 00:00:00 2001 From: hsonne Date: Mon, 15 Feb 2021 22:06:54 +0100 Subject: [PATCH 08/49] Update NAMESPACE --- NAMESPACE | 1 - 1 file changed, 1 deletion(-) diff --git a/NAMESPACE b/NAMESPACE index 068b43e..d2b5eaf 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -13,6 +13,5 @@ importFrom(kwb.utils,createDirectory) importFrom(kwb.utils,expandGrid) importFrom(kwb.utils,getAttribute) importFrom(kwb.utils,resolve) -importFrom(kwb.utils,toNamedList) importFrom(kwb.utils,user) importFrom(usethis,use_testthat) From fa28dc2f83ca520babd4aa2bbb3879e1a7615d35 Mon Sep 17 00:00:00 2001 From: mrustl Date: Tue, 16 Feb 2021 10:03:35 +0100 Subject: [PATCH 09/49] Move to GitHub actions * Run kwb.pkgbuild::use_ghactions() * Run kwb.pkgbuild::use_badge_ghactions() --- .Rbuildignore | 1 + .github/workflows/R-CMD-check.yaml | 81 ++++++++++++++++++++++++++++ .github/workflows/pkgdown.yaml | 49 +++++++++++++++++ .github/workflows/pr-commands.yaml | 51 ++++++++++++++++++ .github/workflows/test-coverage.yaml | 48 +++++++++++++++++ .travis.yml | 31 ----------- README.md | 4 +- appveyor.yml | 67 ----------------------- index.md | 4 +- 9 files changed, 234 insertions(+), 102 deletions(-) create mode 100644 .github/workflows/R-CMD-check.yaml create mode 100644 .github/workflows/pkgdown.yaml create mode 100644 .github/workflows/pr-commands.yaml create mode 100644 .github/workflows/test-coverage.yaml delete mode 100644 .travis.yml delete mode 100644 appveyor.yml diff --git a/.Rbuildignore b/.Rbuildignore index 2b00dd6..9993e05 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -8,3 +8,4 @@ ^docs\.* _pkgdown.yaml ^.gitlab-ci\.yml$ +^\.github$ diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml new file mode 100644 index 0000000..909fbdf --- /dev/null +++ b/.github/workflows/R-CMD-check.yaml @@ -0,0 +1,81 @@ +on: + push: + branches: + - master + - main + - dev + pull_request: + branches: + - master + - main + - dev + +name: R-CMD-check + +jobs: + R-CMD-check: + runs-on: ${{ matrix.config.os }} + + name: ${{ matrix.config.os }} (${{ matrix.config.r }}) + + strategy: + fail-fast: false + matrix: + config: + - {os: macOS-latest, r: 'release'} + - {os: ubuntu-20.04, r: 'release', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"} + - {os: windows-latest, r: 'devel'} + - {os: windows-latest, r: 'oldrel'} + - {os: windows-latest, r: 'release'} + + env: + R_REMOTES_NO_ERRORS_FROM_WARNINGS: true + RSPM: ${{ matrix.config.rspm }} + + steps: + - uses: actions/checkout@v2 + + - uses: r-lib/actions/setup-r@master + with: + r-version: ${{ matrix.config.r }} + + - uses: r-lib/actions/setup-pandoc@master + + - name: Query dependencies + run: | + install.packages('remotes') + saveRDS(remotes::dev_package_deps(dependencies = TRUE), "depends.Rds", version = 2) + shell: Rscript {0} + + - name: Cache R packages + if: runner.os != 'Windows' + uses: actions/cache@v1 + with: + path: ${{ env.R_LIBS_USER }} + key: ${{ runner.os }}-r-${{ matrix.config.r }}-3-${{ hashFiles('depends.Rds') }} + restore-keys: ${{ runner.os }}-r-${{ matrix.config.r }}-3- + + - name: Install system dependencies + if: runner.os == 'Linux' + env: + RHUB_PLATFORM: linux-x86_64-ubuntu-gcc + run: | + Rscript -e "remotes::install_github('r-hub/sysreqs')" + sysreqs=$(Rscript -e "cat(sysreqs::sysreq_commands('DESCRIPTION'))") + sudo -s eval "$sysreqs" + - name: Install dependencies + run: | + remotes::install_deps(dependencies = TRUE) + remotes::install_cran("rcmdcheck") + shell: Rscript {0} + + - name: Check + run: rcmdcheck::rcmdcheck(args = "--no-manual", error_on = "warning", check_dir = "check") + shell: Rscript {0} + + - name: Upload check results + if: failure() + uses: actions/upload-artifact@master + with: + name: ${{ runner.os }}-r${{ matrix.config.r }}-results + path: check diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml new file mode 100644 index 0000000..58a9d79 --- /dev/null +++ b/.github/workflows/pkgdown.yaml @@ -0,0 +1,49 @@ +on: + push: + branches: + - main + - master + - dev + +name: pkgdown + +jobs: + pkgdown: + runs-on: macOS-latest + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + steps: + - uses: actions/checkout@v2 + + - uses: r-lib/actions/setup-r@master + + - uses: r-lib/actions/setup-pandoc@master + + - name: Query dependencies + run: | + install.packages('remotes') + saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2) + writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version") + shell: Rscript {0} + + - name: Cache R packages + uses: actions/cache@v2 + with: + path: ${{ env.R_LIBS_USER }} + key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }} + restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1- + + - name: Install dependencies + run: | + remotes::install_deps(dependencies = TRUE) + install.packages("pkgdown", type = "binary") + shell: Rscript {0} + + - name: Install package + run: R CMD INSTALL . + + - name: Deploy package + run: | + git config --local user.email "actions@github.com" + git config --local user.name "GitHub Actions" + Rscript -e 'pkgdown::deploy_to_branch(new_process = FALSE)' diff --git a/.github/workflows/pr-commands.yaml b/.github/workflows/pr-commands.yaml new file mode 100644 index 0000000..0d3cb71 --- /dev/null +++ b/.github/workflows/pr-commands.yaml @@ -0,0 +1,51 @@ +on: + issue_comment: + types: [created] +name: Commands +jobs: + document: + if: startsWith(github.event.comment.body, '/document') + name: document + runs-on: macOS-latest + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + steps: + - uses: actions/checkout@v2 + - uses: r-lib/actions/pr-fetch@master + with: + repo-token: ${{ secrets.GITHUB_TOKEN }} + - uses: r-lib/actions/setup-r@master + - name: Install dependencies + run: Rscript -e 'install.packages(c("remotes", "roxygen2"))' -e 'remotes::install_deps(dependencies = TRUE)' + - name: Document + run: Rscript -e 'roxygen2::roxygenise()' + - name: commit + run: | + git add man/\* NAMESPACE + git commit -m 'Document' + - uses: r-lib/actions/pr-push@master + with: + repo-token: ${{ secrets.GITHUB_TOKEN }} + style: + if: startsWith(github.event.comment.body, '/style') + name: style + runs-on: macOS-latest + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + steps: + - uses: actions/checkout@v2 + - uses: r-lib/actions/pr-fetch@master + with: + repo-token: ${{ secrets.GITHUB_TOKEN }} + - uses: r-lib/actions/setup-r@master + - name: Install dependencies + run: Rscript -e 'install.packages("styler")' + - name: Style + run: Rscript -e 'styler::style_pkg()' + - name: commit + run: | + git add \*.R + git commit -m 'Style' + - uses: r-lib/actions/pr-push@master + with: + repo-token: ${{ secrets.GITHUB_TOKEN }} diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml new file mode 100644 index 0000000..4efc7ab --- /dev/null +++ b/.github/workflows/test-coverage.yaml @@ -0,0 +1,48 @@ +on: + push: + branches: + - master + - main + pull_request: + branches: + - master + - main + +name: test-coverage + +jobs: + test-coverage: + runs-on: macOS-latest + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + steps: + - uses: actions/checkout@v2 + + - uses: r-lib/actions/setup-r@master + + - uses: r-lib/actions/setup-pandoc@master + + - name: Query dependencies + run: | + install.packages('remotes') + saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2) + writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version") + shell: Rscript {0} + + - name: Cache R packages + uses: actions/cache@v1 + with: + path: ${{ env.R_LIBS_USER }} + key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }} + restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1- + + - name: Install dependencies + run: | + install.packages(c("remotes")) + remotes::install_deps(dependencies = TRUE) + remotes::install_cran("covr") + shell: Rscript {0} + + - name: Test coverage + run: covr::codecov() + shell: Rscript {0} diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index 3dab783..0000000 --- a/.travis.yml +++ /dev/null @@ -1,31 +0,0 @@ -############################################################################## -### Autogenerated with R package kwb.pkgbuild v0.1.1 -### (installed from 'Github (kwb-r/kwb.pkgbuild@0ac3694)' source code on 2019-09-06) -### by calling the function kwb.pkgbuild::use_autopkgdown("kwb.test") -### (file created at: 2019-09-09 14:46:26) -############################################################################## - - -language: r -sudo: required -cache: packages -r_packages: -- remotes -- covr -matrix: - include: - - r: devel - - r: release - after_success: - - Rscript -e 'covr::codecov()' - before_deploy: - - Rscript -e 'remotes::install_cran("pkgdown")' - deploy: - provider: script - script: Rscript -e 'pkgdown::deploy_site_github(verbose = TRUE)' - skip_cleanup: 'true' - on: - branch: - - master - - dev - - r: oldrel diff --git a/README.md b/README.md index 030bf1a..6ca7fa3 100644 --- a/README.md +++ b/README.md @@ -1,7 +1,7 @@ # kwb.test -[![Appveyor build status](https://ci.appveyor.com/api/projects/status/88r5ooo4lv40tl45/branch/master?svg=true)](https://ci.appveyor.com/project/KWB-R/kwb-test/branch/master)[![Build Status](https://travis-ci.org/KWB-R/kwb.test.svg?branch=master)](https://travis-ci.org/KWB-R/kwb.test) -[![Build Status](https://travis-ci.org/KWB-R/kwb.test.svg?branch=master)](https://travis-ci.org/KWB-R/kwb.test) +[![R-CMD-check](https://github.com/KWB-R/kwb.test/workflows/R-CMD-check/badge.svg)](https://github.com/KWB-R/kwb.test/actions?query=workflow%3AR-CMD-check) +[![pkgdown](https://github.com/KWB-R/kwb.test/workflows/pkgdown/badge.svg)](https://github.com/KWB-R/kwb.test/actions?query=workflow%3Apkgdown) [![codecov](https://codecov.io/github/KWB-R/kwb.test/branch/master/graphs/badge.svg)](https://codecov.io/github/KWB-R/kwb.test) [![lifecycle](https://img.shields.io/badge/lifecycle-stable-brightgreen.svg)](https://www.tidyverse.org/lifecycle/#stable) [![CRAN_Status_Badge](http://www.r-pkg.org/badges/version/kwb.test)](http://cran.r-project.org/package=kwb.test) diff --git a/appveyor.yml b/appveyor.yml deleted file mode 100644 index a50d690..0000000 --- a/appveyor.yml +++ /dev/null @@ -1,67 +0,0 @@ -############################################################################## -### Autogenerated with R package kwb.pkgbuild v0.1.1 -### (installed from 'Github (kwb-r/kwb.pkgbuild@0ac3694)' source code on 2019-09-06) -### by calling the function kwb.pkgbuild::use_appveyor() -### (file created at: 2019-09-10 10:27:41) -############################################################################## - - - -### Configuration copied from: -### https://raw.githubusercontent.com/tidyverse/readxl/5649e2643d25bb5b6353797fc48bbcbb0eb72f6d/appveyor.yml" -### But in addition also use two environment variables: -### - USE_RTools = true(for details see: https://github.com/KWB-R/kwb.pkgbuild/issues/37) -### - R_REMOTES_STANDALONE = true (for details see: https://github.com/r-lib/remotes#standalone-mode, https://github.com/krlmlr/r-appveyor/issues/135) - -# DO NOT CHANGE the "init" and "install" sections below - -# Download script file from GitHub -init: - ps: | - $ErrorActionPreference = "Stop" - Invoke-WebRequest http://raw.github.com/krlmlr/r-appveyor/master/scripts/appveyor-tool.ps1 -OutFile "..\appveyor-tool.ps1" - Import-Module '..\appveyor-tool.ps1' - -install: - ps: Bootstrap - -cache: - - C:\RLibrary - -# Adapt as necessary starting from here - -environment: -### Add RTools (for details see: https://github.com/KWB-R/kwb.pkgbuild/issues/37) - USE_RTOOLS: true -### Add R_REMOTES_STANDALONE(for details see: https://github.com/krlmlr/r-appveyor/issues/135 -### or https://github.com/r-lib/remotes#standalone-mode) - R_REMOTES_STANDALONE: true - -build_script: - - travis-tool.sh install_deps - -test_script: - - travis-tool.sh run_tests - -on_failure: - - 7z a failure.zip *.Rcheck\* - - appveyor PushArtifact failure.zip - -artifacts: - - path: '*.Rcheck\**\*.log' - name: Logs - - - path: '*.Rcheck\**\*.out' - name: Logs - - - path: '*.Rcheck\**\*.fail' - name: Logs - - - path: '*.Rcheck\**\*.Rout' - name: Logs - - - path: '\*_*.tar.gz' - name: Bits - - - path: '\*_*.zip' - name: Bits diff --git a/index.md b/index.md index aca4db5..a496803 100644 --- a/index.md +++ b/index.md @@ -1,5 +1,5 @@ -[![Appveyor build status](https://ci.appveyor.com/api/projects/status/88r5ooo4lv40tl45/branch/master?svg=true)](https://ci.appveyor.com/project/KWB-R/kwb-test/branch/master) -[![Build Status](https://travis-ci.org/KWB-R/kwb.test.svg?branch=master)](https://travis-ci.org/KWB-R/kwb.test) +[![R-CMD-check](https://github.com/KWB-R/kwb.test/workflows/R-CMD-check/badge.svg)](https://github.com/KWB-R/kwb.test/actions?query=workflow%3AR-CMD-check) +[![pkgdown](https://github.com/KWB-R/kwb.test/workflows/pkgdown/badge.svg)](https://github.com/KWB-R/kwb.test/actions?query=workflow%3Apkgdown) [![codecov](https://codecov.io/github/KWB-R/kwb.test/branch/master/graphs/badge.svg)](https://codecov.io/github/KWB-R/kwb.test) [![lifecycle](https://img.shields.io/badge/lifecycle-stable-brightgreen.svg)](https://www.tidyverse.org/lifecycle/#stable) [![CRAN_Status_Badge](http://www.r-pkg.org/badges/version/kwb.test)](http://cran.r-project.org/package=kwb.test) From 1d226471933abe1cbd2baae4c73f46ce835d674f Mon Sep 17 00:00:00 2001 From: mrustl Date: Tue, 16 Feb 2021 10:04:02 +0100 Subject: [PATCH 10/49] Update LICENSE year --- LICENSE | 2 +- LICENSE.md | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/LICENSE b/LICENSE index 472e305..9cd6c4a 100644 --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ MIT License -Copyright (c) 2017-2019 Kompetenzzentrum Wasser Berlin gGmbH (KWB) +Copyright (c) 2017-2021 Kompetenzzentrum Wasser Berlin gGmbH (KWB) Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/LICENSE.md b/LICENSE.md index b6bf8ea..366bdc5 100644 --- a/LICENSE.md +++ b/LICENSE.md @@ -1,6 +1,6 @@ # MIT License -Copyright (c) 2017-2019 Kompetenzzentrum Wasser Berlin gGmbH +Copyright (c) 2017-2021 Kompetenzzentrum Wasser Berlin gGmbH Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal From 4deee18c5615656f428f5bf3730a2c80232ea131 Mon Sep 17 00:00:00 2001 From: Michael Rustler Date: Thu, 18 Feb 2021 12:23:23 +0100 Subject: [PATCH 11/49] Delete docs (now deployed to "gh-pages") using GitHub actions "pkgdown" workflow --- docs/dev/LICENSE-text.html | 144 ----------- docs/dev/LICENSE.html | 129 ---------- docs/dev/authors.html | 132 ---------- docs/dev/docsearch.css | 148 ----------- docs/dev/docsearch.js | 85 ------- docs/dev/index.html | 176 ------------- docs/dev/jquery.sticky-kit.min.js | 11 - docs/dev/link.svg | 12 - docs/dev/pkgdown.css | 232 ------------------ docs/dev/pkgdown.js | 110 --------- docs/dev/pkgdown.yml | 8 - docs/dev/reference/create_test_files.html | 174 ------------- docs/dev/reference/index.html | 180 -------------- docs/dev/reference/loadArgs.html | 207 ---------------- docs/dev/reference/printTestMessage.html | 170 ------------- docs/dev/reference/saveArgs.html | 187 -------------- .../dev/reference/testColumnwiseIdentity.html | 162 ------------ docs/dev/reference/test_function.html | 212 ---------------- docs/dev/sitemap.xml | 24 -- 19 files changed, 2503 deletions(-) delete mode 100644 docs/dev/LICENSE-text.html delete mode 100644 docs/dev/LICENSE.html delete mode 100644 docs/dev/authors.html delete mode 100644 docs/dev/docsearch.css delete mode 100644 docs/dev/docsearch.js delete mode 100644 docs/dev/index.html delete mode 100644 docs/dev/jquery.sticky-kit.min.js delete mode 100644 docs/dev/link.svg delete mode 100644 docs/dev/pkgdown.css delete mode 100644 docs/dev/pkgdown.js delete mode 100644 docs/dev/pkgdown.yml delete mode 100644 docs/dev/reference/create_test_files.html delete mode 100644 docs/dev/reference/index.html delete mode 100644 docs/dev/reference/loadArgs.html delete mode 100644 docs/dev/reference/printTestMessage.html delete mode 100644 docs/dev/reference/saveArgs.html delete mode 100644 docs/dev/reference/testColumnwiseIdentity.html delete mode 100644 docs/dev/reference/test_function.html delete mode 100644 docs/dev/sitemap.xml diff --git a/docs/dev/LICENSE-text.html b/docs/dev/LICENSE-text.html deleted file mode 100644 index 8290cc5..0000000 --- a/docs/dev/LICENSE-text.html +++ /dev/null @@ -1,144 +0,0 @@ - - - - - - - - -License • kwb.test - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
- - - -
- -
-
-
-

License

-
- -
MIT License
-
-Copyright (c) 2017-2018 Kompetenzzentrum Wasser Berlin gGmbH (KWB)
-
-Permission is hereby granted, free of charge, to any person obtaining a copy
-of this software and associated documentation files (the "Software"), to deal
-in the Software without restriction, including without limitation the rights
-to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-copies of the Software, and to permit persons to whom the Software is
-furnished to do so, subject to the following conditions:
-
-The above copyright notice and this permission notice shall be included in all
-copies or substantial portions of the Software.
-
-THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
-OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
-SOFTWARE.
-
- -
- -
- - -
-
-

Developed by Hauke Sonnenberg.

-
- -
-

Site built with pkgdown.

-
- -
-
- - - - - - diff --git a/docs/dev/LICENSE.html b/docs/dev/LICENSE.html deleted file mode 100644 index 51e0578..0000000 --- a/docs/dev/LICENSE.html +++ /dev/null @@ -1,129 +0,0 @@ - - - - - - - - -MIT License • kwb.test - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
- - - -
- -
-
-
-

MIT License

-
- -
- -

Copyright (c) 2017-2018 Kompetenzzentrum Wasser Berlin gGmbH

-

Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the “Software”), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:

-

The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.

-

THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

-
- -
- -
- - -
-
-

Developed by Hauke Sonnenberg.

-
- -
-

Site built with pkgdown.

-
- -
-
- - - - - - diff --git a/docs/dev/authors.html b/docs/dev/authors.html deleted file mode 100644 index 05eb120..0000000 --- a/docs/dev/authors.html +++ /dev/null @@ -1,132 +0,0 @@ - - - - - - - - -Authors • kwb.test - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
- - - -
- -
-
-
-

Authors

-
- -
    -
  • -

    Hauke Sonnenberg. Author, maintainer. -

    -
    • -
  • -

    . Copyright holder. -

    -
    • -
- -
- -
- - -
-
-

Developed by Hauke Sonnenberg.

-
- -
-

Site built with pkgdown.

-
- -
-
- - - - - - diff --git a/docs/dev/docsearch.css b/docs/dev/docsearch.css deleted file mode 100644 index e5f1fe1..0000000 --- a/docs/dev/docsearch.css +++ /dev/null @@ -1,148 +0,0 @@ -/* Docsearch -------------------------------------------------------------- */ -/* - Source: https://github.com/algolia/docsearch/ - License: MIT -*/ - -.algolia-autocomplete { - display: block; - -webkit-box-flex: 1; - -ms-flex: 1; - flex: 1 -} - -.algolia-autocomplete .ds-dropdown-menu { - width: 100%; - min-width: none; - max-width: none; - padding: .75rem 0; - background-color: #fff; - background-clip: padding-box; - border: 1px solid rgba(0, 0, 0, .1); - box-shadow: 0 .5rem 1rem rgba(0, 0, 0, .175); -} - -@media (min-width:768px) { - .algolia-autocomplete .ds-dropdown-menu { - width: 175% - } -} - -.algolia-autocomplete .ds-dropdown-menu::before { - display: none -} - -.algolia-autocomplete .ds-dropdown-menu [class^=ds-dataset-] { - padding: 0; - background-color: rgb(255,255,255); - border: 0; - max-height: 80vh; -} - -.algolia-autocomplete .ds-dropdown-menu .ds-suggestions { - margin-top: 0 -} - -.algolia-autocomplete .algolia-docsearch-suggestion { - padding: 0; - overflow: visible -} - -.algolia-autocomplete .algolia-docsearch-suggestion--category-header { - padding: .125rem 1rem; - margin-top: 0; - font-size: 1.3em; - font-weight: 500; - color: #00008B; - border-bottom: 0 -} - -.algolia-autocomplete .algolia-docsearch-suggestion--wrapper { - float: none; - padding-top: 0 -} - -.algolia-autocomplete .algolia-docsearch-suggestion--subcategory-column { - float: none; - width: auto; - padding: 0; - text-align: left -} - -.algolia-autocomplete .algolia-docsearch-suggestion--content { - float: none; - width: auto; - padding: 0 -} - -.algolia-autocomplete .algolia-docsearch-suggestion--content::before { - display: none -} - -.algolia-autocomplete .ds-suggestion:not(:first-child) .algolia-docsearch-suggestion--category-header { - padding-top: .75rem; - margin-top: .75rem; - border-top: 1px solid rgba(0, 0, 0, .1) -} - -.algolia-autocomplete .ds-suggestion .algolia-docsearch-suggestion--subcategory-column { - display: block; - padding: .1rem 1rem; - margin-bottom: 0.1; - font-size: 1.0em; - font-weight: 400 - /* display: none */ -} - -.algolia-autocomplete .algolia-docsearch-suggestion--title { - display: block; - padding: .25rem 1rem; - margin-bottom: 0; - font-size: 0.9em; - font-weight: 400 -} - -.algolia-autocomplete .algolia-docsearch-suggestion--text { - padding: 0 1rem .5rem; - margin-top: -.25rem; - font-size: 0.8em; - font-weight: 400; - line-height: 1.25 -} - -.algolia-autocomplete .algolia-docsearch-footer { - width: 110px; - height: 20px; - z-index: 3; - margin-top: 10.66667px; - float: right; - font-size: 0; - line-height: 0; -} - -.algolia-autocomplete .algolia-docsearch-footer--logo { - background-image: url("data:image/svg+xml;utf8,"); - background-repeat: no-repeat; - background-position: 50%; - background-size: 100%; - overflow: hidden; - text-indent: -9000px; - width: 100%; - height: 100%; - display: block; - transform: translate(-8px); -} - -.algolia-autocomplete .algolia-docsearch-suggestion--highlight { - color: #FF8C00; - background: rgba(232, 189, 54, 0.1) -} - - -.algolia-autocomplete .algolia-docsearch-suggestion--text .algolia-docsearch-suggestion--highlight { - box-shadow: inset 0 -2px 0 0 rgba(105, 105, 105, .5) -} - -.algolia-autocomplete .ds-suggestion.ds-cursor .algolia-docsearch-suggestion--content { - background-color: rgba(192, 192, 192, .15) -} diff --git a/docs/dev/docsearch.js b/docs/dev/docsearch.js deleted file mode 100644 index b35504c..0000000 --- a/docs/dev/docsearch.js +++ /dev/null @@ -1,85 +0,0 @@ -$(function() { - - // register a handler to move the focus to the search bar - // upon pressing shift + "/" (i.e. "?") - $(document).on('keydown', function(e) { - if (e.shiftKey && e.keyCode == 191) { - e.preventDefault(); - $("#search-input").focus(); - } - }); - - $(document).ready(function() { - // do keyword highlighting - /* modified from https://jsfiddle.net/julmot/bL6bb5oo/ */ - var mark = function() { - - var referrer = document.URL ; - var paramKey = "q" ; - - if (referrer.indexOf("?") !== -1) { - var qs = referrer.substr(referrer.indexOf('?') + 1); - var qs_noanchor = qs.split('#')[0]; - var qsa = qs_noanchor.split('&'); - var keyword = ""; - - for (var i = 0; i < qsa.length; i++) { - var currentParam = qsa[i].split('='); - - if (currentParam.length !== 2) { - continue; - } - - if (currentParam[0] == paramKey) { - keyword = decodeURIComponent(currentParam[1].replace(/\+/g, "%20")); - } - } - - if (keyword !== "") { - $(".contents").unmark({ - done: function() { - $(".contents").mark(keyword); - } - }); - } - } - }; - - mark(); - }); -}); - -/* Search term highlighting ------------------------------*/ - -function matchedWords(hit) { - var words = []; - - var hierarchy = hit._highlightResult.hierarchy; - // loop to fetch from lvl0, lvl1, etc. - for (var idx in hierarchy) { - words = words.concat(hierarchy[idx].matchedWords); - } - - var content = hit._highlightResult.content; - if (content) { - words = words.concat(content.matchedWords); - } - - // return unique words - var words_uniq = [...new Set(words)]; - return words_uniq; -} - -function updateHitURL(hit) { - - var words = matchedWords(hit); - var url = ""; - - if (hit.anchor) { - url = hit.url_without_anchor + '?q=' + escape(words.join(" ")) + '#' + hit.anchor; - } else { - url = hit.url + '?q=' + escape(words.join(" ")); - } - - return url; -} diff --git a/docs/dev/index.html b/docs/dev/index.html deleted file mode 100644 index f0a998a..0000000 --- a/docs/dev/index.html +++ /dev/null @@ -1,176 +0,0 @@ - - - - - - - -Test whether Different Functions Return the Same • kwb.test - - - - - - - - - - -
-
- - - -
-
- - - - - -

Test whether Different Functions Return the Same

-
-

-Install from GitHub

-
if (! requireNamespace("devtools")) {
-  install.packages("devtools")
-}
-
-devtools::install_github("kwb-r/kwb.test")
-
-
-

-Usage

-

Load the package

-
library(kwb.test)
-

Define a function using saveArgs() to save arguments and result

-
squareSum <- function(a, b) {
-  result <- a * a + b * b
-  saveArgs("squareSum", args = list(a = a, b = b), result = result)
-  result
-}
-
-# Set global variable TESTMODE to "activate" saveArgs() in squareSum()
-TESTMODE <- TRUE
-
-# Call the function with different arguments
-squareSum(1, 2)
-squareSum(2, 3)
-squareSum(-1, -2)
-
-# The arguments and function results were saved here:
-dir(file.path(tempdir(), "test"))
-
-# Write a new (wrong) version of the function
-squareSum.new <- function(a, b) {
-  a * a - b * b
-}
-
-# Check if it returns the same results
-test_function("squareSum.new", loadArgs("squareSum"))
-
-# If no test data are given, loadArgs is called on the function to test,
-# i.e. testing squareSum on the test data created by the same function will
-# return TRUE if the function did not change in the meanwhile.
-test_function("squareSum")
-
-
- - - -
- - -
-

Developed by Hauke Sonnenberg.

-
- -
-

Site built with pkgdown.

-
- -
-
- - - - - diff --git a/docs/dev/jquery.sticky-kit.min.js b/docs/dev/jquery.sticky-kit.min.js deleted file mode 100644 index 1c16271..0000000 --- a/docs/dev/jquery.sticky-kit.min.js +++ /dev/null @@ -1,11 +0,0 @@ -/* Sticky-kit v1.1.2 | WTFPL | Leaf Corcoran 2015 | */ -/* - Source: https://github.com/leafo/sticky-kit - License: MIT -*/ -(function(){var b,f;b=this.jQuery||window.jQuery;f=b(window);b.fn.stick_in_parent=function(d){var A,w,J,n,B,K,p,q,k,E,t;null==d&&(d={});t=d.sticky_class;B=d.inner_scrolling;E=d.recalc_every;k=d.parent;q=d.offset_top;p=d.spacer;w=d.bottoming;null==q&&(q=0);null==k&&(k=void 0);null==B&&(B=!0);null==t&&(t="is_stuck");A=b(document);null==w&&(w=!0);J=function(a,d,n,C,F,u,r,G){var v,H,m,D,I,c,g,x,y,z,h,l;if(!a.data("sticky_kit")){a.data("sticky_kit",!0);I=A.height();g=a.parent();null!=k&&(g=g.closest(k)); -if(!g.length)throw"failed to find stick parent";v=m=!1;(h=null!=p?p&&a.closest(p):b("
"))&&h.css("position",a.css("position"));x=function(){var c,f,e;if(!G&&(I=A.height(),c=parseInt(g.css("border-top-width"),10),f=parseInt(g.css("padding-top"),10),d=parseInt(g.css("padding-bottom"),10),n=g.offset().top+c+f,C=g.height(),m&&(v=m=!1,null==p&&(a.insertAfter(h),h.detach()),a.css({position:"",top:"",width:"",bottom:""}).removeClass(t),e=!0),F=a.offset().top-(parseInt(a.css("margin-top"),10)||0)-q, -u=a.outerHeight(!0),r=a.css("float"),h&&h.css({width:a.outerWidth(!0),height:u,display:a.css("display"),"vertical-align":a.css("vertical-align"),"float":r}),e))return l()};x();if(u!==C)return D=void 0,c=q,z=E,l=function(){var b,l,e,k;if(!G&&(e=!1,null!=z&&(--z,0>=z&&(z=E,x(),e=!0)),e||A.height()===I||x(),e=f.scrollTop(),null!=D&&(l=e-D),D=e,m?(w&&(k=e+u+c>C+n,v&&!k&&(v=!1,a.css({position:"fixed",bottom:"",top:c}).trigger("sticky_kit:unbottom"))),eb&&!v&&(c-=l,c=Math.max(b-u,c),c=Math.min(q,c),m&&a.css({top:c+"px"})))):e>F&&(m=!0,b={position:"fixed",top:c},b.width="border-box"===a.css("box-sizing")?a.outerWidth()+"px":a.width()+"px",a.css(b).addClass(t),null==p&&(a.after(h),"left"!==r&&"right"!==r||h.append(a)),a.trigger("sticky_kit:stick")),m&&w&&(null==k&&(k=e+u+c>C+n),!v&&k)))return v=!0,"static"===g.css("position")&&g.css({position:"relative"}), -a.css({position:"absolute",bottom:d,top:"auto"}).trigger("sticky_kit:bottom")},y=function(){x();return l()},H=function(){G=!0;f.off("touchmove",l);f.off("scroll",l);f.off("resize",y);b(document.body).off("sticky_kit:recalc",y);a.off("sticky_kit:detach",H);a.removeData("sticky_kit");a.css({position:"",bottom:"",top:"",width:""});g.position("position","");if(m)return null==p&&("left"!==r&&"right"!==r||a.insertAfter(h),h.remove()),a.removeClass(t)},f.on("touchmove",l),f.on("scroll",l),f.on("resize", -y),b(document.body).on("sticky_kit:recalc",y),a.on("sticky_kit:detach",H),setTimeout(l,0)}};n=0;for(K=this.length;n - - - - - diff --git a/docs/dev/pkgdown.css b/docs/dev/pkgdown.css deleted file mode 100644 index 6ca2f37..0000000 --- a/docs/dev/pkgdown.css +++ /dev/null @@ -1,232 +0,0 @@ -/* Sticky footer */ - -/** - * Basic idea: https://philipwalton.github.io/solved-by-flexbox/demos/sticky-footer/ - * Details: https://github.com/philipwalton/solved-by-flexbox/blob/master/assets/css/components/site.css - * - * .Site -> body > .container - * .Site-content -> body > .container .row - * .footer -> footer - * - * Key idea seems to be to ensure that .container and __all its parents__ - * have height set to 100% - * - */ - -html, body { - height: 100%; -} - -body > .container { - display: flex; - height: 100%; - flex-direction: column; - - padding-top: 60px; -} - -body > .container .row { - flex: 1 0 auto; -} - -footer { - margin-top: 45px; - padding: 35px 0 36px; - border-top: 1px solid #e5e5e5; - color: #666; - display: flex; - flex-shrink: 0; -} -footer p { - margin-bottom: 0; -} -footer div { - flex: 1; -} -footer .pkgdown { - text-align: right; -} -footer p { - margin-bottom: 0; -} - -img.icon { - float: right; -} - -img { - max-width: 100%; -} - -/* Typographic tweaking ---------------------------------*/ - -.contents h1.page-header { - margin-top: calc(-60px + 1em); -} - -/* Section anchors ---------------------------------*/ - -a.anchor { - margin-left: -30px; - display:inline-block; - width: 30px; - height: 30px; - visibility: hidden; - - background-image: url(./link.svg); - background-repeat: no-repeat; - background-size: 20px 20px; - background-position: center center; -} - -.hasAnchor:hover a.anchor { - visibility: visible; -} - -@media (max-width: 767px) { - .hasAnchor:hover a.anchor { - visibility: hidden; - } -} - - -/* Fixes for fixed navbar --------------------------*/ - -.contents h1, .contents h2, .contents h3, .contents h4 { - padding-top: 60px; - margin-top: -40px; -} - -/* Static header placement on mobile devices */ -@media (max-width: 767px) { - .navbar-fixed-top { - position: absolute; - } - .navbar { - padding: 0; - } -} - - -/* Sidebar --------------------------*/ - -#sidebar { - margin-top: 30px; -} -#sidebar h2 { - font-size: 1.5em; - margin-top: 1em; -} - -#sidebar h2:first-child { - margin-top: 0; -} - -#sidebar .list-unstyled li { - margin-bottom: 0.5em; -} - -.orcid { - height: 16px; - vertical-align: middle; -} - -/* Reference index & topics ----------------------------------------------- */ - -.ref-index th {font-weight: normal;} - -.ref-index td {vertical-align: top;} -.ref-index .alias {width: 40%;} -.ref-index .title {width: 60%;} - -.ref-index .alias {width: 40%;} -.ref-index .title {width: 60%;} - -.ref-arguments th {text-align: right; padding-right: 10px;} -.ref-arguments th, .ref-arguments td {vertical-align: top;} -.ref-arguments .name {width: 20%;} -.ref-arguments .desc {width: 80%;} - -/* Nice scrolling for wide elements --------------------------------------- */ - -table { - display: block; - overflow: auto; -} - -/* Syntax highlighting ---------------------------------------------------- */ - -pre { - word-wrap: normal; - word-break: normal; - border: 1px solid #eee; -} - -pre, code { - background-color: #f8f8f8; - color: #333; -} - -pre code { - overflow: auto; - word-wrap: normal; - white-space: pre; -} - -pre .img { - margin: 5px 0; -} - -pre .img img { - background-color: #fff; - display: block; - height: auto; -} - -code a, pre a { - color: #375f84; -} - -a.sourceLine:hover { - text-decoration: none; -} - -.fl {color: #1514b5;} -.fu {color: #000000;} /* function */ -.ch,.st {color: #036a07;} /* string */ -.kw {color: #264D66;} /* keyword */ -.co {color: #888888;} /* comment */ - -.message { color: black; font-weight: bolder;} -.error { color: orange; font-weight: bolder;} -.warning { color: #6A0366; font-weight: bolder;} - -/* Clipboard --------------------------*/ - -.hasCopyButton { - position: relative; -} - -.btn-copy-ex { - position: absolute; - right: 0; - top: 0; - visibility: hidden; -} - -.hasCopyButton:hover button.btn-copy-ex { - visibility: visible; -} - -/* mark.js ----------------------------*/ - -mark { - background-color: rgba(255, 255, 51, 0.5); - border-bottom: 2px solid rgba(255, 153, 51, 0.3); - padding: 1px; -} - -/* vertical spacing after htmlwidgets */ -.html-widget { - margin-bottom: 10px; -} diff --git a/docs/dev/pkgdown.js b/docs/dev/pkgdown.js deleted file mode 100644 index de9bd72..0000000 --- a/docs/dev/pkgdown.js +++ /dev/null @@ -1,110 +0,0 @@ -/* http://gregfranko.com/blog/jquery-best-practices/ */ -(function($) { - $(function() { - - $("#sidebar") - .stick_in_parent({offset_top: 40}) - .on('sticky_kit:bottom', function(e) { - $(this).parent().css('position', 'static'); - }) - .on('sticky_kit:unbottom', function(e) { - $(this).parent().css('position', 'relative'); - }); - - $('body').scrollspy({ - target: '#sidebar', - offset: 60 - }); - - $('[data-toggle="tooltip"]').tooltip(); - - var cur_path = paths(location.pathname); - var links = $("#navbar ul li a"); - var max_length = -1; - var pos = -1; - for (var i = 0; i < links.length; i++) { - if (links[i].getAttribute("href") === "#") - continue; - var path = paths(links[i].pathname); - - var length = prefix_length(cur_path, path); - if (length > max_length) { - max_length = length; - pos = i; - } - } - - // Add class to parent
  • , and enclosing
  • if in dropdown - if (pos >= 0) { - var menu_anchor = $(links[pos]); - menu_anchor.parent().addClass("active"); - menu_anchor.closest("li.dropdown").addClass("active"); - } - }); - - function paths(pathname) { - var pieces = pathname.split("/"); - pieces.shift(); // always starts with / - - var end = pieces[pieces.length - 1]; - if (end === "index.html" || end === "") - pieces.pop(); - return(pieces); - } - - function prefix_length(needle, haystack) { - if (needle.length > haystack.length) - return(0); - - // Special case for length-0 haystack, since for loop won't run - if (haystack.length === 0) { - return(needle.length === 0 ? 1 : 0); - } - - for (var i = 0; i < haystack.length; i++) { - if (needle[i] != haystack[i]) - return(i); - } - - return(haystack.length); - } - - /* Clipboard --------------------------*/ - - function changeTooltipMessage(element, msg) { - var tooltipOriginalTitle=element.getAttribute('data-original-title'); - element.setAttribute('data-original-title', msg); - $(element).tooltip('show'); - element.setAttribute('data-original-title', tooltipOriginalTitle); - } - - if(Clipboard.isSupported()) { - $(document).ready(function() { - var copyButton = ""; - - $(".examples, div.sourceCode").addClass("hasCopyButton"); - - // Insert copy buttons: - $(copyButton).prependTo(".hasCopyButton"); - - // Initialize tooltips: - $('.btn-copy-ex').tooltip({container: 'body'}); - - // Initialize clipboard: - var clipboardBtnCopies = new Clipboard('[data-clipboard-copy]', { - text: function(trigger) { - return trigger.parentNode.textContent; - } - }); - - clipboardBtnCopies.on('success', function(e) { - changeTooltipMessage(e.trigger, 'Copied!'); - e.clearSelection(); - }); - - clipboardBtnCopies.on('error', function() { - changeTooltipMessage(e.trigger,'Press Ctrl+C or Command+C to copy'); - }); - }); - } -})(window.jQuery || window.$) diff --git a/docs/dev/pkgdown.yml b/docs/dev/pkgdown.yml deleted file mode 100644 index c98c9aa..0000000 --- a/docs/dev/pkgdown.yml +++ /dev/null @@ -1,8 +0,0 @@ -pandoc: 1.19.2.4 -pkgdown: 1.1.0 -pkgdown_sha: ~ -articles: [] -urls: - reference: https://kwb-r.github.io/kwb.test/reference - article: https://kwb-r.github.io/kwb.test/articles - diff --git a/docs/dev/reference/create_test_files.html b/docs/dev/reference/create_test_files.html deleted file mode 100644 index 5a75b0d..0000000 --- a/docs/dev/reference/create_test_files.html +++ /dev/null @@ -1,174 +0,0 @@ - - - - - - - - -Create Test Files — create_test_files • kwb.test - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    -
    - - - -
    - -
    -
    -
    -

    Create Test Files

    - Source: R/testCreate.R - -
    - -
    - -

    Create test files for each source file containing one - test_that call for each function in the package

    - -
    - - 
    create_test_files(package_dir = getwd(), file_per_function = TRUE,
-  full = FALSE, dbg = TRUE)
    - -

    Arguments

    - - - - - - - - - - - - - - - - - - -
    package_dir

    path to package directory in which to create the test -files

    file_per_function

    if TRUE (default), one test file -test-<function>.R is generated for each function, otherwise one test -file test-<source-file> is generated for each source file.

    full

    if TRUE, test calls with many argument combinations are -generated instead of only one call

    dbg

    if TRUE, debug messages are shown

    - -

    Details

    - -

    Existing test files will not be overwritten.

    - - -
    - -
    - -
    -
    -

    Developed by Hauke Sonnenberg.

    -
    - -
    -

    Site built with pkgdown.

    -
    - -
    -
    - - - - - - diff --git a/docs/dev/reference/index.html b/docs/dev/reference/index.html deleted file mode 100644 index c1c3df8..0000000 --- a/docs/dev/reference/index.html +++ /dev/null @@ -1,180 +0,0 @@ - - - - - - - - -Function reference • kwb.test - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    -
    - - - -
    - -
    -
    -
    -

    Reference

    -
    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    -

    All functions

    -

    -
    -

    create_test_files()

    -

    Create Test Files

    -

    loadArgs()

    -

    Load Function Arguments and Results From Files

    -

    printTestMessage()

    -

    Print a Test with its Result

    -

    saveArgs()

    -

    Save the Arguments and Result of a Function Call

    -

    testColumnwiseIdentity()

    -

    Check Corresponding Columns in two Data Frames for Identity

    -

    test_function()

    -

    Test if Function Reproduces Stored Results

    -
    - - -
    - -
    -
    -

    Developed by Hauke Sonnenberg.

    -
    - -
    -

    Site built with pkgdown.

    -
    - -
    -
    - - - - - - diff --git a/docs/dev/reference/loadArgs.html b/docs/dev/reference/loadArgs.html deleted file mode 100644 index 6b4c1ae..0000000 --- a/docs/dev/reference/loadArgs.html +++ /dev/null @@ -1,207 +0,0 @@ - - - - - - - - -Load Function Arguments and Results From Files — loadArgs • kwb.test - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    -
    - - - -
    - -
    -
    -
    -

    Load Function Arguments and Results From Files

    - Source: R/testMain.R - -
    - -
    - -

    Read the function arguments and function results that were stored in RData -files (in objects args and result, respectively) by a previous -call of saveArgs.

    - -
    - - 
    loadArgs(functionName = NULL, data.dir = file.path(tempdir(), "test"))
    - -

    Arguments

    - - - - - - - - - - -
    functionName

    Name of the function to load arguments and results for. -The name is used to create a search pattern for RData files in -data.dir.

    data.dir

    Directory in which to look for RData files matching -args_<functionName>_<hhmmss>_<no>.RData. The default is the -subfolder test in tempdir().

    - -

    Value

    - -

    list with as many items as there were files args_<functionName>_* - in the directory given in data.dir. Each list element has two - components: args containing the arguments that were given to - the function and result containing what the function returned.

    - -

    See also

    - -

    saveArgs

    - - -

    Examples

    - 
    
-# Define a function that stores its arguments and result with saveArgs
-double <- function(x) {
-  result <- 2 * x
-  saveArgs("double", args = list(x = x), result = result)
-  result
-}
-
-# Set global variable TESTMODE to "activate" saveArgs() in double()
-TESTMODE <- TRUE
-
-# Call the function a couple of times
-double(4)
    #> [Set global variable TESTMODE to FALSE to prevent this message]
-#> Save args to 'double' (y, n)? 
    #> [1] 8
    double(-99)
    #> [Set global variable TESTMODE to FALSE to prevent this message]
-#> Save args to 'double' (y, n)? 
    #> [1] -198
    double(1:10)
    #> [Set global variable TESTMODE to FALSE to prevent this message]
-#> Save args to 'double' (y, n)? 
    #>  [1]  2  4  6  8 10 12 14 16 18 20
    
-# Load what was stored behind the scenes
-testdata <- loadArgs("double")
    #> Error: No such file: 'test' in
-#>   '/tmp/RtmpmHUyR1'.
-#> Available files:
-#>   ''
    
-# "Deactivate" saveArgs() in double()
-TESTMODE <- FALSE
-
-# Rerun the function with the stored arguments
-results <- lapply(testdata, function(x) do.call("double", x$args))
    #> Error in lapply(testdata, function(x) do.call("double", x$args)): object 'testdata' not found
    
-# Compare the new with the old results
-identical(results, lapply(testdata, "[[", "result"))
    #> Error in identical(results, lapply(testdata, "[[", "result")): object 'results' not found
    -
    - -
    - -
    -
    -

    Developed by Hauke Sonnenberg.

    -
    - -
    -

    Site built with pkgdown.

    -
    - -
    -
    - - - - - - diff --git a/docs/dev/reference/printTestMessage.html b/docs/dev/reference/printTestMessage.html deleted file mode 100644 index c03724c..0000000 --- a/docs/dev/reference/printTestMessage.html +++ /dev/null @@ -1,170 +0,0 @@ - - - - - - - - -Print a Test with its Result — printTestMessage • kwb.test - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    -
    - - - -
    - -
    -
    -
    -

    Print a Test with its Result

    - Source: R/testMain.R - -
    - -
    - -

    Print a test with its result as a message and return the message as a -character string

    - -
    - - 
    printTestMessage(testexpression, testresult, newline = TRUE)
    - -

    Arguments

    - - - - - - - - - - - - - - -
    testexpression

    text description of what was tested

    testresult

    boolean result (of length one) of the test

    newline

    if TRUE (default) a new line character is appended -to the message shown.

    - -

    Value

    - -

    the message that was shown as a character string

    - - -

    Examples

    - 
    printTestMessage("apple == apple", 1 == 1)
    #> apple == apple? TRUE
    #> [1] TRUE
    printTestMessage("apple == pear", 1 == 2)
    #> apple == pear? FALSE
    #> [1] FALSE
    -
    - -
    - -
    -
    -

    Developed by Hauke Sonnenberg.

    -
    - -
    -

    Site built with pkgdown.

    -
    - -
    -
    - - - - - - diff --git a/docs/dev/reference/saveArgs.html b/docs/dev/reference/saveArgs.html deleted file mode 100644 index f194487..0000000 --- a/docs/dev/reference/saveArgs.html +++ /dev/null @@ -1,187 +0,0 @@ - - - - - - - - -Save the Arguments and Result of a Function Call — saveArgs • kwb.test - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    -
    - - - -
    - -
    -
    -
    -

    Save the Arguments and Result of a Function Call

    - Source: R/testMain.R - -
    - -
    - -

    Save the list of named arguments given in ... to an RData file -args_<functionName>_<hhmmss>_<no>.RData in the directory given in -targetdir. This function can be used to log the inputs given to a -function together with the result returned by the function. -test_function can then be used to check whether another version -of the function (e.g. obtained by code cleaning) can reproduce the stored -results from the stored arguments. Check out the example on the help page for -test_function.

    - -
    - - 
    saveArgs(functionName, ...,
-  targetdir = kwb.utils::createDirectory(file.path(tempdir(), "test")))
    - -

    Arguments

    - - - - - - - - - - - - - - -
    functionName

    name of the function to which the arguments to be saved -belong. It will be used to generate a file name for the RData file.

    ...

    named arguments representing the arguments that have been given -to the function functionName.

    targetdir

    directory in which to store the objects given in ... -Default: subdirectory test in tempdir()

    - -

    Value

    - -

    path to the file written (invisibly)

    - -

    See also

    - -

    loadArgs

    - - -
    - -
    - -
    -
    -

    Developed by Hauke Sonnenberg.

    -
    - -
    -

    Site built with pkgdown.

    -
    - -
    -
    - - - - - - diff --git a/docs/dev/reference/testColumnwiseIdentity.html b/docs/dev/reference/testColumnwiseIdentity.html deleted file mode 100644 index 98aab7f..0000000 --- a/docs/dev/reference/testColumnwiseIdentity.html +++ /dev/null @@ -1,162 +0,0 @@ - - - - - - - - -Check Corresponding Columns in two Data Frames for Identity — testColumnwiseIdentity • kwb.test - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    -
    - - - -
    - -
    -
    -
    -

    Check Corresponding Columns in two Data Frames for Identity

    - Source: R/testMain.R - -
    - -
    - -

    For all columns in the first data frame, check if the second data frame -has identical values in columns of the same name

    - -
    - - 
    testColumnwiseIdentity(...)
    - -

    Arguments

    - - - - - - -
    ...

    two data frames given as named arguments. The argument names will -appear in the output. By doing so you can give a longer expression that -returns a data frame a short name 'on-the-fly'.

    - - -

    Examples

    - 
    # Compare two identical data frames. Give them short names data.1 and data.2
-testColumnwiseIdentity(data.1 = (x <- data.frame(a = 1:2, b = 2:3)),
-                       data.2 = x)
    #> identical(data.1[, "a"], data.2[, "a"])? TRUE
    #> identical(data.1[, "b"], data.2[, "b"])? TRUE
    
-# Compare two data frames differing in one column
-testColumnwiseIdentity(A = data.frame(x = 1:2, y = 2:3),
-                       B = data.frame(x = 1:2, y = 3:4))
    #> identical(A[, "x"], B[, "x"])? TRUE
    #> identical(A[, "y"], B[, "y"])? FALSE
    -
    - -
    - -
    -
    -

    Developed by Hauke Sonnenberg.

    -
    - -
    -

    Site built with pkgdown.

    -
    - -
    -
    - - - - - - diff --git a/docs/dev/reference/test_function.html b/docs/dev/reference/test_function.html deleted file mode 100644 index 522009e..0000000 --- a/docs/dev/reference/test_function.html +++ /dev/null @@ -1,212 +0,0 @@ - - - - - - - - -Test if Function Reproduces Stored Results — test_function • kwb.test - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    -
    - - - -
    - -
    -
    -
    -

    Test if Function Reproduces Stored Results

    - Source: R/testMain.R - -
    - -
    - -

    Call the function functionName with the arguments contained in -testdata and compare the results with the results in testdata -for identity.

    - -
    - - 
    test_function(functionName, testdata = loadArgs(functionName,
-  file.path(tempdir(), "test")), dbg = TRUE)
    - -

    Arguments

    - - - - - - - - - - - - - - -
    functionName

    Name of the function to test. It must be callable, i.e. -either defined in the global environment or on the search path.

    testdata

    List of lists containing function arguments (in elemenet -args) and results (in element result), just as returned by - loadArgs. If no testdata are given, it is tried to - load test data by calling loadArgs on functionName.

    dbg

    if TRUE (default) debug messages are shown

    - -

    Value

    - -

    TRUE If the function functionName is able to reproduce - the same results as given in the result elements in testdata - for all the argument combinations given in the args elements in - testdata.

    - - -

    Examples

    - 
    # Define a function using saveArgs() to save arguments and result
-squareSum <- function(a, b) {
-  result <- a * a + b * b
-  saveArgs("squareSum", args = list(a = a, b = b), result = result)
-  result
-}
-
-# Set global variable TESTMODE to "activate" saveArgs() in squareSum()
-TESTMODE <- TRUE
-
-# Call the function with different arguments
-squareSum(1, 2)
    #> [Set global variable TESTMODE to FALSE to prevent this message]
-#> Save args to 'squareSum' (y, n)? 
    #> [1] 5
    squareSum(2, 3)
    #> [Set global variable TESTMODE to FALSE to prevent this message]
-#> Save args to 'squareSum' (y, n)? 
    #> [1] 13
    squareSum(-1, -2)
    #> [Set global variable TESTMODE to FALSE to prevent this message]
-#> Save args to 'squareSum' (y, n)? 
    #> [1] 5
    
-# The arguments and function results were saved here:
-dir(file.path(tempdir(), "test"))
    #> character(0)
    
-# Write a new (wrong) version of the function
-squareSum.new <- function(a, b) {
-  a * a - b * b
-}
-
-# Check if it returns the same results
-test_function("squareSum.new", loadArgs("squareSum"))
    #> Error: No such file: 'test' in
-#>   '/tmp/RtmpmHUyR1'.
-#> Available files:
-#>   ''
    
-# If no test data are given, loadArgs is called on the function to test,
-# i.e. testing squareSum on the test data created by the same function will
-# return TRUE if the function did not change in the meanwhile.
-test_function("squareSum")
    #> Error: No such file: 'test' in
-#>   '/tmp/RtmpmHUyR1'.
-#> Available files:
-#>   ''
    -
    - -
    - -
    -
    -

    Developed by Hauke Sonnenberg.

    -
    - -
    -

    Site built with pkgdown.

    -
    - -
    -
    - - - - - - diff --git a/docs/dev/sitemap.xml b/docs/dev/sitemap.xml deleted file mode 100644 index ab777ed..0000000 --- a/docs/dev/sitemap.xml +++ /dev/null @@ -1,24 +0,0 @@ - - - - https://kwb-r.github.io/kwb.test/index.html - - - https://kwb-r.github.io/kwb.test/reference/create_test_files.html - - - https://kwb-r.github.io/kwb.test/reference/loadArgs.html - - - https://kwb-r.github.io/kwb.test/reference/printTestMessage.html - - - https://kwb-r.github.io/kwb.test/reference/saveArgs.html - - - https://kwb-r.github.io/kwb.test/reference/testColumnwiseIdentity.html - - - https://kwb-r.github.io/kwb.test/reference/test_function.html - - From 1a62356d273e16898794b9184b73e47b42ce5daa Mon Sep 17 00:00:00 2001 From: hsonne Date: Sun, 16 Jul 2023 08:57:02 +0200 Subject: [PATCH 12/49] Exclude files starting with dot, use full.names --- R/testCreate.R | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/R/testCreate.R b/R/testCreate.R index 9e00e54..7ace0e4 100644 --- a/R/testCreate.R +++ b/R/testCreate.R @@ -27,9 +27,7 @@ create_test_files <- function( full = FALSE, dbg = TRUE ) { - if (FALSE) { - package_dir = getwd(); file_per_function = TRUE; full = FALSE; dbg = TRUE - } + #package_dir = getwd(); file_per_function = TRUE; full = FALSE; dbg = TRUE pkg_name <- basename(package_dir) @@ -39,7 +37,7 @@ create_test_files <- function( usethis::use_testthat() - source_files <- file.path("R", dir("R")) + source_files <- dir("R", pattern = "^[^.].*\\.[rR]$", full.names = TRUE) target_dir <- kwb.utils::defaultIfNULL( target_dir, From d04a6d164906b9bbed8209162b08ac261c67c0a6 Mon Sep 17 00:00:00 2001 From: hsonne Date: Sun, 16 Jul 2023 08:58:46 +0200 Subject: [PATCH 13/49] Rename file to create_test_files.R according to contained function --- R/{testCreate.R => create_test_files.R} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename R/{testCreate.R => create_test_files.R} (100%) diff --git a/R/testCreate.R b/R/create_test_files.R similarity index 100% rename from R/testCreate.R rename to R/create_test_files.R From 166262eb309a5e7e264e0564454ca963f80b7b69 Mon Sep 17 00:00:00 2001 From: hsonne Date: Sun, 16 Jul 2023 09:02:54 +0200 Subject: [PATCH 14/49] Simplify create_test_files() --- R/create_test_files.R | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/R/create_test_files.R b/R/create_test_files.R index 7ace0e4..816d5da 100644 --- a/R/create_test_files.R +++ b/R/create_test_files.R @@ -37,19 +37,23 @@ create_test_files <- function( usethis::use_testthat() - source_files <- dir("R", pattern = "^[^.].*\\.[rR]$", full.names = TRUE) + scripts <- dir("R", pattern = "^[^.].*\\.[rR]$", full.names = TRUE) - target_dir <- kwb.utils::defaultIfNULL( - target_dir, - kwb.utils::createDirectory(file.path("tests", "testthat"), dbg = dbg) - ) + if (is.null(target_dir)) { + target_dir <- kwb.utils::createDirectory("tests/testthat", dbg = dbg) + } - #source_file <- source_files[3] + #script <- scripts[3] - for (source_file in source_files) { + for (script in scripts) { create_tests_for_file( - source_file, test_dir = target_dir, pkg_name, file_per_function, full, dbg + script, + test_dir = target_dir, + pkg_name = pkg_name, + file_per_function = file_per_function, + full = full, + dbg = dbg ) } } From 72ee65b2ab0ed45478ae01cbb718fc412f4518dd Mon Sep 17 00:00:00 2001 From: hsonne Date: Sun, 16 Jul 2023 09:06:43 +0200 Subject: [PATCH 15/49] Move warn_if_file_exists() to new file utils.R --- R/create_test_files.R | 12 ------------ R/utils.R | 11 +++++++++++ 2 files changed, 11 insertions(+), 12 deletions(-) create mode 100644 R/utils.R diff --git a/R/create_test_files.R b/R/create_test_files.R index 816d5da..4f9844d 100644 --- a/R/create_test_files.R +++ b/R/create_test_files.R @@ -101,18 +101,6 @@ create_tests_for_file <- function( } } -# warn_if_file_exists ---------------------------------------------------------- -warn_if_file_exists <- function(test_file) -{ - exists <- file.exists(test_file) - - if (exists) { - message("Skipping exising file ", basename(test_file)) - } - - exists -} - # write_test_file -------------------------------------------------------------- #' @importFrom kwb.utils catAndRun write_test_file <- function(code, test_file, dbg = TRUE) diff --git a/R/utils.R b/R/utils.R new file mode 100644 index 0000000..0bba558 --- /dev/null +++ b/R/utils.R @@ -0,0 +1,11 @@ +# warn_if_file_exists ---------------------------------------------------------- +warn_if_file_exists <- function(test_file) +{ + exists <- file.exists(test_file) + + if (exists) { + message("Skipping exising file ", basename(test_file)) + } + + exists +} From e8863bf766f8761f7fa55bd343807e6c4cc2dce9 Mon Sep 17 00:00:00 2001 From: hsonne Date: Sun, 16 Jul 2023 09:39:24 +0200 Subject: [PATCH 16/49] Move functions to different script files --- DESCRIPTION | 2 +- R/create_test_files.R | 331 ++--------------------- R/get_test_codes_for_functions_in_file.R | 148 ++++++++++ R/get_test_for_function_calls.R | 153 +++++++++++ R/helpers.R | 164 +++++++++++ R/testColumnwiseIdentity.R | 64 +++++ R/testMain.R | 316 ---------------------- R/test_function.R | 97 +++++++ R/utils.R | 6 + man/create_test_files.Rd | 2 +- man/loadArgs.Rd | 2 +- man/printTestMessage.Rd | 2 +- man/saveArgs.Rd | 2 +- man/testColumnwiseIdentity.Rd | 2 +- man/test_function.Rd | 2 +- 15 files changed, 655 insertions(+), 638 deletions(-) create mode 100644 R/get_test_codes_for_functions_in_file.R create mode 100644 R/get_test_for_function_calls.R create mode 100644 R/helpers.R create mode 100644 R/testColumnwiseIdentity.R delete mode 100644 R/testMain.R create mode 100644 R/test_function.R diff --git a/DESCRIPTION b/DESCRIPTION index c35f32f..19837db 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -26,4 +26,4 @@ Remotes: github::kwb-r/kwb.utils Encoding: UTF-8 LazyData: TRUE -RoxygenNote: 7.1.1 +RoxygenNote: 7.2.3 diff --git a/R/create_test_files.R b/R/create_test_files.R index 4f9844d..06d6b7f 100644 --- a/R/create_test_files.R +++ b/R/create_test_files.R @@ -61,14 +61,18 @@ create_test_files <- function( # create_tests_for_file -------------------------------------------------------- #' @importFrom kwb.utils resolve user create_tests_for_file <- function( - source_file, test_dir, pkg_name, file_per_function = TRUE, full = FALSE, + script, + test_dir, + pkg_name, + file_per_function = TRUE, + full = FALSE, dbg = TRUE ) { # One test file per source file? - if (! file_per_function) { + if (!file_per_function) { - test_file <- sprintf("%s/test-file-%s", test_dir, basename(source_file)) + test_file <- sprintf("%s/test-file-%s", test_dir, basename(script)) if (isTRUE(warn_if_file_exists(test_file))) { return() @@ -78,7 +82,7 @@ create_tests_for_file <- function( # Parse the source file, find the function definitions and generate test # code for each function codes <- get_test_codes_for_functions_in_file( - file = source_file, + file = script, pkg_name = pkg_name, test_dir = test_dir, full = full @@ -86,7 +90,10 @@ create_tests_for_file <- function( # Get the text to be put as an introduction in each generated file intro <- kwb.utils::resolve( - "intro", get_templates(), datetime = Sys.time(), user = kwb.utils::user() + "intro", + get_templates(), + datetime = Sys.time(), + user = kwb.utils::user() ) if (file_per_function) { @@ -101,15 +108,6 @@ create_tests_for_file <- function( } } -# write_test_file -------------------------------------------------------------- -#' @importFrom kwb.utils catAndRun -write_test_file <- function(code, test_file, dbg = TRUE) -{ - kwb.utils::catAndRun(dbg = dbg, paste("Writing", test_file), { - writeLines(code, test_file) - }) -} - # write_one_file_per_function -------------------------------------------------- #' @importFrom kwb.utils getAttribute write_one_file_per_function <- function(codes, test_dir, intro, dbg = TRUE) @@ -126,309 +124,12 @@ write_one_file_per_function <- function(codes, test_dir, intro, dbg = TRUE) } } -# path_to_testfile ------------------------------------------------------------- -path_to_testfile <- function(test_dir, fun_name) -{ - sprintf("%s/test-function-%s.R", test_dir, fun_name) -} - -# get_test_codes_for_functions_in_file ----------------------------------------- -get_test_codes_for_functions_in_file <- function(file, pkg_name, test_dir, ...) -{ - # Get the expressions that represent assignments of function definitions - assignments <- get_function_assignments(file) - - # Name the assignments according to the function names - names(assignments) <- sapply(assignments, function(x) as.character(x[[2]])) - - # Get the names of the exported functions - exports <- getNamespaceExports(pkg_name) - - # Create a test_that-call for each function - kwb.utils::excludeNULL(dbg = FALSE, lapply( - stats::setNames(nm = names(assignments)), - FUN = function(fun_name) { - - if (warn_if_file_exists(path_to_testfile(test_dir, fun_name))) { - return() - } - - get_test_for_function( - fun_name = fun_name, - fun_args = assignments[[fun_name]][[3]][[2]], - pkg_name = pkg_name, - exports = exports, - ... - ) - } - )) -} - -# get_function_assignments ----------------------------------------------------- -get_function_assignments <- function(file) -{ - code <- as.list(parse(file)) - - #expr <- code[[2]] - - is_function_assignment <- sapply(code, function(expr) { - - ok <- as.character(expr[[1]]) == "<-" - - ok && length(expr) >= 3 && as.character(expr[[3]][[1]]) == "function" - }) - - code[is_function_assignment] -} - -# get_test_for_function -------------------------------------------------------- -get_test_for_function <- function( - fun_name, fun_args, pkg_name, exports = getNamespaceExports(pkg_name), - full = FALSE -) -{ - #assignment <- assignments[[1]] - - arg_combis <- if (full) { - - get_arg_combis(arg_names = get_no_default_args(fun_args)) - - } else { - - data.frame() - } - - #fun_name <- as.character(assignment[[2]]) - - call_strings <- get_function_call_strings(fun_name, arg_combis, pkg_name) - - exported <- fun_name %in% exports - - get_test_for_function_calls(call_strings, fun_name, pkg_name, exported) -} - -# get_test_for_function_calls -------------------------------------------------- -#' @importFrom kwb.utils collapsed getAttribute resolve -get_test_for_function_calls <- function( - call_strings, fun_name, pkg_name, exported -) -{ - templates_raw <- get_templates() - - # Remove the calls that generate the same error messages as previous calls - fail_indices <- which_calls_fail(call_strings, dbg = FALSE) - - success_indices <- setdiff(seq_along(call_strings), fail_indices) - - fail_indices <- remove_duplicated_fails(fail_indices) - - errors <- kwb.utils::getAttribute(fail_indices, "errors") - - errors <- sapply(errors, get_error_message) - - full_fun_name <- kwb.utils::resolve( - ifelse(exported, "pkg_fun_exported", "pkg_fun_private"), - templates_raw, - fun = fun_name, - pkg = pkg_name - ) - - pattern <- paste0("(^|\\s)", full_fun_name, "\\(") - - use_shortcut <- function(x) gsub(pattern, "f(", x) - - expect_calls_fail <- sapply(seq_along(fail_indices), function(i) { - - kwb.utils::resolve( - "fun_call_error", - templates_raw, - fun_call = use_shortcut(call_strings[fail_indices[i]]), - quoted_error = gsub("\n", "\n# ", errors[i]) - ) - }) - - expect_calls_success <- sapply(success_indices, function(i) { - - kwb.utils::resolve( - "fun_call_alone", - templates_raw, - fun_call = use_shortcut(call_strings[i]) - ) - }) - - #call_strings[fails] <- sprintf("expect_error(%s)", call_strings[fails]) - #test_that_body <- paste0(" ", call_strings, collapse = "\n") - - shortcut <- get_shortcut_assignment(templates_raw, fun_name, pkg_name) - - test_that_body <- paste0( - " ", shortcut, "\n\n", - kwb.utils::collapsed(c(expect_calls_success, expect_calls_fail)) - ) - - test_that_call <- kwb.utils::resolve( - "test_that_call", - templates_raw, - fun = fun_name, - #pkg = pkg_name, - #pkg_fun = "f", #ifelse(exported, "", ""), - test_that_body = paste0(test_that_body, "\n") - ) - - structure(test_that_call, fun_name = fun_name) -} - -# get_shortcut_assignment ------------------------------------------------------ -get_shortcut_assignment <- function(templates, fun_name, pkg_name) -{ - sprintf( - "f <- %s", - kwb.utils::selectElements( - kwb.utils::resolve(templates, fun = fun_name, pkg = pkg_name), - ifelse(pkg_name == "", "pkg_fun_exported", "pkg_fun_private") - ) - ) -} - -# single_quoted ---------------------------------------------------------------- -single_quoted <- function(x) -{ - paste0("'", gsub("'", "\\\\'", x), "'") -} - -# get_error_message ------------------------------------------------------------ -get_error_message <- function(error) -{ - if (inherits(error, "error")) { - - error$message - - } else { - - error - } -} - -# remove_duplicated_fails ------------------------------------------------------ -#' @importFrom kwb.utils getAttribute -remove_duplicated_fails <- function(fails) -{ - errors <- kwb.utils::getAttribute(fails, "errors") - - keep <- ! duplicated(sapply(errors, get_error_message)) - - structure(fails[keep], errors = errors[keep]) -} - -# get_templates ---------------------------------------------------------------- -get_templates <- function() -{ - templates <- list( - intro = "\n\n\n", - intro_1 = "#\n# This test file has been generated by ", - intro_2 = "# launched by user on .", - intro_3 = "# Your are strongly encouraged to modify the dummy functions", - intro_4 = "# so that real cases are tested. \n#\n", - hint_delete = "You should then delete this comment.", - test_creator = "kwb.test::create_test_files()", - test_that_call = "test_that(\"() works\", {\n\n})", - fun_call = "()", - fun_call_alone = " \n", - fun_call_error = "expect_error(\n\n)\n", - expect_error_args = "\n# ", - fun_call_message = "expect_message()\n", - fun_call_silent = "expect_silent()\n,", - pkg_fun_exported = "", - pkg_fun_private = ":::", - i2 = "", - i1 = " " - ) -} - -# which_calls_fail ------------------------------------------------------------- -which_calls_fail <- function(call_strings, dbg = TRUE) -{ - results <- lapply(call_strings, function(call_string) { - - tryCatch(eval_text(call_string, dbg), error = identity) - }) - - is_error <- sapply(results, inherits, "simpleError") - - structure(which(is_error), errors = results[is_error]) -} - -# eval_text -------------------------------------------------------------------- +# write_test_file -------------------------------------------------------------- #' @importFrom kwb.utils catAndRun -eval_text <- function(text, dbg = TRUE) +write_test_file <- function(code, test_file, dbg = TRUE) { - kwb.utils::catAndRun(dbg = dbg, paste0("Evaluating:\n ", text, "\n"), { - eval(parse(text = text)) + kwb.utils::catAndRun(dbg = dbg, paste("Writing", test_file), { + writeLines(code, test_file) }) } -# get_function_call_strings ---------------------------------------------------- -#' @importFrom kwb.utils asColumnList resolve -get_function_call_strings <- function(fun_name, arg_combis, pkg_name = "") -{ - arg_strings <- "" - - if (nrow(arg_combis) > 0) { - - arg_combi_list <- kwb.utils::asColumnList(as.matrix(arg_combis)) - - assignment <- function(name) paste(name, "=", arg_combi_list[[name]]) - - paste_args <- c(lapply(names(arg_combi_list), assignment), sep = ", ") - - arg_strings <- do.call(paste, paste_args) - } - - sprintf( - "%s(%s)", - kwb.utils::selectElements( - kwb.utils::resolve(get_templates(), fun = fun_name, pkg = pkg_name), - ifelse(pkg_name == "", "pkg_fun_exported", "pkg_fun_private") - ), - arg_strings - ) -} - -# get_arg_combis --------------------------------------------------------------- -#' @importFrom kwb.utils expandGrid -get_arg_combis <- function(arg_names, max_args = 2) -{ - string_values <- c( - "1", "1:2", - '"a"', 'c("a", "b")', - "TRUE", "FALSE", - 'as.POSIXct("2018-06-03 23:50:00")', - 'list(key = c("a", "b"), value = 1:2)' - ) - - n <- min(max_args, length(arg_names)) - - if (n == 1) { - - matrix(string_values, ncol = 1, dimnames = list(NULL, arg_names)) - - } else { - - f <- rep(seq_len(n), each = length(string_values)) - - arguments <- split(rep(string_values, n), f = f) - - names(arguments) <- arg_names[seq_len(n)] - - do.call(kwb.utils::expandGrid, arguments) - } -} - -# get_no_default_args ---------------------------------------------------------- -get_no_default_args <- function(arguments) -{ - if (! is.null(arguments)) { - - names(which(sapply(arguments, is.symbol))) - } -} diff --git a/R/get_test_codes_for_functions_in_file.R b/R/get_test_codes_for_functions_in_file.R new file mode 100644 index 0000000..08118b9 --- /dev/null +++ b/R/get_test_codes_for_functions_in_file.R @@ -0,0 +1,148 @@ +# get_test_codes_for_functions_in_file ----------------------------------------- +get_test_codes_for_functions_in_file <- function(file, pkg_name, test_dir, ...) +{ + # Get the expressions that represent assignments of function definitions + assignments <- get_function_assignments(file) + + # Name the assignments according to the function names + names(assignments) <- sapply(assignments, function(x) as.character(x[[2]])) + + # Get the names of the exported functions + exports <- getNamespaceExports(pkg_name) + + # Create a test_that-call for each function + kwb.utils::excludeNULL(dbg = FALSE, lapply( + stats::setNames(nm = names(assignments)), + FUN = function(fun_name) { + + if (warn_if_file_exists(path_to_testfile(test_dir, fun_name))) { + return() + } + + get_test_for_function( + fun_name = fun_name, + fun_args = assignments[[fun_name]][[3]][[2]], + pkg_name = pkg_name, + exports = exports, + ... + ) + } + )) +} + +# get_function_assignments ----------------------------------------------------- +get_function_assignments <- function(file) +{ + code <- as.list(parse(file)) + + #expr <- code[[2]] + + is_function_assignment <- sapply(code, function(expr) { + + ok <- as.character(expr[[1]]) == "<-" + + ok && length(expr) >= 3 && as.character(expr[[3]][[1]]) == "function" + }) + + code[is_function_assignment] +} + +# path_to_testfile ------------------------------------------------------------- +path_to_testfile <- function(test_dir, fun_name) +{ + sprintf("%s/test-function-%s.R", test_dir, fun_name) +} + +# get_test_for_function -------------------------------------------------------- +get_test_for_function <- function( + fun_name, + fun_args, + pkg_name, + exports = getNamespaceExports(pkg_name), + full = FALSE +) +{ + #assignment <- assignments[[1]] + + arg_combis <- if (full) { + + get_arg_combis(arg_names = get_no_default_args(fun_args)) + + } else { + + data.frame() + } + + #fun_name <- as.character(assignment[[2]]) + + call_strings <- get_function_call_strings(fun_name, arg_combis, pkg_name) + + exported <- fun_name %in% exports + + get_test_for_function_calls(call_strings, fun_name, pkg_name, exported) +} + +# get_no_default_args ---------------------------------------------------------- +get_no_default_args <- function(arguments) +{ + if (!is.null(arguments)) { + names(which(sapply(arguments, is.symbol))) + } +} + +# get_arg_combis --------------------------------------------------------------- +#' @importFrom kwb.utils expandGrid +get_arg_combis <- function(arg_names, max_args = 2L) +{ + string_values <- c( + "1", "1:2", + '"a"', 'c("a", "b")', + "TRUE", "FALSE", + 'as.POSIXct("2018-06-03 23:50:00")', + 'list(key = c("a", "b"), value = 1:2)' + ) + + n <- min(max_args, length(arg_names)) + + if (n == 1L) { + + matrix(string_values, ncol = 1L, dimnames = list(NULL, arg_names)) + + } else { + + f <- rep(seq_len(n), each = length(string_values)) + + arguments <- split(rep(string_values, n), f = f) + + names(arguments) <- arg_names[seq_len(n)] + + do.call(kwb.utils::expandGrid, arguments) + } +} + +# get_function_call_strings ---------------------------------------------------- +#' @importFrom kwb.utils asColumnList resolve +get_function_call_strings <- function(fun_name, arg_combis, pkg_name = "") +{ + arg_strings <- "" + + if (nrow(arg_combis) > 0L) { + + arg_combi_list <- kwb.utils::asColumnList(as.matrix(arg_combis)) + + assignment <- function(name) paste(name, "=", arg_combi_list[[name]]) + + paste_args <- c(lapply(names(arg_combi_list), assignment), sep = ", ") + + arg_strings <- do.call(paste, paste_args) + } + + sprintf( + "%s(%s)", + kwb.utils::selectElements( + kwb.utils::resolve(get_templates(), fun = fun_name, pkg = pkg_name), + ifelse(pkg_name == "", "pkg_fun_exported", "pkg_fun_private") + ), + arg_strings + ) +} diff --git a/R/get_test_for_function_calls.R b/R/get_test_for_function_calls.R new file mode 100644 index 0000000..7f5a79c --- /dev/null +++ b/R/get_test_for_function_calls.R @@ -0,0 +1,153 @@ +# get_test_for_function_calls -------------------------------------------------- +#' @importFrom kwb.utils collapsed getAttribute resolve +get_test_for_function_calls <- function( + call_strings, fun_name, pkg_name, exported +) +{ + templates_raw <- get_templates() + + # Remove the calls that generate the same error messages as previous calls + fail_indices <- which_calls_fail(call_strings, dbg = FALSE) + + success_indices <- setdiff(seq_along(call_strings), fail_indices) + + fail_indices <- remove_duplicated_fails(fail_indices) + + errors <- kwb.utils::getAttribute(fail_indices, "errors") + + errors <- sapply(errors, get_error_message) + + full_fun_name <- kwb.utils::resolve( + ifelse(exported, "pkg_fun_exported", "pkg_fun_private"), + templates_raw, + fun = fun_name, + pkg = pkg_name + ) + + pattern <- paste0("(^|\\s)", full_fun_name, "\\(") + + use_shortcut <- function(x) gsub(pattern, "f(", x) + + expect_calls_fail <- sapply(seq_along(fail_indices), function(i) { + + kwb.utils::resolve( + "fun_call_error", + templates_raw, + fun_call = use_shortcut(call_strings[fail_indices[i]]), + quoted_error = gsub("\n", "\n# ", errors[i]) + ) + }) + + expect_calls_success <- sapply(success_indices, function(i) { + + kwb.utils::resolve( + "fun_call_alone", + templates_raw, + fun_call = use_shortcut(call_strings[i]) + ) + }) + + #call_strings[fails] <- sprintf("expect_error(%s)", call_strings[fails]) + #test_that_body <- paste0(" ", call_strings, collapse = "\n") + + shortcut <- get_shortcut_assignment(templates_raw, fun_name, pkg_name) + + test_that_body <- paste0( + " ", shortcut, "\n\n", + kwb.utils::collapsed(c(expect_calls_success, expect_calls_fail)) + ) + + test_that_call <- kwb.utils::resolve( + "test_that_call", + templates_raw, + fun = fun_name, + #pkg = pkg_name, + #pkg_fun = "f", #ifelse(exported, "", ""), + test_that_body = paste0(test_that_body, "\n") + ) + + structure(test_that_call, fun_name = fun_name) +} + +# get_templates ---------------------------------------------------------------- +get_templates <- function() +{ + templates <- list( + intro = "\n\n\n", + intro_1 = "#\n# This test file has been generated by ", + intro_2 = "# launched by user on .", + intro_3 = "# Your are strongly encouraged to modify the dummy functions", + intro_4 = "# so that real cases are tested. \n#\n", + hint_delete = "You should then delete this comment.", + test_creator = "kwb.test::create_test_files()", + test_that_call = "test_that(\"() works\", {\n\n})", + fun_call = "()", + fun_call_alone = " \n", + fun_call_error = "expect_error(\n\n)\n", + expect_error_args = "\n# ", + fun_call_message = "expect_message()\n", + fun_call_silent = "expect_silent()\n,", + pkg_fun_exported = "", + pkg_fun_private = ":::", + i2 = "", + i1 = " " + ) +} + +# which_calls_fail ------------------------------------------------------------- +which_calls_fail <- function(call_strings, dbg = TRUE) +{ + results <- lapply(call_strings, function(call_string) { + + tryCatch(eval_text(call_string, dbg), error = identity) + }) + + is_error <- sapply(results, inherits, "simpleError") + + structure(which(is_error), errors = results[is_error]) +} + +# eval_text -------------------------------------------------------------------- +#' @importFrom kwb.utils catAndRun +eval_text <- function(text, dbg = TRUE) +{ + kwb.utils::catAndRun(paste0("Evaluating:\n ", text, "\n"), dbg = dbg, { + eval(parse(text = text)) + }) +} + +# remove_duplicated_fails ------------------------------------------------------ +#' @importFrom kwb.utils getAttribute +remove_duplicated_fails <- function(fails) +{ + errors <- kwb.utils::getAttribute(fails, "errors") + + keep <- !duplicated(sapply(errors, get_error_message)) + + structure(fails[keep], errors = errors[keep]) +} + +# get_error_message ------------------------------------------------------------ +get_error_message <- function(error) +{ + if (inherits(error, "error")) { + + error$message + + } else { + + error + } +} + +# get_shortcut_assignment ------------------------------------------------------ +get_shortcut_assignment <- function(templates, fun_name, pkg_name) +{ + sprintf( + "f <- %s", + kwb.utils::selectElements( + kwb.utils::resolve(templates, fun = fun_name, pkg = pkg_name), + ifelse(pkg_name == "", "pkg_fun_exported", "pkg_fun_private") + ) + ) +} diff --git a/R/helpers.R b/R/helpers.R new file mode 100644 index 0000000..abc17ed --- /dev/null +++ b/R/helpers.R @@ -0,0 +1,164 @@ +# loadArgs --------------------------------------------------------------------- + +#' Load Function Arguments and Results From Files +#' +#' Read the function arguments and function results that were stored in RData +#' files (in objects \code{args} and \code{result}, respectively) by a previous +#' call of \code{\link{saveArgs}}. +#' +#' @param functionName Name of the function to load arguments and results for. +#' The name is used to create a search pattern for RData files in +#' \code{data.dir}. +#' @param data.dir Directory in which to look for RData files matching +#' \code{args___.RData}. The default is the +#' subfolder \code{test} in \code{tempdir()}. +#' @return list with as many items as there were files args__* +#' in the directory given in \code{data.dir}. Each list element has two +#' components: \code{args} containing the arguments that were given to +#' the function and \code{result} containing what the function returned. +#' @export +#' @seealso \code{\link{saveArgs}} +#' @examples +#' +#' # Define a function that stores its arguments and result with saveArgs +#' double <- function(x) { +#' result <- 2 * x +#' saveArgs("double", args = list(x = x), result = result) +#' result +#' } +#' +#' # Set global variable TESTMODE to "activate" saveArgs() in double() +#' TESTMODE <- TRUE +#' +#' # Call the function a couple of times +#' double(4) +#' double(-99) +#' double(1:10) +#' +#' # Load what was stored behind the scenes +#' testdata <- loadArgs("double") +#' +#' # "Deactivate" saveArgs() in double() +#' TESTMODE <- FALSE +#' +#' # Rerun the function with the stored arguments +#' results <- lapply(testdata, function(x) do.call("double", x$args)) +#' +#' # Compare the new with the old results +#' identical(results, lapply(testdata, "[[", "result")) +loadArgs <- function +( + functionName = NULL, data.dir = file.path(tempdir(), "test") +) +{ + kwb.utils::safePath(data.dir) + + template <- "^args_NAME_\\d{6}_.*$" + + pattern <- gsub( + "NAME", + kwb.utils::defaultIfNULL(functionName, ".*"), + template + ) + + data.files <- dir(data.dir, pattern, full.names = TRUE) + + if (!length(data.files)) { + stop( + "No files matching '", pattern, "' found in '", data.dir, "'. ", + "Available files: ", kwb.utils::stringList(dir(data.dir)) + ) + } + + getBasename <- function(x, short) { + subst1 <- list("^args_" = "") + subst2 <- if (short) + list("\\d{6}_\\d+\\.RData$" = "") + else + list("\\.RData$" = "") + kwb.utils::multiSubstitute(basename(x), c(subst1, subst2)) + } + + if (is.null(functionName)) { + + functionNames <- unique(getBasename(data.files, short = TRUE)) + + stop( + "No function name given. Functions for which arguments are stored ", + "in ", data.dir, ": ", kwb.utils::stringList(functionNames) + ) + } + + data.files <- data.files[grepl(pattern, basename(data.files))] + + result <- lapply(data.files, function(data.file) { + + list( + args = kwb.utils::loadObject(data.file, "args"), + result = kwb.utils::loadObject(data.file, "result") + ) + }) + + structure(result, names = getBasename(data.files, short = FALSE)) +} + +# saveArgs --------------------------------------------------------------------- + +#' Save the Arguments and Result of a Function Call +#' +#' Save the list of named arguments given in \code{...} to an RData file +#' \code{args___.RData} in the directory given in +#' \code{targetdir}. This function can be used to log the inputs given to a +#' function together with the result returned by the function. +#' \code{\link{test_function}} can then be used to check whether another version +#' of the function (e.g. obtained by code cleaning) can reproduce the stored +#' results from the stored arguments. Check out the example on the help page for +#' \code{\link{test_function}}. +#' +#' @param functionName name of the function to which the arguments to be saved +#' belong. It will be used to generate a file name for the RData file. +#' @param ... named arguments representing the arguments that have been given +#' to the function \code{functionName}. +#' @param targetdir directory in which to store the objects given in \code{...} +#' Default: subdirectory \code{test} in \code{tempdir()} +#' @return path to the file written (invisibly) +#' @export +#' @seealso \code{\link{loadArgs}} +saveArgs <- function +( + functionName, + ..., + targetdir = kwb.utils::createDirectory(file.path(tempdir(), "test")) +) +{ + if (! exists("TESTMODE")) { + + prompt <- paste0( + "[Set global variable TESTMODE to FALSE to prevent this message]\n", + sprintf("Save args to '%s' (y, n)? ", functionName) + ) + + TESTMODE <- (readline(prompt) == "y") + } + + if (TESTMODE) { + + timestring <- format(Sys.time(), "%H%M%S") + filename <- paste0("args_", functionName, "_", timestring, "_0") + + # Make the name unique within the existing files in targetdir (generated + # within the same second) + filenames <- gsub("\\.RData$", "", dir(targetdir)) + filename <- kwb.utils::hsSafeName(filename, filenames) + + file <- file.path(targetdir, paste0(filename, ".RData")) + + cat("saving args to", file, "... ") + args <- list(...) + save(file = file, list = names(args), envir = list2env(args)) + cat("ok.\n") + + # Return (invisibly) the path to the file to which data was stored + invisible(file) + } +} diff --git a/R/testColumnwiseIdentity.R b/R/testColumnwiseIdentity.R new file mode 100644 index 0000000..e2f11af --- /dev/null +++ b/R/testColumnwiseIdentity.R @@ -0,0 +1,64 @@ +# testColumnwiseIdentity ------------------------------------------------------- + +#' Check Corresponding Columns in two Data Frames for Identity +#' +#' For all columns in the first data frame, check if the second data frame +#' has identical values in columns of the same name +#' +#' @param ... two data frames given as named arguments. The argument names will +#' appear in the output. By doing so you can give a longer expression that +#' returns a data frame a short name 'on-the-fly'. +#' @export +#' @examples +#' # Compare two identical data frames. Give them short names data.1 and data.2 +#' testColumnwiseIdentity(data.1 = (x <- data.frame(a = 1:2, b = 2:3)), +#' data.2 = x) +#' +#' # Compare two data frames differing in one column +#' testColumnwiseIdentity(A = data.frame(x = 1:2, y = 2:3), +#' B = data.frame(x = 1:2, y = 3:4)) +testColumnwiseIdentity <- function(...) +{ + args <- list(...) + stopifnot(length(args) == 2) + + x <- args[[1]] + y <- args[[2]] + + objectnames <- names(args) + + for (column in names(x)) { + + printTestMessage( + sprintf(#"identical(%s[[\"%s\"]], %s[[\"%s\"]])", + "identical(%s[, \"%s\"], %s[, \"%s\"])", + objectnames[1], column, objectnames[2], column), + identical(kwb.utils::selectColumns(x, column), + kwb.utils::selectColumns(y, column)), + newline = FALSE + ) + } +} + +# printTestMessage ------------------------------------------------------------- + +#' Print a Test with its Result +#' +#' Print a test with its result as a message and return the message as a +#' character string +#' +#' @param testexpression text description of what was tested +#' @param testresult boolean result (of length one) of the test +#' @param newline if \code{TRUE} (default) a new line character is appended +#' to the message shown. +#' @return the message that was shown as a character string +#' @export +#' @examples +#' printTestMessage("apple == apple", 1 == 1) +#' printTestMessage("apple == pear", 1 == 2) +printTestMessage <- function(testexpression, testresult, newline = TRUE) +{ + message(sprintf(paste0("%s? %s", ifelse(newline, "\n", "")), + testexpression, testresult)) + testresult +} diff --git a/R/testMain.R b/R/testMain.R deleted file mode 100644 index 8358022..0000000 --- a/R/testMain.R +++ /dev/null @@ -1,316 +0,0 @@ -# test_function ---------------------------------------------------------------- - -#' Test if Function Reproduces Stored Results -#' -#' Call the function \code{functionName} with the arguments contained in -#' \code{testdata} and compare the results with the results in \code{testdata} -#' for identity. -#' @param functionName Name of the function to test. It must be callable, i.e. -#' either defined in the global environment or on the search path. -#' @param testdata List of lists containing function arguments (in elemenet -#' \code{args}) and results (in element \code{result}), just as returned by -#' \code{\link{loadArgs}}. If no \code{testdata} are given, it is tried to -#' load test data by calling \code{loadArgs} on \code{functionName}. -#' @param dbg if \code{TRUE} (default) debug messages are shown -#' @return \code{TRUE} If the function \code{functionName} is able to reproduce -#' the same results as given in the \code{result} elements in \code{testdata} -#' for all the argument combinations given in the \code{args} elements in -#' \code{testdata}. -#' @export -#' @examples -#' # Define a function using saveArgs() to save arguments and result -#' squareSum <- function(a, b) { -#' result <- a * a + b * b -#' saveArgs("squareSum", args = list(a = a, b = b), result = result) -#' result -#' } -#' -#' # Set global variable TESTMODE to "activate" saveArgs() in squareSum() -#' TESTMODE <- TRUE -#' -#' # Call the function with different arguments -#' squareSum(1, 2) -#' squareSum(2, 3) -#' squareSum(-1, -2) -#' -#' # The arguments and function results were saved here: -#' dir(file.path(tempdir(), "test")) -#' -#' # Write a new (wrong) version of the function -#' squareSum.new <- function(a, b) { -#' a * a - b * b -#' } -#' -#' # Check if it returns the same results -#' test_function("squareSum.new", loadArgs("squareSum")) -#' -#' # If no test data are given, loadArgs is called on the function to test, -#' # i.e. testing squareSum on the test data created by the same function will -#' # return TRUE if the function did not change in the meanwhile. -#' test_function("squareSum") -test_function <- function -( - functionName, - testdata = loadArgs(functionName, file.path(tempdir(), "test")), - dbg = TRUE -) -{ - compare.available <- requireNamespace("compare", quietly = TRUE) - - if (length(testdata)) { - kwb.utils::catIf(dbg, sprintf("Calling '%s' with arguments stored in...\n", - functionName)) - } - - success <- lapply(names(testdata), function(element) { - - args <- testdata[[element]]$args - result <- testdata[[element]]$result - - kwb.utils::catIf(dbg, " ", element, "-> ") - - utils::capture.output(my.result <- do.call(functionName, args)) - - isIdentical <- identical(result, my.result) - - kwb.utils::catIf(dbg, ifelse(isIdentical, "SAME", "DIFFERENT"), "result.\n") - - if (! isIdentical && compare.available) { - - cat("Comparison with compare::compare:\n") - print(compare::compare(result, my.result, allowAll = TRUE)) - } - - isIdentical - }) - - if (! compare.available) { - message("If the 'compare' package was installed I would have also been ", - "used 'compare::compare' to compare the results") - } - - all(unlist(success)) -} - -# loadArgs --------------------------------------------------------------------- - -#' Load Function Arguments and Results From Files -#' -#' Read the function arguments and function results that were stored in RData -#' files (in objects \code{args} and \code{result}, respectively) by a previous -#' call of \code{\link{saveArgs}}. -#' -#' @param functionName Name of the function to load arguments and results for. -#' The name is used to create a search pattern for RData files in -#' \code{data.dir}. -#' @param data.dir Directory in which to look for RData files matching -#' \code{args___.RData}. The default is the -#' subfolder \code{test} in \code{tempdir()}. -#' @return list with as many items as there were files args__* -#' in the directory given in \code{data.dir}. Each list element has two -#' components: \code{args} containing the arguments that were given to -#' the function and \code{result} containing what the function returned. -#' @export -#' @seealso \code{\link{saveArgs}} -#' @examples -#' -#' # Define a function that stores its arguments and result with saveArgs -#' double <- function(x) { -#' result <- 2 * x -#' saveArgs("double", args = list(x = x), result = result) -#' result -#' } -#' -#' # Set global variable TESTMODE to "activate" saveArgs() in double() -#' TESTMODE <- TRUE -#' -#' # Call the function a couple of times -#' double(4) -#' double(-99) -#' double(1:10) -#' -#' # Load what was stored behind the scenes -#' testdata <- loadArgs("double") -#' -#' # "Deactivate" saveArgs() in double() -#' TESTMODE <- FALSE -#' -#' # Rerun the function with the stored arguments -#' results <- lapply(testdata, function(x) do.call("double", x$args)) -#' -#' # Compare the new with the old results -#' identical(results, lapply(testdata, "[[", "result")) -loadArgs <- function -( - functionName = NULL, data.dir = file.path(tempdir(), "test") -) -{ - kwb.utils::safePath(data.dir) - - template <- "^args_NAME_\\d{6}_.*$" - - pattern <- gsub("NAME", kwb.utils::defaultIfNULL(functionName, ".*"), - template) - - data.files <- dir(data.dir, pattern, full.names = TRUE) - - if (! length(data.files)) { - stop("No files matching '", pattern, "' found in '", data.dir, "'. ", - "Available files: ", kwb.utils::stringList(dir(data.dir))) - } - - getBasename <- function(x, short) { - subst1 <- list("^args_" = "") - subst2 <- if (short) - list("\\d{6}_\\d+\\.RData$" = "") - else - list("\\.RData$" = "") - kwb.utils::multiSubstitute(basename(x), c(subst1, subst2)) - } - - if (is.null(functionName)) { - - functionNames <- unique(getBasename(data.files, short = TRUE)) - - stop("No function name given. Functions for which arguments are stored ", - "in ", data.dir, ": ", kwb.utils::stringList(functionNames)) - } - - data.files <- data.files[grepl(pattern, basename(data.files))] - - result <- lapply(data.files, function(data.file) { - - list( - args = kwb.utils::loadObject(data.file, "args"), - result = kwb.utils::loadObject(data.file, "result") - ) - }) - - structure(result, names = getBasename(data.files, short = FALSE)) -} - -# testColumnwiseIdentity ------------------------------------------------------- - -#' Check Corresponding Columns in two Data Frames for Identity -#' -#' For all columns in the first data frame, check if the second data frame -#' has identical values in columns of the same name -#' -#' @param ... two data frames given as named arguments. The argument names will -#' appear in the output. By doing so you can give a longer expression that -#' returns a data frame a short name 'on-the-fly'. -#' @export -#' @examples -#' # Compare two identical data frames. Give them short names data.1 and data.2 -#' testColumnwiseIdentity(data.1 = (x <- data.frame(a = 1:2, b = 2:3)), -#' data.2 = x) -#' -#' # Compare two data frames differing in one column -#' testColumnwiseIdentity(A = data.frame(x = 1:2, y = 2:3), -#' B = data.frame(x = 1:2, y = 3:4)) -testColumnwiseIdentity <- function(...) -{ - args <- list(...) - stopifnot(length(args) == 2) - - x <- args[[1]] - y <- args[[2]] - - objectnames <- names(args) - - for (column in names(x)) { - - printTestMessage( - sprintf(#"identical(%s[[\"%s\"]], %s[[\"%s\"]])", - "identical(%s[, \"%s\"], %s[, \"%s\"])", - objectnames[1], column, objectnames[2], column), - identical(kwb.utils::selectColumns(x, column), - kwb.utils::selectColumns(y, column)), - newline = FALSE - ) - } -} - -# printTestMessage ------------------------------------------------------------- - -#' Print a Test with its Result -#' -#' Print a test with its result as a message and return the message as a -#' character string -#' -#' @param testexpression text description of what was tested -#' @param testresult boolean result (of length one) of the test -#' @param newline if \code{TRUE} (default) a new line character is appended -#' to the message shown. -#' @return the message that was shown as a character string -#' @export -#' @examples -#' printTestMessage("apple == apple", 1 == 1) -#' printTestMessage("apple == pear", 1 == 2) -printTestMessage <- function(testexpression, testresult, newline = TRUE) -{ - message(sprintf(paste0("%s? %s", ifelse(newline, "\n", "")), - testexpression, testresult)) - testresult -} - -# saveArgs --------------------------------------------------------------------- - -#' Save the Arguments and Result of a Function Call -#' -#' Save the list of named arguments given in \code{...} to an RData file -#' \code{args___.RData} in the directory given in -#' \code{targetdir}. This function can be used to log the inputs given to a -#' function together with the result returned by the function. -#' \code{\link{test_function}} can then be used to check whether another version -#' of the function (e.g. obtained by code cleaning) can reproduce the stored -#' results from the stored arguments. Check out the example on the help page for -#' \code{\link{test_function}}. -#' -#' @param functionName name of the function to which the arguments to be saved -#' belong. It will be used to generate a file name for the RData file. -#' @param ... named arguments representing the arguments that have been given -#' to the function \code{functionName}. -#' @param targetdir directory in which to store the objects given in \code{...} -#' Default: subdirectory \code{test} in \code{tempdir()} -#' @return path to the file written (invisibly) -#' @export -#' @seealso \code{\link{loadArgs}} -saveArgs <- function -( - functionName, - ..., - targetdir = kwb.utils::createDirectory(file.path(tempdir(), "test")) -) -{ - if (! exists("TESTMODE")) { - - prompt <- paste0( - "[Set global variable TESTMODE to FALSE to prevent this message]\n", - sprintf("Save args to '%s' (y, n)? ", functionName) - ) - - TESTMODE <- (readline(prompt) == "y") - } - - if (TESTMODE) { - - timestring <- format(Sys.time(), "%H%M%S") - filename <- paste0("args_", functionName, "_", timestring, "_0") - - # Make the name unique within the existing files in targetdir (generated - # within the same second) - filenames <- gsub("\\.RData$", "", dir(targetdir)) - filename <- kwb.utils::hsSafeName(filename, filenames) - - file <- file.path(targetdir, paste0(filename, ".RData")) - - cat("saving args to", file, "... ") - args <- list(...) - save(file = file, list = names(args), envir = list2env(args)) - cat("ok.\n") - - # Return (invisibly) the path to the file to which data was stored - invisible(file) - } -} diff --git a/R/test_function.R b/R/test_function.R new file mode 100644 index 0000000..04205c8 --- /dev/null +++ b/R/test_function.R @@ -0,0 +1,97 @@ +# test_function ---------------------------------------------------------------- + +#' Test if Function Reproduces Stored Results +#' +#' Call the function \code{functionName} with the arguments contained in +#' \code{testdata} and compare the results with the results in \code{testdata} +#' for identity. +#' @param functionName Name of the function to test. It must be callable, i.e. +#' either defined in the global environment or on the search path. +#' @param testdata List of lists containing function arguments (in elemenet +#' \code{args}) and results (in element \code{result}), just as returned by +#' \code{\link{loadArgs}}. If no \code{testdata} are given, it is tried to +#' load test data by calling \code{loadArgs} on \code{functionName}. +#' @param dbg if \code{TRUE} (default) debug messages are shown +#' @return \code{TRUE} If the function \code{functionName} is able to reproduce +#' the same results as given in the \code{result} elements in \code{testdata} +#' for all the argument combinations given in the \code{args} elements in +#' \code{testdata}. +#' @export +#' @examples +#' # Define a function using saveArgs() to save arguments and result +#' squareSum <- function(a, b) { +#' result <- a * a + b * b +#' saveArgs("squareSum", args = list(a = a, b = b), result = result) +#' result +#' } +#' +#' # Set global variable TESTMODE to "activate" saveArgs() in squareSum() +#' TESTMODE <- TRUE +#' +#' # Call the function with different arguments +#' squareSum(1, 2) +#' squareSum(2, 3) +#' squareSum(-1, -2) +#' +#' # The arguments and function results were saved here: +#' dir(file.path(tempdir(), "test")) +#' +#' # Write a new (wrong) version of the function +#' squareSum.new <- function(a, b) { +#' a * a - b * b +#' } +#' +#' # Check if it returns the same results +#' test_function("squareSum.new", loadArgs("squareSum")) +#' +#' # If no test data are given, loadArgs is called on the function to test, +#' # i.e. testing squareSum on the test data created by the same function will +#' # return TRUE if the function did not change in the meanwhile. +#' test_function("squareSum") +test_function <- function +( + functionName, + testdata = loadArgs(functionName, file.path(tempdir(), "test")), + dbg = TRUE +) +{ + compare.available <- requireNamespace("compare", quietly = TRUE) + + if (length(testdata)) { + kwb.utils::catIf(dbg, sprintf( + "Calling '%s' with arguments stored in...\n", + functionName + )) + } + + success <- lapply(names(testdata), function(element) { + + args <- testdata[[element]]$args + result <- testdata[[element]]$result + + kwb.utils::catIf(dbg, " ", element, "-> ") + + utils::capture.output(my.result <- do.call(functionName, args)) + + isIdentical <- identical(result, my.result) + + kwb.utils::catIf(dbg, ifelse(isIdentical, "SAME", "DIFFERENT"), "result.\n") + + if (! isIdentical && compare.available) { + + cat("Comparison with compare::compare:\n") + print(compare::compare(result, my.result, allowAll = TRUE)) + } + + isIdentical + }) + + if (!compare.available) { + message( + "If the 'compare' package was installed I would have also been ", + "used 'compare::compare' to compare the results" + ) + } + + all(unlist(success)) +} diff --git a/R/utils.R b/R/utils.R index 0bba558..e3caeb8 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1,3 +1,9 @@ +# single_quoted ---------------------------------------------------------------- +single_quoted <- function(x) +{ + paste0("'", gsub("'", "\\\\'", x), "'") +} + # warn_if_file_exists ---------------------------------------------------------- warn_if_file_exists <- function(test_file) { diff --git a/man/create_test_files.Rd b/man/create_test_files.Rd index bb3c2d8..2acda6c 100644 --- a/man/create_test_files.Rd +++ b/man/create_test_files.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/testCreate.R +% Please edit documentation in R/create_test_files.R \name{create_test_files} \alias{create_test_files} \title{Create Test Files} diff --git a/man/loadArgs.Rd b/man/loadArgs.Rd index 811dc84..ce9b5e5 100644 --- a/man/loadArgs.Rd +++ b/man/loadArgs.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/testMain.R +% Please edit documentation in R/helpers.R \name{loadArgs} \alias{loadArgs} \title{Load Function Arguments and Results From Files} diff --git a/man/printTestMessage.Rd b/man/printTestMessage.Rd index 4b00cf3..95e688c 100644 --- a/man/printTestMessage.Rd +++ b/man/printTestMessage.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/testMain.R +% Please edit documentation in R/testColumnwiseIdentity.R \name{printTestMessage} \alias{printTestMessage} \title{Print a Test with its Result} diff --git a/man/saveArgs.Rd b/man/saveArgs.Rd index 8d59694..14a9f4b 100644 --- a/man/saveArgs.Rd +++ b/man/saveArgs.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/testMain.R +% Please edit documentation in R/helpers.R \name{saveArgs} \alias{saveArgs} \title{Save the Arguments and Result of a Function Call} diff --git a/man/testColumnwiseIdentity.Rd b/man/testColumnwiseIdentity.Rd index 1138314..4f2cb97 100644 --- a/man/testColumnwiseIdentity.Rd +++ b/man/testColumnwiseIdentity.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/testMain.R +% Please edit documentation in R/testColumnwiseIdentity.R \name{testColumnwiseIdentity} \alias{testColumnwiseIdentity} \title{Check Corresponding Columns in two Data Frames for Identity} diff --git a/man/test_function.Rd b/man/test_function.Rd index 9da047f..2d808d8 100644 --- a/man/test_function.Rd +++ b/man/test_function.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/testMain.R +% Please edit documentation in R/test_function.R \name{test_function} \alias{test_function} \title{Test if Function Reproduces Stored Results} From 4682b695c7464a5a1a206eea7add1f09545ee3b0 Mon Sep 17 00:00:00 2001 From: hsonne Date: Sun, 16 Jul 2023 09:53:44 +0200 Subject: [PATCH 17/49] Simplify, use file.path() --- R/create_test_files.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/create_test_files.R b/R/create_test_files.R index 06d6b7f..efaab11 100644 --- a/R/create_test_files.R +++ b/R/create_test_files.R @@ -72,9 +72,9 @@ create_tests_for_file <- function( # One test file per source file? if (!file_per_function) { - test_file <- sprintf("%s/test-file-%s", test_dir, basename(script)) + test_file <- file.path(test_dir, paste0("test-file-", basename(script))) - if (isTRUE(warn_if_file_exists(test_file))) { + if (warn_if_file_exists(test_file)) { return() } } From 739155694e5c26caa0b10a650f621ccb94cec0a9 Mon Sep 17 00:00:00 2001 From: hsonne Date: Sun, 16 Jul 2023 09:55:17 +0200 Subject: [PATCH 18/49] Let get_function_assignment() name the elements and test that --- R/get_test_codes_for_functions_in_file.R | 11 +++++++---- tests/testthat/test-testCreate.R | 18 +++++++++++++++++- 2 files changed, 24 insertions(+), 5 deletions(-) diff --git a/R/get_test_codes_for_functions_in_file.R b/R/get_test_codes_for_functions_in_file.R index 08118b9..7e1f2d5 100644 --- a/R/get_test_codes_for_functions_in_file.R +++ b/R/get_test_codes_for_functions_in_file.R @@ -4,9 +4,6 @@ get_test_codes_for_functions_in_file <- function(file, pkg_name, test_dir, ...) # Get the expressions that represent assignments of function definitions assignments <- get_function_assignments(file) - # Name the assignments according to the function names - names(assignments) <- sapply(assignments, function(x) as.character(x[[2]])) - # Get the names of the exported functions exports <- getNamespaceExports(pkg_name) @@ -44,7 +41,13 @@ get_function_assignments <- function(file) ok && length(expr) >= 3 && as.character(expr[[3]][[1]]) == "function" }) - code[is_function_assignment] + assignments <- code[is_function_assignment] + + # Name the assignments according to the function names + stats::setNames( + assignments, + sapply(assignments, function(x) as.character(x[[2]])) + ) } # path_to_testfile ------------------------------------------------------------- diff --git a/tests/testthat/test-testCreate.R b/tests/testthat/test-testCreate.R index 990ceee..c891148 100644 --- a/tests/testthat/test-testCreate.R +++ b/tests/testthat/test-testCreate.R @@ -15,7 +15,23 @@ test_that("get_test_codes_for_functions_in_file() works", { test_that("get_function_assignments() works", { - expect_error(kwb.test:::get_function_assignments()) + f <- kwb.test:::get_function_assignments + + expect_error(f()) + + file <- tempfile("test-", fileext = ".R") + + writeLines( + text = c( + "id <- function(x) x", + "plus <- function(x, y) x + y" + ), + con = file + ) + + result <- f(file) + + expect_identical(names(result), c("id", "plus")) }) test_that("get_test_for_function_assignment() works", { From 0928a7676590460bc95f510839ea8924f6e12d17 Mon Sep 17 00:00:00 2001 From: hsonne Date: Sun, 16 Jul 2023 09:59:07 +0200 Subject: [PATCH 19/49] Separate excludeNULL() from lapply() --- R/get_test_codes_for_functions_in_file.R | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/R/get_test_codes_for_functions_in_file.R b/R/get_test_codes_for_functions_in_file.R index 7e1f2d5..9c9663f 100644 --- a/R/get_test_codes_for_functions_in_file.R +++ b/R/get_test_codes_for_functions_in_file.R @@ -8,14 +8,12 @@ get_test_codes_for_functions_in_file <- function(file, pkg_name, test_dir, ...) exports <- getNamespaceExports(pkg_name) # Create a test_that-call for each function - kwb.utils::excludeNULL(dbg = FALSE, lapply( - stats::setNames(nm = names(assignments)), + test_calls <- lapply( + X = stats::setNames(nm = names(assignments)), FUN = function(fun_name) { - if (warn_if_file_exists(path_to_testfile(test_dir, fun_name))) { return() } - get_test_for_function( fun_name = fun_name, fun_args = assignments[[fun_name]][[3]][[2]], @@ -24,7 +22,10 @@ get_test_codes_for_functions_in_file <- function(file, pkg_name, test_dir, ...) ... ) } - )) + ) + + # Remove NULL elements + kwb.utils::excludeNULL(test_calls, dbg = FALSE) } # get_function_assignments ----------------------------------------------------- From 9e6847a7cd212ac34714771db05f651f983c5214 Mon Sep 17 00:00:00 2001 From: hsonne Date: Sun, 16 Jul 2023 10:12:25 +0200 Subject: [PATCH 20/49] Test for existing files beforehand --- R/get_test_codes_for_functions_in_file.R | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/R/get_test_codes_for_functions_in_file.R b/R/get_test_codes_for_functions_in_file.R index 9c9663f..098baca 100644 --- a/R/get_test_codes_for_functions_in_file.R +++ b/R/get_test_codes_for_functions_in_file.R @@ -4,6 +4,15 @@ get_test_codes_for_functions_in_file <- function(file, pkg_name, test_dir, ...) # Get the expressions that represent assignments of function definitions assignments <- get_function_assignments(file) + # Exclude functions for which a test file already exists + { + file_exists <- sapply(names(assignments), function(fun_name) { + warn_if_file_exists(path_to_testfile(test_dir, fun_name)) + }) + + assignments <- assignments[!file_exists] + } + # Get the names of the exported functions exports <- getNamespaceExports(pkg_name) @@ -11,9 +20,6 @@ get_test_codes_for_functions_in_file <- function(file, pkg_name, test_dir, ...) test_calls <- lapply( X = stats::setNames(nm = names(assignments)), FUN = function(fun_name) { - if (warn_if_file_exists(path_to_testfile(test_dir, fun_name))) { - return() - } get_test_for_function( fun_name = fun_name, fun_args = assignments[[fun_name]][[3]][[2]], From 54b1d1967fb01e69f2ab2a1147b8f6c87ffe6f2c Mon Sep 17 00:00:00 2001 From: hsonne Date: Sun, 16 Jul 2023 11:02:37 +0200 Subject: [PATCH 21/49] Assume that there is a function shortcut "f" closing #7 --- R/get_test_codes_for_functions_in_file.R | 17 ++++++----------- 1 file changed, 6 insertions(+), 11 deletions(-) diff --git a/R/get_test_codes_for_functions_in_file.R b/R/get_test_codes_for_functions_in_file.R index 098baca..6a38a9e 100644 --- a/R/get_test_codes_for_functions_in_file.R +++ b/R/get_test_codes_for_functions_in_file.R @@ -134,9 +134,7 @@ get_arg_combis <- function(arg_names, max_args = 2L) #' @importFrom kwb.utils asColumnList resolve get_function_call_strings <- function(fun_name, arg_combis, pkg_name = "") { - arg_strings <- "" - - if (nrow(arg_combis) > 0L) { + arg_strings <- if (nrow(arg_combis) > 0L) { arg_combi_list <- kwb.utils::asColumnList(as.matrix(arg_combis)) @@ -145,14 +143,11 @@ get_function_call_strings <- function(fun_name, arg_combis, pkg_name = "") paste_args <- c(lapply(names(arg_combi_list), assignment), sep = ", ") arg_strings <- do.call(paste, paste_args) + + } else { + + "" } - sprintf( - "%s(%s)", - kwb.utils::selectElements( - kwb.utils::resolve(get_templates(), fun = fun_name, pkg = pkg_name), - ifelse(pkg_name == "", "pkg_fun_exported", "pkg_fun_private") - ), - arg_strings - ) + sprintf("f(%s)", arg_strings) } From 2230fa35e7899d1bff6185751dd3946995d94061 Mon Sep 17 00:00:00 2001 From: hsonne Date: Sun, 16 Jul 2023 11:10:54 +0200 Subject: [PATCH 22/49] Simplify and shorten the descriptive comment --- R/get_test_for_function_calls.R | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/R/get_test_for_function_calls.R b/R/get_test_for_function_calls.R index 7f5a79c..b75af3e 100644 --- a/R/get_test_for_function_calls.R +++ b/R/get_test_for_function_calls.R @@ -74,12 +74,10 @@ get_templates <- function() { templates <- list( intro = "\n\n\n", - intro_1 = "#\n# This test file has been generated by ", - intro_2 = "# launched by user on .", - intro_3 = "# Your are strongly encouraged to modify the dummy functions", - intro_4 = "# so that real cases are tested. \n#\n", - hint_delete = "You should then delete this comment.", - test_creator = "kwb.test::create_test_files()", + intro_1 = "#\n# This file was generated by kwb.test::create_test_files(), ", + intro_2 = "# launched by on .", + intro_3 = "# Please modify the dummy functions so that real cases are", + intro_4 = "# tested. Then, delete this comment.\n#\n", test_that_call = "test_that(\"() works\", {\n\n})", fun_call = "()", fun_call_alone = " \n", From ead410cf985745cb540f89c871e96129cd1ea514 Mon Sep 17 00:00:00 2001 From: hsonne Date: Thu, 27 Jul 2023 09:36:29 +0200 Subject: [PATCH 23/49] Use get_function_assignments_from kwb.code --- DESCRIPTION | 2 ++ R/get_test_codes_for_functions_in_file.R | 25 +----------------------- 2 files changed, 3 insertions(+), 24 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 19837db..f485546 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -17,12 +17,14 @@ License: MIT + file LICENSE URL: https://github.com/kwb-r/kwb.test BugReports: https://github.com/kwb-r/kwb.test/issues Imports: + kwb.code, kwb.utils, usethis Suggests: compare, testthat Remotes: + github::kwb-r/kwb.code github::kwb-r/kwb.utils Encoding: UTF-8 LazyData: TRUE diff --git a/R/get_test_codes_for_functions_in_file.R b/R/get_test_codes_for_functions_in_file.R index 6a38a9e..d952fec 100644 --- a/R/get_test_codes_for_functions_in_file.R +++ b/R/get_test_codes_for_functions_in_file.R @@ -2,7 +2,7 @@ get_test_codes_for_functions_in_file <- function(file, pkg_name, test_dir, ...) { # Get the expressions that represent assignments of function definitions - assignments <- get_function_assignments(file) + assignments <- kwb.code::get_function_assignments(file) # Exclude functions for which a test file already exists { @@ -34,29 +34,6 @@ get_test_codes_for_functions_in_file <- function(file, pkg_name, test_dir, ...) kwb.utils::excludeNULL(test_calls, dbg = FALSE) } -# get_function_assignments ----------------------------------------------------- -get_function_assignments <- function(file) -{ - code <- as.list(parse(file)) - - #expr <- code[[2]] - - is_function_assignment <- sapply(code, function(expr) { - - ok <- as.character(expr[[1]]) == "<-" - - ok && length(expr) >= 3 && as.character(expr[[3]][[1]]) == "function" - }) - - assignments <- code[is_function_assignment] - - # Name the assignments according to the function names - stats::setNames( - assignments, - sapply(assignments, function(x) as.character(x[[2]])) - ) -} - # path_to_testfile ------------------------------------------------------------- path_to_testfile <- function(test_dir, fun_name) { From 84f993b1b4aef03e2a06dd1343b2e2cceafa17b8 Mon Sep 17 00:00:00 2001 From: hsonne Date: Tue, 26 Sep 2023 07:06:29 +0200 Subject: [PATCH 24/49] Fix CI: Replace "master" with "v2" --- .github/workflows/R-CMD-check.yaml | 10 +++++----- .github/workflows/pkgdown.yaml | 4 ++-- .github/workflows/pr-commands.yaml | 12 ++++++------ .github/workflows/test-coverage.yaml | 4 ++-- 4 files changed, 15 insertions(+), 15 deletions(-) diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index 909fbdf..bdd8319 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -22,9 +22,9 @@ jobs: fail-fast: false matrix: config: - - {os: macOS-latest, r: 'release'} - - {os: ubuntu-20.04, r: 'release', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"} - - {os: windows-latest, r: 'devel'} + - {os: macOS-latest, r: 'release'} + - {os: ubuntu-20.04, r: 'release', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"} + - {os: windows-latest, r: 'devel'} - {os: windows-latest, r: 'oldrel'} - {os: windows-latest, r: 'release'} @@ -35,11 +35,11 @@ jobs: steps: - uses: actions/checkout@v2 - - uses: r-lib/actions/setup-r@master + - uses: r-lib/actions/setup-r@v2 with: r-version: ${{ matrix.config.r }} - - uses: r-lib/actions/setup-pandoc@master + - uses: r-lib/actions/setup-pandoc@v2 - name: Query dependencies run: | diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml index 58a9d79..7dc7100 100644 --- a/.github/workflows/pkgdown.yaml +++ b/.github/workflows/pkgdown.yaml @@ -15,9 +15,9 @@ jobs: steps: - uses: actions/checkout@v2 - - uses: r-lib/actions/setup-r@master + - uses: r-lib/actions/setup-r@v2 - - uses: r-lib/actions/setup-pandoc@master + - uses: r-lib/actions/setup-pandoc@v2 - name: Query dependencies run: | diff --git a/.github/workflows/pr-commands.yaml b/.github/workflows/pr-commands.yaml index 0d3cb71..cfda2fb 100644 --- a/.github/workflows/pr-commands.yaml +++ b/.github/workflows/pr-commands.yaml @@ -11,10 +11,10 @@ jobs: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} steps: - uses: actions/checkout@v2 - - uses: r-lib/actions/pr-fetch@master + - uses: r-lib/actions/pr-fetch@v2 with: repo-token: ${{ secrets.GITHUB_TOKEN }} - - uses: r-lib/actions/setup-r@master + - uses: r-lib/actions/setup-r@v2 - name: Install dependencies run: Rscript -e 'install.packages(c("remotes", "roxygen2"))' -e 'remotes::install_deps(dependencies = TRUE)' - name: Document @@ -23,7 +23,7 @@ jobs: run: | git add man/\* NAMESPACE git commit -m 'Document' - - uses: r-lib/actions/pr-push@master + - uses: r-lib/actions/pr-push@v2 with: repo-token: ${{ secrets.GITHUB_TOKEN }} style: @@ -34,10 +34,10 @@ jobs: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} steps: - uses: actions/checkout@v2 - - uses: r-lib/actions/pr-fetch@master + - uses: r-lib/actions/pr-fetch@v2 with: repo-token: ${{ secrets.GITHUB_TOKEN }} - - uses: r-lib/actions/setup-r@master + - uses: r-lib/actions/setup-r@v2 - name: Install dependencies run: Rscript -e 'install.packages("styler")' - name: Style @@ -46,6 +46,6 @@ jobs: run: | git add \*.R git commit -m 'Style' - - uses: r-lib/actions/pr-push@master + - uses: r-lib/actions/pr-push@v2 with: repo-token: ${{ secrets.GITHUB_TOKEN }} diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml index 4efc7ab..c4cfea8 100644 --- a/.github/workflows/test-coverage.yaml +++ b/.github/workflows/test-coverage.yaml @@ -18,9 +18,9 @@ jobs: steps: - uses: actions/checkout@v2 - - uses: r-lib/actions/setup-r@master + - uses: r-lib/actions/setup-r@v2 - - uses: r-lib/actions/setup-pandoc@master + - uses: r-lib/actions/setup-pandoc@v2 - name: Query dependencies run: | From e841e5146bbc3efe93051d65e95986407b94d1be Mon Sep 17 00:00:00 2001 From: hsonne Date: Tue, 26 Sep 2023 07:15:16 +0200 Subject: [PATCH 25/49] Add missing comma --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index f485546..a643af0 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -24,7 +24,7 @@ Suggests: compare, testthat Remotes: - github::kwb-r/kwb.code + github::kwb-r/kwb.code, github::kwb-r/kwb.utils Encoding: UTF-8 LazyData: TRUE From d4524c904bd49c0114147708139eb9e8183d1a1c Mon Sep 17 00:00:00 2001 From: hsonne Date: Mon, 12 Feb 2024 12:47:22 +0100 Subject: [PATCH 26/49] Remove test of get_function_assignments() The function has been moved to kwb.test --- tests/testthat/test-testCreate.R | 21 --------------------- 1 file changed, 21 deletions(-) diff --git a/tests/testthat/test-testCreate.R b/tests/testthat/test-testCreate.R index c891148..dc059c6 100644 --- a/tests/testthat/test-testCreate.R +++ b/tests/testthat/test-testCreate.R @@ -13,27 +13,6 @@ test_that("get_test_codes_for_functions_in_file() works", { expect_error(kwb.test:::get_test_codes_for_functions_in_file()) }) -test_that("get_function_assignments() works", { - - f <- kwb.test:::get_function_assignments - - expect_error(f()) - - file <- tempfile("test-", fileext = ".R") - - writeLines( - text = c( - "id <- function(x) x", - "plus <- function(x, y) x + y" - ), - con = file - ) - - result <- f(file) - - expect_identical(names(result), c("id", "plus")) -}) - test_that("get_test_for_function_assignment() works", { expect_error(kwb.test:::get_test_for_function_assignment()) From a4bb178dbd97e1f40cb900487352c941f4df96b7 Mon Sep 17 00:00:00 2001 From: hsonne Date: Mon, 12 Feb 2024 13:11:52 +0100 Subject: [PATCH 27/49] Indent argument list, add comments and rely on the fact that use_testthat() creates the `tests/testthat` subfolder --- R/create_test_files.R | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/R/create_test_files.R b/R/create_test_files.R index efaab11..2c077b1 100644 --- a/R/create_test_files.R +++ b/R/create_test_files.R @@ -23,25 +23,30 @@ #' @importFrom kwb.utils createDirectory #' create_test_files <- function( - package_dir = getwd(), target_dir = NULL, file_per_function = TRUE, - full = FALSE, dbg = TRUE + package_dir = getwd(), + target_dir = NULL, + file_per_function = TRUE, + full = FALSE, + dbg = TRUE ) { #package_dir = getwd(); file_per_function = TRUE; full = FALSE; dbg = TRUE pkg_name <- basename(package_dir) + # Change into the package directory and change back on exit old_dir <- setwd(package_dir) - on.exit(setwd(old_dir)) usethis::use_testthat() + # Get the paths to the R scripts in the R subfolder scripts <- dir("R", pattern = "^[^.].*\\.[rR]$", full.names = TRUE) - if (is.null(target_dir)) { - target_dir <- kwb.utils::createDirectory("tests/testthat", dbg = dbg) - } + # Set the target directory to the testthat directory by default + target_dir <- kwb.utils::defaultIfNULL( + target_dir, kwb.utils::safePath(package_dir, "tests/testthat") + ) #script <- scripts[3] From 1853e9bbc37b798cf85b0df23763071d7434c878 Mon Sep 17 00:00:00 2001 From: hsonne Date: Wed, 14 Feb 2024 11:18:49 +0100 Subject: [PATCH 28/49] Extract get_full_function_name() --- R/get_test_for_function_calls.R | 22 ++++++++++++++++------ 1 file changed, 16 insertions(+), 6 deletions(-) diff --git a/R/get_test_for_function_calls.R b/R/get_test_for_function_calls.R index b75af3e..8869fdf 100644 --- a/R/get_test_for_function_calls.R +++ b/R/get_test_for_function_calls.R @@ -17,12 +17,7 @@ get_test_for_function_calls <- function( errors <- sapply(errors, get_error_message) - full_fun_name <- kwb.utils::resolve( - ifelse(exported, "pkg_fun_exported", "pkg_fun_private"), - templates_raw, - fun = fun_name, - pkg = pkg_name - ) + full_fun_name <- get_full_function_name(fun_name, pkg_name, exported) pattern <- paste0("(^|\\s)", full_fun_name, "\\(") @@ -92,6 +87,21 @@ get_templates <- function() ) } +# get_full_function_name ------------------------------------------------------- +get_full_function_name <- function( + fun_name, + pkg_name, + exported = fun_name %in% getNamespaceExports(pkg_name) +) +{ + kwb.utils::resolve( + ifelse(exported, "pkg_fun_exported", "pkg_fun_private"), + get_templates(), + fun = fun_name, + pkg = pkg_name + ) +} + # which_calls_fail ------------------------------------------------------------- which_calls_fail <- function(call_strings, dbg = TRUE) { From 08342f566d799d8591538139757d5f8a45b1eecd Mon Sep 17 00:00:00 2001 From: hsonne Date: Wed, 14 Feb 2024 11:21:21 +0100 Subject: [PATCH 29/49] Extract full_function_name() and remove get_shortcut_assignment() --- R/get_test_for_function_calls.R | 16 ++++------------ 1 file changed, 4 insertions(+), 12 deletions(-) diff --git a/R/get_test_for_function_calls.R b/R/get_test_for_function_calls.R index 8869fdf..9ed0716 100644 --- a/R/get_test_for_function_calls.R +++ b/R/get_test_for_function_calls.R @@ -45,10 +45,8 @@ get_test_for_function_calls <- function( #call_strings[fails] <- sprintf("expect_error(%s)", call_strings[fails]) #test_that_body <- paste0(" ", call_strings, collapse = "\n") - shortcut <- get_shortcut_assignment(templates_raw, fun_name, pkg_name) - test_that_body <- paste0( - " ", shortcut, "\n\n", + " f <- ", full_function_name(pkg_name, fun_name, exported), "\n\n", kwb.utils::collapsed(c(expect_calls_success, expect_calls_fail)) ) @@ -148,14 +146,8 @@ get_error_message <- function(error) } } -# get_shortcut_assignment ------------------------------------------------------ -get_shortcut_assignment <- function(templates, fun_name, pkg_name) +# full_function_name ----------------------------------------------------------- +full_function_name <- function(pkg_name, fun_name, exported) { - sprintf( - "f <- %s", - kwb.utils::selectElements( - kwb.utils::resolve(templates, fun = fun_name, pkg = pkg_name), - ifelse(pkg_name == "", "pkg_fun_exported", "pkg_fun_private") - ) - ) + paste0(pkg_name, ifelse(exported, "::", ":::"), fun_name) } From 5d15760bace406ae16a0899eb97660a7a2d571f9 Mon Sep 17 00:00:00 2001 From: hsonne Date: Wed, 14 Feb 2024 11:21:51 +0100 Subject: [PATCH 30/49] Update NAMESPACE and DESCRIPTION --- DESCRIPTION | 5 +++-- NAMESPACE | 1 - 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index a643af0..fad1888 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -22,10 +22,11 @@ Imports: usethis Suggests: compare, - testthat + testthat (>= 3.0.0) Remotes: github::kwb-r/kwb.code, github::kwb-r/kwb.utils Encoding: UTF-8 LazyData: TRUE -RoxygenNote: 7.2.3 +RoxygenNote: 7.3.1 +Config/testthat/edition: 3 diff --git a/NAMESPACE b/NAMESPACE index d2b5eaf..acdc3dc 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -6,7 +6,6 @@ export(printTestMessage) export(saveArgs) export(testColumnwiseIdentity) export(test_function) -importFrom(kwb.utils,asColumnList) importFrom(kwb.utils,catAndRun) importFrom(kwb.utils,collapsed) importFrom(kwb.utils,createDirectory) From 89d8126d1d055c3cd8aabb2665333e4be6729ace Mon Sep 17 00:00:00 2001 From: hsonne Date: Wed, 14 Feb 2024 11:29:20 +0100 Subject: [PATCH 31/49] Rename "templates_raw" to "templates" --- R/get_test_for_function_calls.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/R/get_test_for_function_calls.R b/R/get_test_for_function_calls.R index 9ed0716..818cb89 100644 --- a/R/get_test_for_function_calls.R +++ b/R/get_test_for_function_calls.R @@ -4,7 +4,7 @@ get_test_for_function_calls <- function( call_strings, fun_name, pkg_name, exported ) { - templates_raw <- get_templates() + templates <- get_templates() # Remove the calls that generate the same error messages as previous calls fail_indices <- which_calls_fail(call_strings, dbg = FALSE) @@ -27,7 +27,7 @@ get_test_for_function_calls <- function( kwb.utils::resolve( "fun_call_error", - templates_raw, + templates, fun_call = use_shortcut(call_strings[fail_indices[i]]), quoted_error = gsub("\n", "\n# ", errors[i]) ) @@ -37,7 +37,7 @@ get_test_for_function_calls <- function( kwb.utils::resolve( "fun_call_alone", - templates_raw, + templates, fun_call = use_shortcut(call_strings[i]) ) }) @@ -52,7 +52,7 @@ get_test_for_function_calls <- function( test_that_call <- kwb.utils::resolve( "test_that_call", - templates_raw, + templates, fun = fun_name, #pkg = pkg_name, #pkg_fun = "f", #ifelse(exported, "", ""), From 3ab29a6e2e97dd4e8c3a080e03261e638802e345 Mon Sep 17 00:00:00 2001 From: hsonne Date: Thu, 15 Feb 2024 14:13:45 +0100 Subject: [PATCH 32/49] Recreate testthat.R --- tests/testthat.R | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/tests/testthat.R b/tests/testthat.R index 99832a5..84ce711 100644 --- a/tests/testthat.R +++ b/tests/testthat.R @@ -1,3 +1,11 @@ +# This file is part of the standard setup for testthat. +# It is recommended that you do not modify it. +# +# Where should you do additional test configuration? +# Learn more about the roles of various files in: +# * https://r-pkgs.org/testing-design.html#sec-tests-files-overview +# * https://testthat.r-lib.org/articles/special-files.html + library(testthat) library(kwb.test) From 98273d99443b345564b2d6afb143013038db73ba Mon Sep 17 00:00:00 2001 From: hsonne Date: Thu, 15 Feb 2024 14:28:35 +0100 Subject: [PATCH 33/49] Reintegrate get_test_for_function() into lapply --- R/get_test_codes_for_functions_in_file.R | 77 ++++++++---------------- 1 file changed, 26 insertions(+), 51 deletions(-) diff --git a/R/get_test_codes_for_functions_in_file.R b/R/get_test_codes_for_functions_in_file.R index d952fec..d76c5c8 100644 --- a/R/get_test_codes_for_functions_in_file.R +++ b/R/get_test_codes_for_functions_in_file.R @@ -1,5 +1,7 @@ # get_test_codes_for_functions_in_file ----------------------------------------- -get_test_codes_for_functions_in_file <- function(file, pkg_name, test_dir, ...) +get_test_codes_for_functions_in_file <- function( + file, pkg_name, test_dir, full = FALSE +) { # Get the expressions that represent assignments of function definitions assignments <- kwb.code::get_function_assignments(file) @@ -20,12 +22,22 @@ get_test_codes_for_functions_in_file <- function(file, pkg_name, test_dir, ...) test_calls <- lapply( X = stats::setNames(nm = names(assignments)), FUN = function(fun_name) { - get_test_for_function( + arg_strings <- if (full) { + arg_combis_to_arg_strings( + arg_combis = get_arg_combis( + arg_names = get_no_default_args( + arguments = assignments[[fun_name]][[3L]][[2L]] + ) + ) + ) + } else { + "" + } + get_test_for_function_calls( + call_strings = sprintf("%s(%s)", fun_name, arg_strings), fun_name = fun_name, - fun_args = assignments[[fun_name]][[3]][[2]], pkg_name = pkg_name, - exports = exports, - ... + exported = fun_name %in% exports ) } ) @@ -40,35 +52,6 @@ path_to_testfile <- function(test_dir, fun_name) sprintf("%s/test-function-%s.R", test_dir, fun_name) } -# get_test_for_function -------------------------------------------------------- -get_test_for_function <- function( - fun_name, - fun_args, - pkg_name, - exports = getNamespaceExports(pkg_name), - full = FALSE -) -{ - #assignment <- assignments[[1]] - - arg_combis <- if (full) { - - get_arg_combis(arg_names = get_no_default_args(fun_args)) - - } else { - - data.frame() - } - - #fun_name <- as.character(assignment[[2]]) - - call_strings <- get_function_call_strings(fun_name, arg_combis, pkg_name) - - exported <- fun_name %in% exports - - get_test_for_function_calls(call_strings, fun_name, pkg_name, exported) -} - # get_no_default_args ---------------------------------------------------------- get_no_default_args <- function(arguments) { @@ -107,24 +90,16 @@ get_arg_combis <- function(arg_names, max_args = 2L) } } -# get_function_call_strings ---------------------------------------------------- -#' @importFrom kwb.utils asColumnList resolve -get_function_call_strings <- function(fun_name, arg_combis, pkg_name = "") +# arg_combis_to_arg_strings ---------------------------------------------------- +arg_combis_to_arg_strings <- function(arg_combis) { - arg_strings <- if (nrow(arg_combis) > 0L) { - - arg_combi_list <- kwb.utils::asColumnList(as.matrix(arg_combis)) - - assignment <- function(name) paste(name, "=", arg_combi_list[[name]]) - - paste_args <- c(lapply(names(arg_combi_list), assignment), sep = ", ") - - arg_strings <- do.call(paste, paste_args) - - } else { - - "" + if (nrow(arg_combis) == 0L) { + return("") } - sprintf("f(%s)", arg_strings) + args_for_paste <- lapply(names(arg_combis), function(arg_name) { + paste(arg_name, "=", arg_combis[[arg_name]]) + }) + + do.call(paste, c(args_for_paste, sep = ", ")) } From 21f2dc1fee3448c74745125eb0ac996aa0e863da Mon Sep 17 00:00:00 2001 From: hsonne Date: Thu, 15 Feb 2024 15:04:16 +0100 Subject: [PATCH 34/49] Change interface to get_test_for_function_calls() --- R/get_test_codes_for_functions_in_file.R | 27 ++++++++++++------------ R/get_test_for_function_calls.R | 4 +++- 2 files changed, 16 insertions(+), 15 deletions(-) diff --git a/R/get_test_codes_for_functions_in_file.R b/R/get_test_codes_for_functions_in_file.R index d76c5c8..c5acb81 100644 --- a/R/get_test_codes_for_functions_in_file.R +++ b/R/get_test_codes_for_functions_in_file.R @@ -22,22 +22,21 @@ get_test_codes_for_functions_in_file <- function( test_calls <- lapply( X = stats::setNames(nm = names(assignments)), FUN = function(fun_name) { - arg_strings <- if (full) { - arg_combis_to_arg_strings( - arg_combis = get_arg_combis( - arg_names = get_no_default_args( - arguments = assignments[[fun_name]][[3L]][[2L]] - ) - ) - ) - } else { - "" - } get_test_for_function_calls( - call_strings = sprintf("%s(%s)", fun_name, arg_strings), - fun_name = fun_name, pkg_name = pkg_name, - exported = fun_name %in% exports + fun_name = fun_name, + exported = fun_name %in% exports, + arg_strings = if (full) { + arg_combis_to_arg_strings( + arg_combis = get_arg_combis( + arg_names = get_no_default_args( + arguments = assignments[[fun_name]][[3L]][[2L]] + ) + ) + ) + } else { + "" + } ) } ) diff --git a/R/get_test_for_function_calls.R b/R/get_test_for_function_calls.R index 818cb89..54fa506 100644 --- a/R/get_test_for_function_calls.R +++ b/R/get_test_for_function_calls.R @@ -1,11 +1,13 @@ # get_test_for_function_calls -------------------------------------------------- #' @importFrom kwb.utils collapsed getAttribute resolve get_test_for_function_calls <- function( - call_strings, fun_name, pkg_name, exported + pkg_name, fun_name, exported = FALSE, arg_strings = "" ) { templates <- get_templates() + call_strings <- sprintf("%s(%s)", fun_name, arg_strings) + # Remove the calls that generate the same error messages as previous calls fail_indices <- which_calls_fail(call_strings, dbg = FALSE) From 7bc7fbe33b5ab470bd737c94d8d49b7312e0dbd1 Mon Sep 17 00:00:00 2001 From: hsonne Date: Thu, 15 Feb 2024 15:19:21 +0100 Subject: [PATCH 35/49] Use different call strings for actual calls --- R/get_test_for_function_calls.R | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/R/get_test_for_function_calls.R b/R/get_test_for_function_calls.R index 54fa506..4117b85 100644 --- a/R/get_test_for_function_calls.R +++ b/R/get_test_for_function_calls.R @@ -6,10 +6,17 @@ get_test_for_function_calls <- function( { templates <- get_templates() - call_strings <- sprintf("%s(%s)", fun_name, arg_strings) - # Remove the calls that generate the same error messages as previous calls - fail_indices <- which_calls_fail(call_strings, dbg = FALSE) + fail_indices <- which_calls_fail(dbg = FALSE, kwb.utils::resolve( + "fun_call", + templates, + args = arg_strings, + pkg_fun = "", + pkg = pkg_name, + fun = fun_name + )) + + call_strings <- sprintf("%s(%s)", fun_name, arg_strings) success_indices <- setdiff(seq_along(call_strings), fail_indices) From 289fa900ccb20d8954747d6f71ff3903310d1fdd Mon Sep 17 00:00:00 2001 From: hsonne Date: Thu, 15 Feb 2024 16:18:59 +0100 Subject: [PATCH 36/49] Add comments to facilitate debugging --- R/create_test_files.R | 6 +++--- R/get_test_codes_for_functions_in_file.R | 1 + 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/R/create_test_files.R b/R/create_test_files.R index 2c077b1..e2cb62c 100644 --- a/R/create_test_files.R +++ b/R/create_test_files.R @@ -48,12 +48,12 @@ create_test_files <- function( target_dir, kwb.utils::safePath(package_dir, "tests/testthat") ) - #script <- scripts[3] - for (script in scripts) { + #script <- scripts[1L] + create_tests_for_file( - script, + script = script, test_dir = target_dir, pkg_name = pkg_name, file_per_function = file_per_function, diff --git a/R/get_test_codes_for_functions_in_file.R b/R/get_test_codes_for_functions_in_file.R index c5acb81..3ac4448 100644 --- a/R/get_test_codes_for_functions_in_file.R +++ b/R/get_test_codes_for_functions_in_file.R @@ -22,6 +22,7 @@ get_test_codes_for_functions_in_file <- function( test_calls <- lapply( X = stats::setNames(nm = names(assignments)), FUN = function(fun_name) { + #fun_name <- X[[1L]] get_test_for_function_calls( pkg_name = pkg_name, fun_name = fun_name, From 26c181af328f7dea829124dcb6d57198a3779133 Mon Sep 17 00:00:00 2001 From: hsonne Date: Thu, 15 Feb 2024 16:19:21 +0100 Subject: [PATCH 37/49] Remove single_quoted() (never used) --- R/utils.R | 6 ------ 1 file changed, 6 deletions(-) diff --git a/R/utils.R b/R/utils.R index e3caeb8..0bba558 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1,9 +1,3 @@ -# single_quoted ---------------------------------------------------------------- -single_quoted <- function(x) -{ - paste0("'", gsub("'", "\\\\'", x), "'") -} - # warn_if_file_exists ---------------------------------------------------------- warn_if_file_exists <- function(test_file) { From 4a849bdacfb506466596bc0ece67e0a3930403b2 Mon Sep 17 00:00:00 2001 From: hsonne Date: Thu, 15 Feb 2024 16:20:00 +0100 Subject: [PATCH 38/49] Simplify/repair get_test_for_function_calls() --- R/get_test_for_function_calls.R | 37 ++++++++++++--------------------- 1 file changed, 13 insertions(+), 24 deletions(-) diff --git a/R/get_test_for_function_calls.R b/R/get_test_for_function_calls.R index 4117b85..4665e20 100644 --- a/R/get_test_for_function_calls.R +++ b/R/get_test_for_function_calls.R @@ -16,46 +16,37 @@ get_test_for_function_calls <- function( fun = fun_name )) - call_strings <- sprintf("%s(%s)", fun_name, arg_strings) - - success_indices <- setdiff(seq_along(call_strings), fail_indices) + success_indices <- setdiff(seq_along(arg_strings), fail_indices) fail_indices <- remove_duplicated_fails(fail_indices) - errors <- kwb.utils::getAttribute(fail_indices, "errors") - - errors <- sapply(errors, get_error_message) - - full_fun_name <- get_full_function_name(fun_name, pkg_name, exported) - - pattern <- paste0("(^|\\s)", full_fun_name, "\\(") - - use_shortcut <- function(x) gsub(pattern, "f(", x) + errors <- sapply( + X = kwb.utils::getAttribute(fail_indices, "errors"), + FUN = get_error_message + ) expect_calls_fail <- sapply(seq_along(fail_indices), function(i) { - kwb.utils::resolve( "fun_call_error", templates, - fun_call = use_shortcut(call_strings[fail_indices[i]]), + pkg_fun = "f", + args = arg_strings[fail_indices[i]], quoted_error = gsub("\n", "\n# ", errors[i]) ) }) expect_calls_success <- sapply(success_indices, function(i) { - kwb.utils::resolve( "fun_call_alone", templates, - fun_call = use_shortcut(call_strings[i]) + pkg_fun = "f", + args = arg_strings[i] ) }) - #call_strings[fails] <- sprintf("expect_error(%s)", call_strings[fails]) - #test_that_body <- paste0(" ", call_strings, collapse = "\n") - - test_that_body <- paste0( - " f <- ", full_function_name(pkg_name, fun_name, exported), "\n\n", + test_that_body <- sprintf( + " f <- %s\n\n%s\n", + full_function_name(pkg_name, fun_name, exported), kwb.utils::collapsed(c(expect_calls_success, expect_calls_fail)) ) @@ -63,9 +54,7 @@ get_test_for_function_calls <- function( "test_that_call", templates, fun = fun_name, - #pkg = pkg_name, - #pkg_fun = "f", #ifelse(exported, "", ""), - test_that_body = paste0(test_that_body, "\n") + test_that_body = test_that_body ) structure(test_that_call, fun_name = fun_name) From 3d3a284c5f0d9e6a762f1038de6fca331ad732d2 Mon Sep 17 00:00:00 2001 From: hsonne Date: Thu, 15 Feb 2024 16:20:50 +0100 Subject: [PATCH 39/49] Do not support the "full" argument any more as it leads to errors. --- R/get_test_codes_for_functions_in_file.R | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/R/get_test_codes_for_functions_in_file.R b/R/get_test_codes_for_functions_in_file.R index 3ac4448..e09036c 100644 --- a/R/get_test_codes_for_functions_in_file.R +++ b/R/get_test_codes_for_functions_in_file.R @@ -3,6 +3,15 @@ get_test_codes_for_functions_in_file <- function( file, pkg_name, test_dir, full = FALSE ) { + if (full) { + stop( + "get_test_codes_for_functions_in_file(..., full = TRUE) is currently ", + "not supported!" + ) + } + + #file = script + # Get the expressions that represent assignments of function definitions assignments <- kwb.code::get_function_assignments(file) From fb4a3f2a0da12594a8bdbd447eb777920a8c839f Mon Sep 17 00:00:00 2001 From: hsonne Date: Fri, 16 Feb 2024 06:38:24 +0100 Subject: [PATCH 40/49] Always return a data frame because the column names of the result of this function are accessed with names() and its columns with x[[column]] --- R/get_test_codes_for_functions_in_file.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/get_test_codes_for_functions_in_file.R b/R/get_test_codes_for_functions_in_file.R index e09036c..01eb552 100644 --- a/R/get_test_codes_for_functions_in_file.R +++ b/R/get_test_codes_for_functions_in_file.R @@ -85,7 +85,7 @@ get_arg_combis <- function(arg_names, max_args = 2L) if (n == 1L) { - matrix(string_values, ncol = 1L, dimnames = list(NULL, arg_names)) + stats::setNames(data.frame(string_values), arg_names) } else { From 14b04ca65a758843ba20f4425fb766a252fec8b5 Mon Sep 17 00:00:00 2001 From: hsonne Date: Fri, 16 Feb 2024 07:12:58 +0100 Subject: [PATCH 41/49] Fix :bug:: call kwb.utils::resolve() in a loop --- R/get_test_for_function_calls.R | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/R/get_test_for_function_calls.R b/R/get_test_for_function_calls.R index 4665e20..e15bde2 100644 --- a/R/get_test_for_function_calls.R +++ b/R/get_test_for_function_calls.R @@ -6,15 +6,20 @@ get_test_for_function_calls <- function( { templates <- get_templates() + # Create function call strings + call_strings <- unname(sapply(arg_strings, function(x) { + kwb.utils::resolve( + "fun_call", + templates, + args = x, + pkg_fun = "", + pkg = pkg_name, + fun = fun_name + ) + })) + # Remove the calls that generate the same error messages as previous calls - fail_indices <- which_calls_fail(dbg = FALSE, kwb.utils::resolve( - "fun_call", - templates, - args = arg_strings, - pkg_fun = "", - pkg = pkg_name, - fun = fun_name - )) + fail_indices <- which_calls_fail(call_strings, dbg = FALSE) success_indices <- setdiff(seq_along(arg_strings), fail_indices) From 799012b4c8f5798419e89e936c4eb64f0f938cbb Mon Sep 17 00:00:00 2001 From: hsonne Date: Fri, 16 Feb 2024 07:25:44 +0100 Subject: [PATCH 42/49] Suppress warnings when evaluating expressions --- R/get_test_for_function_calls.R | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/R/get_test_for_function_calls.R b/R/get_test_for_function_calls.R index e15bde2..3fa4b10 100644 --- a/R/get_test_for_function_calls.R +++ b/R/get_test_for_function_calls.R @@ -107,7 +107,6 @@ get_full_function_name <- function( which_calls_fail <- function(call_strings, dbg = TRUE) { results <- lapply(call_strings, function(call_string) { - tryCatch(eval_text(call_string, dbg), error = identity) }) @@ -121,7 +120,7 @@ which_calls_fail <- function(call_strings, dbg = TRUE) eval_text <- function(text, dbg = TRUE) { kwb.utils::catAndRun(paste0("Evaluating:\n ", text, "\n"), dbg = dbg, { - eval(parse(text = text)) + suppressWarnings(eval(parse(text = text))) }) } From 11dcd099dbdb0f1310f7d458574f3dfe7cdc2d5b Mon Sep 17 00:00:00 2001 From: hsonne Date: Fri, 16 Feb 2024 07:32:20 +0100 Subject: [PATCH 43/49] Seq along what was the base for "fail_indices" --- R/get_test_for_function_calls.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/get_test_for_function_calls.R b/R/get_test_for_function_calls.R index 3fa4b10..7c61e28 100644 --- a/R/get_test_for_function_calls.R +++ b/R/get_test_for_function_calls.R @@ -21,7 +21,7 @@ get_test_for_function_calls <- function( # Remove the calls that generate the same error messages as previous calls fail_indices <- which_calls_fail(call_strings, dbg = FALSE) - success_indices <- setdiff(seq_along(arg_strings), fail_indices) + success_indices <- setdiff(seq_along(call_strings), fail_indices) fail_indices <- remove_duplicated_fails(fail_indices) From 30b0fa4fcfa1ed20368840f166df505999d705b4 Mon Sep 17 00:00:00 2001 From: hsonne Date: Fri, 16 Feb 2024 07:41:28 +0100 Subject: [PATCH 44/49] Allow argument "full" again --- R/get_test_codes_for_functions_in_file.R | 7 ------- 1 file changed, 7 deletions(-) diff --git a/R/get_test_codes_for_functions_in_file.R b/R/get_test_codes_for_functions_in_file.R index 01eb552..6cdf71a 100644 --- a/R/get_test_codes_for_functions_in_file.R +++ b/R/get_test_codes_for_functions_in_file.R @@ -3,13 +3,6 @@ get_test_codes_for_functions_in_file <- function( file, pkg_name, test_dir, full = FALSE ) { - if (full) { - stop( - "get_test_codes_for_functions_in_file(..., full = TRUE) is currently ", - "not supported!" - ) - } - #file = script # Get the expressions that represent assignments of function definitions From 2c3738d29afa9750e2eea43a43db1e49dbd6d7b9 Mon Sep 17 00:00:00 2001 From: Hauke Sonnenberg Date: Fri, 16 Feb 2024 07:53:50 +0100 Subject: [PATCH 45/49] Use env variable "GITHUB_PAT" --- .github/workflows/R-CMD-check.yaml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index bdd8319..e122ca0 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -29,6 +29,7 @@ jobs: - {os: windows-latest, r: 'release'} env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} R_REMOTES_NO_ERRORS_FROM_WARNINGS: true RSPM: ${{ matrix.config.rspm }} From 0ffdc727e162591fb6b48d8a2c6538728d225696 Mon Sep 17 00:00:00 2001 From: Hauke Sonnenberg Date: Fri, 16 Feb 2024 08:00:25 +0100 Subject: [PATCH 46/49] Rely on kwb.code from the "dev" branch --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index a643af0..bedcade 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -24,7 +24,7 @@ Suggests: compare, testthat Remotes: - github::kwb-r/kwb.code, + github::kwb-r/kwb.code@dev, github::kwb-r/kwb.utils Encoding: UTF-8 LazyData: TRUE From a5db297708f86b83888f8cfc7f83cabd6f362dc5 Mon Sep 17 00:00:00 2001 From: hsonne Date: Fri, 16 Feb 2024 08:04:59 +0100 Subject: [PATCH 47/49] Rely on kwb.code from the "dev" branch --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index fad1888..8fe60f0 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -17,7 +17,7 @@ License: MIT + file LICENSE URL: https://github.com/kwb-r/kwb.test BugReports: https://github.com/kwb-r/kwb.test/issues Imports: - kwb.code, + kwb.code@dev, kwb.utils, usethis Suggests: From 027a2cd248cbd33d0b8699913da745496e605e38 Mon Sep 17 00:00:00 2001 From: hsonne Date: Fri, 16 Feb 2024 08:12:20 +0100 Subject: [PATCH 48/49] Fix package dependency in DESCRIPTION --- DESCRIPTION | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 8fe60f0..e073b91 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -17,14 +17,14 @@ License: MIT + file LICENSE URL: https://github.com/kwb-r/kwb.test BugReports: https://github.com/kwb-r/kwb.test/issues Imports: - kwb.code@dev, + kwb.code, kwb.utils, usethis Suggests: compare, testthat (>= 3.0.0) Remotes: - github::kwb-r/kwb.code, + github::kwb-r/kwb.code@dev, github::kwb-r/kwb.utils Encoding: UTF-8 LazyData: TRUE From b349c8b5b1b2685cb934b7653a36803db343ab1b Mon Sep 17 00:00:00 2001 From: hsonne Date: Thu, 18 Apr 2024 20:30:27 +0200 Subject: [PATCH 49/49] Mention name of current script in debug message --- R/create_test_files.R | 43 +++++++++++++++++++++++++------------------ 1 file changed, 25 insertions(+), 18 deletions(-) diff --git a/R/create_test_files.R b/R/create_test_files.R index e2cb62c..8108ca9 100644 --- a/R/create_test_files.R +++ b/R/create_test_files.R @@ -23,11 +23,11 @@ #' @importFrom kwb.utils createDirectory #' create_test_files <- function( - package_dir = getwd(), - target_dir = NULL, - file_per_function = TRUE, - full = FALSE, - dbg = TRUE + package_dir = getwd(), + target_dir = NULL, + file_per_function = TRUE, + full = FALSE, + dbg = TRUE ) { #package_dir = getwd(); file_per_function = TRUE; full = FALSE; dbg = TRUE @@ -52,13 +52,20 @@ create_test_files <- function( #script <- scripts[1L] - create_tests_for_file( - script = script, - test_dir = target_dir, - pkg_name = pkg_name, - file_per_function = file_per_function, - full = full, - dbg = dbg + kwb.utils::catAndRun( + paste("Creating tests for functions in", script), + dbg = dbg, + newLine = 3L, + expr = { + create_tests_for_file( + script = script, + test_dir = target_dir, + pkg_name = pkg_name, + file_per_function = file_per_function, + full = full, + dbg = dbg + ) + } ) } } @@ -66,12 +73,12 @@ create_test_files <- function( # create_tests_for_file -------------------------------------------------------- #' @importFrom kwb.utils resolve user create_tests_for_file <- function( - script, - test_dir, - pkg_name, - file_per_function = TRUE, - full = FALSE, - dbg = TRUE + script, + test_dir, + pkg_name, + file_per_function = TRUE, + full = FALSE, + dbg = TRUE ) { # One test file per source file?