context("actions")
# Helper functions --------------------------------------------------------
# Taken from https://github.com/harrelfe/Hmisc/blob/master/R/regexpEscape.s
escape_regex <- function(string) {
gsub("([.|()\\^{}+$*?]|\\[|\\])", "\\\\\\1", string)
}
# Input data --------------------------------------------------------------
mtcars_exposed <- mtcars %>% set_exposure(input_exposure_ref)
rule_breakers <- input_exposure_ref %>%
get_report() %>%
filter(!(value %in% TRUE))
trigger_nrow_30 <- function(.tbl) {
nrow(get_report(.tbl)) > 40
}
trigger_nrow_10 <- function(.tbl) {
nrow(get_report(.tbl)) > 10
}
actor_print <- function(.tbl) {
print(get_exposure(.tbl))
.tbl
}
assert_text <- "assert_any_breaker: Some breakers found in exposure."
exposure_no_breakers <- input_exposure_ref
exposure_no_breakers$packs_info <- exposure_no_breakers$packs_info %>%
slice(1) %>%
as_packs_info()
exposure_no_breakers$report <- exposure_no_breakers$report %>%
slice(c(1, 2, 5)) %>%
as_report()
mtcars_exposed_no_breakers <- set_exposure(mtcars, exposure_no_breakers)
# Custom expectations -----------------------------------------------------
expect_asserts <- function(input, type, silent = FALSE, result = input,
output_name = "Breakers report\n",
output_report,
warnings = character(0),
messages = character(0),
...) {
assert_evaluation <- evaluate_promise(
assert_any_breaker(input, type, silent, ...)
)
expect_identical(assert_evaluation$result, result)
expect_match(assert_evaluation$output, output_name)
expect_match(assert_evaluation$output, output_report)
expect_identical(assert_evaluation$warnings, warnings)
expect_identical(assert_evaluation$messages, messages)
}
# act_after_exposure ------------------------------------------------------
test_that("act_after_exposure works", {
expect_error(
act_after_exposure(mtcars, trigger_nrow_30, actor_print),
"act_after_exposure:.*not.*have"
)
input_bad <- mtcars
attr(input_bad, "exposure") <- "a"
expect_error(
act_after_exposure(input_bad, trigger_nrow_30, actor_print),
"act_after_exposure:.*not.*proper.*exposure"
)
expect_silent(
output_1 <- act_after_exposure(
mtcars_exposed, trigger_nrow_30,
actor_print
)
)
expect_identical(output_1, mtcars_exposed)
output_ref <- capture_output(print(input_exposure_ref))
expect_output(
output_2 <- act_after_exposure(
mtcars_exposed, trigger_nrow_10,
actor_print
),
output_ref,
fixed = TRUE
)
expect_identical(output_2, mtcars_exposed)
})
# assert_any_breaker ------------------------------------------------------
test_that("assert_any_breaker works", {
output_ref <- escape_regex(capture_output(print(rule_breakers)))
# Error assertions
expect_error(
expect_output(assert_any_breaker(mtcars_exposed), output_ref),
assert_text
)
expect_error(
expect_output(assert_any_breaker(mtcars_exposed, "error"), output_ref),
assert_text
)
expect_error(
expect_output(assert_any_breaker(mtcars_exposed, "error", TRUE), ""),
assert_text
)
# Warning and message assertions
expect_asserts(
mtcars_exposed,
"warning",
output_report = output_ref,
warnings = assert_text
)
expect_asserts(
mtcars_exposed,
"message",
output_report = output_ref,
messages = paste0(assert_text, "\n")
)
# Absence of printing
expect_asserts(
mtcars_exposed,
"warning",
silent = TRUE,
output_name = "",
output_report = "",
warnings = assert_text
)
expect_asserts(
mtcars_exposed,
"message",
silent = TRUE,
output_name = "",
output_report = "",
messages = paste0(assert_text, "\n")
)
# Absence of assertions
expect_asserts(
mtcars_exposed_no_breakers,
"error",
output_name = "",
output_report = ""
)
expect_asserts(
mtcars_exposed_no_breakers,
"warning",
output_name = "",
output_report = ""
)
expect_asserts(
mtcars_exposed_no_breakers,
"message",
output_name = "",
output_report = ""
)
})
test_that("assert_any_breaker accounts for printing options", {
output_ref <- escape_regex(capture_output(print(rule_breakers, n = 3)))
expect_error(
expect_output(
assert_any_breaker(mtcars_exposed, "error", n = 3),
output_ref
),
assert_text
)
expect_asserts(
mtcars_exposed,
"warning",
output_report = output_ref,
warnings = assert_text,
n = 3
)
expect_asserts(
mtcars_exposed,
"message",
output_report = output_ref,
messages = paste0(assert_text, "\n"),
n = 3
)
})
# any_breaker -------------------------------------------------------------
test_that("any_breaker works", {
expect_error(any_breaker("a"), "any_breaker:.*not.*proper.*exposure")
expect_true(any_breaker(input_exposure_ref))
expect_false(any_breaker(exposure_no_breakers))
})
# generate_breakers_informer ----------------------------------------------
test_that("generate_breakers_informer works", {
custom_assert_text <- "Custom"
informer <- generate_breakers_informer(
.fun = warning,
.message = custom_assert_text,
.silent = FALSE
)
expect_is(informer, "function")
output <- evaluate_promise(informer(.tbl = mtcars_exposed))
expect_identical(output$result, mtcars_exposed)
expect_match(
output$output,
escape_regex(capture_output(print(rule_breakers)))
)
expect_identical(output$warnings, custom_assert_text)
expect_identical(output$messages, character(0))
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.