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..e122ca0 --- /dev/null +++ b/.github/workflows/R-CMD-check.yaml @@ -0,0 +1,82 @@ +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: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + R_REMOTES_NO_ERRORS_FROM_WARNINGS: true + RSPM: ${{ matrix.config.rspm }} + + steps: + - uses: actions/checkout@v2 + + - uses: r-lib/actions/setup-r@v2 + with: + r-version: ${{ matrix.config.r }} + + - uses: r-lib/actions/setup-pandoc@v2 + + - 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..7dc7100 --- /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@v2 + + - uses: r-lib/actions/setup-pandoc@v2 + + - 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..cfda2fb --- /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@v2 + with: + repo-token: ${{ secrets.GITHUB_TOKEN }} + - 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 + run: Rscript -e 'roxygen2::roxygenise()' + - name: commit + run: | + git add man/\* NAMESPACE + git commit -m 'Document' + - uses: r-lib/actions/pr-push@v2 + 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@v2 + with: + repo-token: ${{ secrets.GITHUB_TOKEN }} + - uses: r-lib/actions/setup-r@v2 + - 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@v2 + 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..c4cfea8 --- /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@v2 + + - uses: r-lib/actions/setup-pandoc@v2 + + - 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/DESCRIPTION b/DESCRIPTION index 864e5bf..e073b91 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -17,13 +17,16 @@ 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 + testthat (>= 3.0.0) Remotes: + github::kwb-r/kwb.code@dev, github::kwb-r/kwb.utils Encoding: UTF-8 LazyData: TRUE -RoxygenNote: 6.1.1 +RoxygenNote: 7.3.1 +Config/testthat/edition: 3 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 diff --git a/NAMESPACE b/NAMESPACE index 068b43e..acdc3dc 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -6,13 +6,11 @@ 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) importFrom(kwb.utils,expandGrid) importFrom(kwb.utils,getAttribute) importFrom(kwb.utils,resolve) -importFrom(kwb.utils,toNamedList) importFrom(kwb.utils,user) importFrom(usethis,use_testthat) diff --git a/R/create_test_files.R b/R/create_test_files.R new file mode 100644 index 0000000..8108ca9 --- /dev/null +++ b/R/create_test_files.R @@ -0,0 +1,147 @@ +# create_test_files ------------------------------------------------------------ + +#' Create Test Files +#' +#' Create test files for each source file containing one +#' \code{\link[testthat]{test_that}} call for each function in the package +#' +#' Existing test files will not be overwritten. +#' +#' @param package_dir path to package directory in which to create the test +#' files +#' @param target_dir directory in which to create the test files. Defaults to +#' \code{/tests/testthat}. +#' @param file_per_function if \code{TRUE} (default), one test file +#' \code{test-.R} is generated for each function, otherwise one test +#' file \code{test-} is generated for each source file. +#' @param full if \code{TRUE}, test calls with many argument combinations are +#' generated instead of only one call +#' @param dbg if \code{TRUE}, debug messages are shown +#' +#' @export +#' @importFrom usethis use_testthat +#' @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(); 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) + + # Set the target directory to the testthat directory by default + target_dir <- kwb.utils::defaultIfNULL( + target_dir, kwb.utils::safePath(package_dir, "tests/testthat") + ) + + for (script in scripts) { + + #script <- scripts[1L] + + 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 + ) + } + ) + } +} + +# 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 +) +{ + # One test file per source file? + if (!file_per_function) { + + test_file <- file.path(test_dir, paste0("test-file-", basename(script))) + + if (warn_if_file_exists(test_file)) { + return() + } + } + + # Parse the source file, find the function definitions and generate test + # code for each function + codes <- get_test_codes_for_functions_in_file( + file = script, + 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() + ) + + if (file_per_function) { + + # Write one file for each function in the source file + write_one_file_per_function(codes, test_dir, intro, dbg) + + } 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_per_function -------------------------------------------------- +#' @importFrom kwb.utils getAttribute +write_one_file_per_function <- function(codes, test_dir, intro, dbg = TRUE) +{ + for (code in codes) { + + fun_name <- kwb.utils::getAttribute(code, "fun_name") + + 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) + } + } +} + +# 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) + }) +} + 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..6cdf71a --- /dev/null +++ b/R/get_test_codes_for_functions_in_file.R @@ -0,0 +1,107 @@ +# get_test_codes_for_functions_in_file ----------------------------------------- +get_test_codes_for_functions_in_file <- function( + file, pkg_name, test_dir, full = FALSE +) +{ + #file = script + + # Get the expressions that represent assignments of function definitions + assignments <- kwb.code::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) + + # Create a test_that-call for each 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, + 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 { + "" + } + ) + } + ) + + # Remove NULL elements + kwb.utils::excludeNULL(test_calls, dbg = FALSE) +} + +# path_to_testfile ------------------------------------------------------------- +path_to_testfile <- function(test_dir, fun_name) +{ + sprintf("%s/test-function-%s.R", test_dir, fun_name) +} + +# 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) { + + stats::setNames(data.frame(string_values), 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) + } +} + +# arg_combis_to_arg_strings ---------------------------------------------------- +arg_combis_to_arg_strings <- function(arg_combis) +{ + if (nrow(arg_combis) == 0L) { + return("") + } + + 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 = ", ")) +} diff --git a/R/get_test_for_function_calls.R b/R/get_test_for_function_calls.R new file mode 100644 index 0000000..7c61e28 --- /dev/null +++ b/R/get_test_for_function_calls.R @@ -0,0 +1,155 @@ +# get_test_for_function_calls -------------------------------------------------- +#' @importFrom kwb.utils collapsed getAttribute resolve +get_test_for_function_calls <- function( + pkg_name, fun_name, exported = FALSE, arg_strings = "" +) +{ + 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(call_strings, dbg = FALSE) + + success_indices <- setdiff(seq_along(call_strings), fail_indices) + + fail_indices <- remove_duplicated_fails(fail_indices) + + 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, + 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, + pkg_fun = "f", + args = arg_strings[i] + ) + }) + + 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)) + ) + + test_that_call <- kwb.utils::resolve( + "test_that_call", + templates, + fun = fun_name, + test_that_body = test_that_body + ) + + structure(test_that_call, fun_name = fun_name) +} + +# get_templates ---------------------------------------------------------------- +get_templates <- function() +{ + templates <- list( + intro = "\n\n\n", + 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", + 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 = " " + ) +} + +# 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) +{ + 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, { + suppressWarnings(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 + } +} + +# full_function_name ----------------------------------------------------------- +full_function_name <- function(pkg_name, fun_name, exported) +{ + paste0(pkg_name, ifelse(exported, "::", ":::"), fun_name) +} 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/testCreate.R b/R/testCreate.R deleted file mode 100644 index d2a6a2b..0000000 --- a/R/testCreate.R +++ /dev/null @@ -1,406 +0,0 @@ -# create_test_files ------------------------------------------------------------ - -#' Create Test Files -#' -#' Create test files for each source file containing one -#' \code{\link[testthat]{test_that}} call for each function in the package -#' -#' Existing test files will not be overwritten. -#' -#' @param package_dir path to package directory in which to create the test -#' files -#' @param target_dir directory in which to create the test files. Defaults to -#' \code{/tests/testthat}. -#' @param file_per_function if \code{TRUE} (default), one test file -#' \code{test-.R} is generated for each function, otherwise one test -#' file \code{test-} is generated for each source file. -#' @param full if \code{TRUE}, test calls with many argument combinations are -#' generated instead of only one call -#' @param dbg if \code{TRUE}, debug messages are shown -#' -#' @export -#' @importFrom usethis use_testthat -#' @importFrom kwb.utils createDirectory -#' -create_test_files <- function( - package_dir = getwd(), target_dir = NULL, file_per_function = TRUE, - full = FALSE, dbg = TRUE -) -{ - if (FALSE) { - package_dir = getwd(); file_per_function = TRUE; full = FALSE; dbg = TRUE - } - - pkg_name <- basename(package_dir) - - old_dir <- setwd(package_dir) - - on.exit(setwd(old_dir)) - - usethis::use_testthat() - - 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) - } - - #source_file <- source_files[1] - - for (source_file in source_files) { - - create_tests_for_file( - source_file, target_dir, pkg_name, file_per_function, full, dbg - ) - } -} - -# 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, - 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) - - skip <- warn_if_file_exists(test_file) - } - - 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 - ) - - # 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) { - - # Write one file for each function in the source file - write_one_file_per_function(codes, test_dir, intro, dbg) - - } else { - - # Write one file for all functions in the source file - write_test_file(c(intro, do.call(c, codes)), test_file, dbg) - } - } -} - -# 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) -{ - 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) -{ - for (code in codes) { - - fun_name <- kwb.utils::getAttribute(code, "fun_name") - - filename <- sprintf("test-function-%s.R", fun_name) - - test_file <- file.path(test_dir, filename) - - if (! warn_if_file_exists(test_file)) { - - write_test_file(c(intro, code), test_file, dbg = dbg) - } - } -} - -# get_test_codes_for_functions_in_file ----------------------------------------- -#' @importFrom kwb.utils toNamedList -get_test_codes_for_functions_in_file <- function(file, pkg_name, ...) -{ - # 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 - 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_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) - - 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]], - 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 = 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) - ) - - test_that_call <- kwb.utils::resolve( - "test_that_call", templates_raw, fun = fun_name, pkg = pkg_name, - pkg_fun = ifelse(exported, "", ""), - test_that_body = paste0(test_that_body, "\n") - ) - - structure(test_that_call, fun_name = fun_name) -} - -# 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})\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(dbg = dbg, paste0("Evaluating:\n ", text, "\n"), { - eval(parse(text = text)) - }) -} - -# get_function_call_strings ---------------------------------------------------- -#' @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) { - - 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)", templates[[key]], 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/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 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 +} 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/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 - - 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) diff --git a/man/create_test_files.Rd b/man/create_test_files.Rd index 5be4c0c..2acda6c 100644 --- a/man/create_test_files.Rd +++ b/man/create_test_files.Rd @@ -1,11 +1,16 @@ % 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} \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/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 bce7975..14a9f4b 100644 --- a/man/saveArgs.Rd +++ b/man/saveArgs.Rd @@ -1,11 +1,14 @@ % 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} \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/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 4c7fd4e..2d808d8 100644 --- a/man/test_function.Rd +++ b/man/test_function.Rd @@ -1,11 +1,14 @@ % 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} \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. 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) diff --git a/tests/testthat/test-testCreate.R b/tests/testthat/test-testCreate.R index 990ceee..dc059c6 100644 --- a/tests/testthat/test-testCreate.R +++ b/tests/testthat/test-testCreate.R @@ -13,11 +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", { - - expect_error(kwb.test:::get_function_assignments()) -}) - test_that("get_test_for_function_assignment() works", { expect_error(kwb.test:::get_test_for_function_assignment())