Skip to content

Commit

Permalink
Update test suite
Browse files Browse the repository at this point in the history
  • Loading branch information
@danielvartan
danielvartan committed May 31, 2021
1 parent 019dc14 commit f0f9aaa
Show file tree
Hide file tree
Showing 42 changed files with 2,269 additions and 2,220 deletions.
18 changes: 9 additions & 9 deletions R/convert.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -432,7 +432,7 @@ convert.Duration <- function(x, class, ..., tz = "UTC", output_unit = NULL,
class <- tolower(class)

if (class == "logical") {
shush(warning("'x' cannot be converted to 'logical'",
shush(warning("'x' cannot be converted to 'logical'.",
call. = FALSE), quiet)
as.logical(rep(NA, length(x)))
} else if (class == "character") {
Expand Down Expand Up @@ -510,7 +510,7 @@ convert.hms <- function(x, class, ..., tz = "UTC", output_unit = NULL,
class <- tolower(class)

if (class == "logical") {
shush(warning("'x' cannot be converted to 'logical'",
shush(warning("'x' cannot be converted to 'logical'.",
call. = FALSE), quiet)
as.logical(rep(NA, length(x)))
} else if (class == "character") {
Expand Down Expand Up @@ -571,7 +571,7 @@ convert.Date <- function(x, class, ..., tz = "UTC", quiet = FALSE) {
}

if (class == "logical") {
shush(warning("'x' cannot be converted to 'logical'",
shush(warning("'x' cannot be converted to 'logical'.",
call. = FALSE), quiet)
as.logical(rep(NA, length(x)))
} else if (class == "character") {
Expand Down Expand Up @@ -624,7 +624,7 @@ convert.POSIXt <- function(x, class, ..., tz = "UTC", output_unit = NULL,
}

if (class == "logical") {
shush(warning("'x' cannot be converted to 'logical'",
shush(warning("'x' cannot be converted to 'logical'.",
call. = FALSE), quiet)
as.logical(rep(NA, length(x)))
} else if (class == "character") {
Expand Down Expand Up @@ -683,13 +683,13 @@ convert.Interval <- function(x, class, ..., tz = "UTC", output_unit = NULL,
}

if (class %in% c("posixct", "posixlt")) {
shush(warning("'x' was converted to the interval time span with",
shush(warning("'x' was converted to the interval time span with ",
"'1970-01-01 as origin (UNIX epoch).",
call. = FALSE), quiet)
}

if (class == "logical") {
shush(warning("'x' cannot be converted to 'logical'",
shush(warning("'x' cannot be converted to 'logical'.",
call. = FALSE), quiet)
as.logical(rep(NA, length(x)))
} else if (class == "character") {
Expand Down Expand Up @@ -774,7 +774,7 @@ convert.data.frame <- function(x, class, ..., cols = NULL, where = NULL,
#' @rdname convert
#' @export
convert_tu <- function(x, output_unit, ...) {
assert_time(x)
assert_temporal(x)

convert(x, class = "numeric", output_unit = output_unit, ... = ...)
}
Expand Down Expand Up @@ -1042,7 +1042,7 @@ convert_to_seconds <- function(x, input_unit = NULL,
checkmate::assert_flag(ignore_date)
checkmate::assert_flag(quiet)

if (!is_time(x) && is.null(input_unit)) {
if (!test_temporal(x) && is.null(input_unit)) {
stop("When 'x' is 'integer' or 'numeric', 'input_unit' cannot be ",
"'NULL'.", call. = FALSE)
}
Expand Down Expand Up @@ -1072,7 +1072,7 @@ convert_to_seconds <- function(x, input_unit = NULL,
} else if (input_unit == "deg") {
x / deg_second
}
} else if (is_time(x)) {
} else if (test_temporal(x)) {
if (lubridate::is.duration(x) || lubridate::is.period(x) ||
hms::is_hms(x) || lubridate::is.interval(x)) {
as.numeric(x)
Expand Down
4 changes: 2 additions & 2 deletions R/qplot_walk.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -146,7 +146,7 @@ qplot_walk <- function(data, ..., cols = NULL, pattern = NULL,

if (any(c("x", "y", "data") %in% names(list(...)))) {
stop("'x', 'y' and `data` are reserved arguments for ",
"`qplot_walk()`.", call. = FALSE)
"'qplot_walk()'.", call. = FALSE)
}

if (is.data.frame(data)) {
Expand Down Expand Up @@ -207,7 +207,7 @@ qplot_walk <- function(data, ..., cols = NULL, pattern = NULL,
cols <- grep(pattern, names(data), value = TRUE)

if (length(cols) == 0) {
stop("None match was found in `names(data)`.", call. = FALSE)
stop("None match was found in 'names(data)'.", call. = FALSE)
}
}

Expand Down
162 changes: 117 additions & 45 deletions R/utils-checks.R
View file
Original file line number Diff line number Diff line change
@@ -1,30 +1,7 @@
check_any_na <- function(x, name = deparse(substitute(x))) {
if (any(is.na(x))) {
paste0(single_quote_(name), " cannot have any missing values")
} else {
TRUE
}
}

assert_any_na <- checkmate::makeAssertionFunction(check_any_na)

check_not_all_na <- function(x, name = deparse(substitute(x))) {
if (all(is.na(x))) {
paste0(single_quote_(name), " cannot have all values as missing")
} else {
TRUE
}
}

assert_not_all_na <- checkmate::makeAssertionFunction(check_not_all_na)
test_length_one <- function(x) if (length(x) == 1) TRUE else FALSE

check_length_one <- function(x, any.missing = TRUE,
name = deparse(substitute(x))) {
checkmate::assert_flag(any.missing)

if (any(is.na(x)) && isFALSE(any.missing)) {
paste0(single_quote_(name), " cannot have missing values")
} else if (!(length(x) == 1)) {
check_length_one <- function(x, name = deparse(substitute(x))) {
if (!(test_length_one(x))) {
paste0(single_quote_(name), " must have length 1, not length ",
length(x))
} else {
Expand All @@ -34,13 +11,15 @@ check_length_one <- function(x, any.missing = TRUE,

assert_length_one <- checkmate::makeAssertionFunction(check_length_one)

test_has_length <- function(x) if (length(x) >= 1) TRUE else FALSE

check_has_length <- function(x, any.missing = TRUE,
name = deparse(substitute(x))) {
checkmate::assert_flag(any.missing)

if (any(is.na(x)) && isFALSE(any.missing)) {
paste0(single_quote_(name), " cannot have missing values")
} else if (length(x) < 1) {
} else if (!test_has_length(x)) {
paste0(single_quote_(name), " must have length greater than zero")
} else {
TRUE
Expand All @@ -49,6 +28,23 @@ check_has_length <- function(x, any.missing = TRUE,

assert_has_length <- checkmate::makeAssertionFunction(check_has_length)

test_whole_number <- function(x, any.missing = TRUE, null.ok = FALSE,
tol = .Machine$double.eps^0.5) {
checkmate::assert_flag(any.missing)
checkmate::assert_flag(null.ok)
checkmate::assert_number(tol)

if (is.null(x) && isTRUE(null.ok)) {
TRUE
} else if (any(is.na(x)) && isFALSE(any.missing)) {
FALSE
} else if (!test_numeric_(x) || !identical(x, abs(x))) {
FALSE
} else {
all(abs(x - round(x)) < tol, na.rm = any.missing)
}
}

check_whole_number <- function(x, any.missing = TRUE, null.ok = FALSE,
name = deparse(substitute(x))) {
checkmate::assert_flag(any.missing)
Expand All @@ -59,8 +55,9 @@ check_whole_number <- function(x, any.missing = TRUE, null.ok = FALSE,
} else if (any(is.na(x)) && isFALSE(any.missing)) {
paste0(single_quote_(name), " cannot have missing values")
} else if (is.null(x) && isFALSE(null.ok)) {
paste0(single_quote_(name), " cannot be 'NULL'")
} else if (!all(is_whole_number(x), na.rm = TRUE)) {
paste0(single_quote_(name), " cannot have 'NULL' values")
} else if (!test_whole_number(x, any.missing = any.missing,
null.ok = null.ok)) {
paste0(single_quote_(name), " must consist of whole numbers")
} else {
TRUE
Expand All @@ -69,10 +66,24 @@ check_whole_number <- function(x, any.missing = TRUE, null.ok = FALSE,

assert_whole_number <- checkmate::makeAssertionFunction(check_whole_number)

## `check_numeric_()` and `assert_numeric_()` were created as a workaround to
## deal with cases like `is.numeric(lubridate::duration())`. See
## `*_numeric_()` was created as a workaround to deal with cases like
## `is.numeric(lubridate::duration())`. See
## https://github.com/tidyverse/lubridate/issues/942 to learn more.

test_numeric_ <- function(x, any.missing = TRUE, null.ok = FALSE) {
checkmate::assert_flag(any.missing)
checkmate::assert_flag(null.ok)

if (is.null(x) && isTRUE(null.ok)) {
TRUE
} else if (any(is.na(x)) && isFALSE(any.missing)) {
FALSE
} else {
classes <- c("integer", "double", "numeric")
checkmate::test_subset(class(x)[1], classes)
}
}

check_numeric_ <- function(x, any.missing = TRUE, null.ok = FALSE,
name = deparse(substitute(x))) {
checkmate::assert_flag(any.missing)
Expand All @@ -84,7 +95,7 @@ check_numeric_ <- function(x, any.missing = TRUE, null.ok = FALSE,
paste0(single_quote_(name), " cannot have missing values")
} else if (is.null(x) && isFALSE(null.ok)) {
paste0(single_quote_(name), " cannot have 'NULL' values")
} else if (!is_numeric_(x)) {
} else if (!test_numeric_(x)) {
paste0("Must be of type 'numeric', not ", class_collapse(x))
} else {
TRUE
Expand All @@ -93,6 +104,19 @@ check_numeric_ <- function(x, any.missing = TRUE, null.ok = FALSE,

assert_numeric_ <- checkmate::makeAssertionFunction(check_numeric_)

test_duration <- function(x, any.missing = TRUE, null.ok = FALSE) {
checkmate::assert_flag(any.missing)
checkmate::assert_flag(null.ok)

if (is.null(x) && isTRUE(null.ok)) {
TRUE
} else if (any(is.na(x)) && isFALSE(any.missing)) {
FALSE
} else {
lubridate::is.duration(x)
}
}

check_duration <- function(x, any.missing = TRUE, null.ok = FALSE,
name = deparse(substitute(x))) {
checkmate::assert_flag(any.missing)
Expand All @@ -104,7 +128,7 @@ check_duration <- function(x, any.missing = TRUE, null.ok = FALSE,
paste0(single_quote_(name), " cannot have missing values")
} else if (is.null(x) && isFALSE(null.ok)) {
paste0(single_quote_(name), " cannot have 'NULL' values")
} else if (!lubridate::is.duration(x)) {
} else if (!test_duration(x)) {
paste0("Must be of type 'Duration', not ", class_collapse(x))
} else {
TRUE
Expand All @@ -113,6 +137,19 @@ check_duration <- function(x, any.missing = TRUE, null.ok = FALSE,

assert_duration <- checkmate::makeAssertionFunction(check_duration)

test_posixt <- function(x, any.missing = TRUE, null.ok = FALSE) {
checkmate::assert_flag(any.missing)
checkmate::assert_flag(null.ok)

if (is.null(x) && isTRUE(null.ok)) {
TRUE
} else if (any(is.na(x)) && isFALSE(any.missing)) {
FALSE
} else {
lubridate::is.POSIXt(x)
}
}

check_posixt <- function(x, any.missing = TRUE, null.ok = FALSE,
name = deparse(substitute(x))) {
checkmate::assert_flag(any.missing)
Expand All @@ -124,7 +161,7 @@ check_posixt <- function(x, any.missing = TRUE, null.ok = FALSE,
paste0(single_quote_(name), " cannot have missing values")
} else if (is.null(x) && isFALSE(null.ok)) {
paste0(single_quote_(name), " cannot have 'NULL' values")
} else if (!lubridate::is.POSIXt(x)) {
} else if (!test_posixt(x)) {
paste0("Must be of type 'POSIXct' or 'POSIXlt', not ",
class_collapse(x))
} else {
Expand All @@ -134,12 +171,29 @@ check_posixt <- function(x, any.missing = TRUE, null.ok = FALSE,

assert_posixt <- checkmate::makeAssertionFunction(check_posixt)

test_time <- function(x, any.missing = TRUE, null.ok = FALSE) {
out <- check_time(x, any.missing, null.ok)
if (isTRUE(out)) TRUE else FALSE
test_temporal <- function(x, any.missing = TRUE, null.ok = FALSE, rm = NULL) {
checkmate::assert_flag(any.missing)
checkmate::assert_flag(null.ok)
checkmate::assert_character(rm, any.missing = FALSE, null.ok = TRUE)

if (is.null(x) && isTRUE(null.ok)) {
TRUE
} else if (any(is.na(x)) && isFALSE(any.missing)) {
FALSE
} else {
classes <- c("Duration", "Period", "difftime", "hms", "Date", "POSIXct",
"POSIXlt", "Interval")

if (!is.null(rm)) {
rm <- paste0("^", rm, "$", collapse = "|")
classes <- str_subset_(classes, rm, negate = TRUE)
}

checkmate::test_subset(class(x)[1], classes)
}
}

check_time <- function(x, any.missing = TRUE, null.ok = FALSE,
check_temporal <- function(x, any.missing = TRUE, null.ok = FALSE,
name = deparse(substitute(x))) {
checkmate::assert_flag(any.missing)
checkmate::assert_flag(null.ok)
Expand All @@ -150,18 +204,23 @@ check_time <- function(x, any.missing = TRUE, null.ok = FALSE,
paste0(single_quote_(name), " cannot have missing values")
} else if (is.null(x) && isFALSE(null.ok)) {
paste0(single_quote_(name), " cannot have 'NULL' values")
} else if (!is_time(x)) {
paste0("Must be a time object, not ", class_collapse(x))
} else if (!test_temporal(x)) {
paste0("Must be a temporal object (see 'test_temporal()'), ",
"not ", class_collapse(x))
} else {
TRUE
}
}

assert_time <- checkmate::makeAssertionFunction(check_time)
assert_temporal <- checkmate::makeAssertionFunction(check_temporal)

assert_identical <- function(..., type = "value", any.missing = TRUE,
null.ok = FALSE) {
checkmate::assert_list(list(...), min.len = 2)

if (!checkmate::test_list(list(...), min.len = 2)) {
stop("'...' must have 2 or more elements.", call. = FALSE)
}

checkmate::assert_choice(type, c("value", "length", "class"))
checkmate::assert_flag(any.missing)
checkmate::assert_flag(null.ok)
Expand Down Expand Up @@ -198,7 +257,21 @@ assert_identical <- function(..., type = "value", any.missing = TRUE,
}
}

# Used in parse_to_date_time()
## `*_custom_1()` are used in `parse_to_date_time()`.

test_custom_1 <- function(x, any.missing = TRUE, null.ok = FALSE) {
checkmate::assert_flag(any.missing)
checkmate::assert_flag(null.ok)

if (is.null(x) && isTRUE(null.ok)) {
TRUE
} else if (any(is.na(x)) && isFALSE(any.missing)) {
FALSE
} else {
is.character(x) || test_numeric_(x)
}
}

check_custom_1 <- function(x, any.missing = TRUE, null.ok = FALSE,
name = deparse(substitute(x))) {
checkmate::assert_flag(any.missing)
Expand All @@ -210,13 +283,12 @@ check_custom_1 <- function(x, any.missing = TRUE, null.ok = FALSE,
paste0(single_quote_(name), " cannot have missing values")
} else if (is.null(x) && isFALSE(null.ok)) {
paste0(single_quote_(name), " cannot have 'NULL' values")
} else if (!(is.character(x) || is_numeric_(x))) {
} else if (!test_custom_1(x)) {
paste0(single_quote_(name), " must inherit from class 'character', ",
"'integer', or 'numeric', but has class ", class_collapse(x))
} else {
TRUE
}
}

# Used in parse_to_date_time()
assert_custom_1 <- checkmate::makeAssertionFunction(check_custom_1)

0 comments on commit f0f9aaa

Please sign in to comment.