Skip to content

Commit 3a00268

Browse files
dshemetovdshemetov
authored
Merge pull request #286 from cmu-delphi/ds/checks
refactor: use checkmate for arg validation
2 parents 69053c8 + f805c3b commit 3a00268

File tree

7 files changed

+78
-170
lines changed

7 files changed

+78
-170
lines changed

‎.github/workflows/R-CMD-check.yaml

+2-2
Original file line numberDiff line numberDiff line change
@@ -4,9 +4,9 @@
44
# Created with usethis + edited to use API key.
55
on:
66
push:
7-
branches: [main, master]
7+
branches: [main, dev]
88
pull_request:
9-
branches: [main, master]
9+
branches: [main, dev]
1010

1111
name: R-CMD-check
1212

‎DESCRIPTION

+2-1
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
Package: epipredict
22
Title: Basic epidemiology forecasting methods
3-
Version: 0.0.8
3+
Version: 0.0.9
44
Authors@R: c(
55
person("Daniel", "McDonald", , "[email protected]", role = c("aut", "cre")),
66
person("Ryan", "Tibshirani", , "[email protected]", role = "aut"),
@@ -27,6 +27,7 @@ Depends:
2727
parsnip (>= 1.0.0),
2828
R (>= 3.5.0)
2929
Imports:
30+
checkmate,
3031
cli,
3132
distributional,
3233
dplyr,

‎NAMESPACE

+11
Original file line numberDiff line numberDiff line change
@@ -195,6 +195,17 @@ import(distributional)
195195
import(epiprocess)
196196
import(parsnip)
197197
import(recipes)
198+
importFrom(checkmate,assert)
199+
importFrom(checkmate,assert_character)
200+
importFrom(checkmate,assert_date)
201+
importFrom(checkmate,assert_function)
202+
importFrom(checkmate,assert_int)
203+
importFrom(checkmate,assert_integer)
204+
importFrom(checkmate,assert_integerish)
205+
importFrom(checkmate,assert_logical)
206+
importFrom(checkmate,assert_number)
207+
importFrom(checkmate,assert_numeric)
208+
importFrom(checkmate,assert_scalar)
198209
importFrom(cli,cli_abort)
199210
importFrom(dplyr,across)
200211
importFrom(dplyr,all_of)

‎NEWS.md

+2-1
Original file line numberDiff line numberDiff line change
@@ -7,7 +7,7 @@ Pre-1.0.0 numbering scheme: 0.x will indicate releases, while 0.0.x will indicat
77
- add `check_enough_train_data` that will error if training data is too small
88
- added `check_enough_train_data` to `arx_forecaster`
99
- simplify `layer_residual_quantiles()` to avoid timesuck in `utils::methods()`
10-
- rename the `dist_quantiles()` to be more descriptive, breaking change)
10+
- rename the `dist_quantiles()` to be more descriptive, breaking change
1111
- removes previous `pivot_quantiles()` (now `*_wider()`, breaking change)
1212
- add `pivot_quantiles_wider()` for easier plotting
1313
- add complement `pivot_quantiles_longer()`
@@ -31,3 +31,4 @@ Pre-1.0.0 numbering scheme: 0.x will indicate releases, while 0.0.x will indicat
3131
- Publish public for easy navigation
3232
- Two simple forecasters as test beds
3333
- Working vignette
34+
- use `checkmate` for input validation

‎R/epipredict-package.R

+3
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,9 @@
44
#' @importFrom stats poly predict lm residuals quantile
55
#' @importFrom cli cli_abort
66
#' @importFrom lifecycle deprecated
7+
#' @importFrom checkmate assert assert_character assert_int assert_scalar
8+
#' assert_logical assert_numeric assert_number assert_integer
9+
#' assert_integerish assert_date assert_function
710
#' @import epiprocess parsnip
811
## usethis namespace: end
912
NULL

‎R/utils-arg.R

+53-154
Original file line numberDiff line numberDiff line change
@@ -2,204 +2,103 @@
22
# http://adv-r.had.co.nz/Computing-on-the-language.html#substitute
33
# Modeled after / copied from rundel/ghclass
44

5-
handle_arg_list <- function(..., tests) {
5+
handle_arg_list <- function(..., .tests) {
66
values <- list(...)
77
names <- eval(substitute(alist(...)))
88
names <- map(names, deparse)
99

10-
walk2(names, values, tests)
10+
walk2(names, values, .tests)
1111
}
1212

1313
arg_is_scalar <- function(..., allow_null = FALSE, allow_na = FALSE) {
14-
handle_arg_list(
15-
...,
16-
tests = function(name, value) {
17-
if (length(value) > 1 | (!allow_null & length(value) == 0)) {
18-
cli::cli_abort("Argument {.val {name}} must be of length 1.")
19-
}
20-
if (!is.null(value)) {
21-
if (is.na(value) & !allow_na) {
22-
cli::cli_abort(
23-
"Argument {.val {name}} must not be a missing value ({.val {NA}})."
24-
)
25-
}
26-
}
27-
}
28-
)
14+
handle_arg_list(..., .tests = function(name, value) {
15+
assert_scalar(value, null.ok = allow_null, na.ok = allow_na, .var.name = name)
16+
})
2917
}
3018

31-
3219
arg_is_lgl <- function(..., allow_null = FALSE, allow_na = FALSE, allow_empty = FALSE) {
33-
handle_arg_list(
34-
...,
35-
tests = function(name, value) {
36-
if (is.null(value) & !allow_null) {
37-
cli::cli_abort("Argument {.val {name}} must be of logical type.")
38-
}
39-
if (any(is.na(value)) & !allow_na) {
40-
cli::cli_abort("Argument {.val {name}} must not contain any missing values ({.val {NA}}).")
41-
}
42-
if (!is.null(value) & (length(value) == 0 & !allow_empty)) {
43-
cli::cli_abort("Argument {.val {name}} must have length >= 1.")
44-
}
45-
if (!is.null(value) & length(value) != 0 & !is.logical(value)) {
46-
cli::cli_abort("Argument {.val {name}} must be of logical type.")
47-
}
48-
}
49-
)
20+
handle_arg_list(..., .tests = function(name, value) {
21+
assert_logical(value, null.ok = allow_null, any.missing = allow_na, min.len = as.integer(!allow_empty), .var.name = name)
22+
})
5023
}
5124

5225
arg_is_lgl_scalar <- function(..., allow_null = FALSE, allow_na = FALSE) {
53-
arg_is_lgl(..., allow_null = allow_null, allow_na = allow_na)
54-
arg_is_scalar(..., allow_null = allow_null, allow_na = allow_na)
26+
handle_arg_list(..., .tests = function(name, value) {
27+
assert_logical(value, null.ok = allow_null, any.missing = allow_na, min.len = 1, max.len = 1, .var.name = name)
28+
})
5529
}
5630

5731
arg_is_numeric <- function(..., allow_null = FALSE) {
58-
handle_arg_list(
59-
...,
60-
tests = function(name, value) {
61-
if (!(is.numeric(value) | (is.null(value) & allow_null))) {
62-
cli::cli_abort("All {.val {name}} must numeric.")
63-
}
64-
}
65-
)
32+
handle_arg_list(..., .tests = function(name, value) {
33+
assert_numeric(value, null.ok = allow_null, any.missing = FALSE, .var.name = name)
34+
})
6635
}
6736

6837
arg_is_pos <- function(..., allow_null = FALSE) {
69-
arg_is_numeric(..., allow_null = allow_null)
70-
handle_arg_list(
71-
...,
72-
tests = function(name, value) {
73-
if (!(all(value > 0) | (is.null(value) & allow_null))) {
74-
cli::cli_abort("All {.val {name}} must be positive number(s).")
75-
}
76-
}
77-
)
38+
handle_arg_list(..., .tests = function(name, value) {
39+
assert_numeric(value, lower = 1, null.ok = allow_null, any.missing = FALSE, .var.name = name)
40+
})
7841
}
7942

8043
arg_is_nonneg <- function(..., allow_null = FALSE) {
81-
arg_is_numeric(..., allow_null = allow_null)
82-
handle_arg_list(
83-
...,
84-
tests = function(name, value) {
85-
if (!(all(value >= 0) | (is.null(value) & allow_null))) {
86-
cli::cli_abort("All {.val {name}} must be nonnegative number(s).")
87-
}
88-
}
89-
)
44+
handle_arg_list(..., .tests = function(name, value) {
45+
assert_numeric(value, lower = 0, null.ok = allow_null, any.missing = FALSE, .var.name = name)
46+
})
9047
}
9148

9249
arg_is_int <- function(..., allow_null = FALSE) {
93-
arg_is_numeric(..., allow_null = allow_null)
94-
handle_arg_list(
95-
...,
96-
tests = function(name, value) {
97-
if (!(all(value %% 1 == 0) | (is.null(value) & allow_null))) {
98-
cli::cli_abort("All {.val {name}} must be whole positive number(s).")
99-
}
100-
}
101-
)
50+
handle_arg_list(..., .tests = function(name, value) {
51+
assert_integerish(value, null.ok = allow_null, .var.name = name)
52+
})
10253
}
10354

10455
arg_is_pos_int <- function(..., allow_null = FALSE) {
105-
arg_is_int(..., allow_null = allow_null)
106-
arg_is_pos(..., allow_null = allow_null)
56+
handle_arg_list(..., .tests = function(name, value) {
57+
assert_integerish(value, null.ok = allow_null, lower = 1, any.missing = FALSE, .var.name = name)
58+
})
10759
}
10860

109-
11061
arg_is_nonneg_int <- function(..., allow_null = FALSE) {
111-
arg_is_int(..., allow_null = allow_null)
112-
arg_is_nonneg(..., allow_null = allow_null)
113-
}
114-
115-
arg_is_date <- function(..., allow_null = FALSE, allow_na = FALSE) {
116-
handle_arg_list(
117-
...,
118-
tests = function(name, value) {
119-
if (is.null(value) & !allow_null) {
120-
cli::cli_abort("Argument {.val {name}} may not be `NULL`.")
121-
}
122-
if (any(is.na(value)) & !allow_na) {
123-
cli::cli_abort("Argument {.val {name}} must not contain any missing values ({.val {NA}}).")
124-
}
125-
if (!(is(value, "Date") | is.null(value) | all(is.na(value)))) {
126-
cli::cli_abort("Argument {.val {name}} must be a Date. Try `as.Date()`.")
127-
}
128-
}
129-
)
130-
}
131-
132-
arg_is_probabilities <- function(..., allow_null = FALSE) {
133-
arg_is_numeric(..., allow_null = allow_null)
134-
handle_arg_list(
135-
...,
136-
tests = function(name, value) {
137-
if (!((all(value >= 0) && all(value <= 1)) | (is.null(value) & allow_null))) {
138-
cli::cli_abort("All {.val {name}} must be in [0,1].")
139-
}
140-
}
141-
)
62+
handle_arg_list(..., .tests = function(name, value) {
63+
assert_integerish(value, null.ok = allow_null, lower = 0, any.missing = FALSE, .var.name = name)
64+
})
14265
}
14366

144-
arg_is_chr <- function(..., allow_null = FALSE, allow_na = FALSE, allow_empty = FALSE) {
145-
handle_arg_list(
146-
...,
147-
tests = function(name, value) {
148-
if (is.null(value) & !allow_null) {
149-
cli::cli_abort("Argument {.val {name}} may not be `NULL`.")
150-
}
151-
if (any(is.na(value)) & !allow_na) {
152-
cli::cli_abort("Argument {.val {name}} must not contain any missing values ({.val {NA}}).")
153-
}
154-
if (!is.null(value) & (length(value) == 0L & !allow_empty)) {
155-
cli::cli_abort("Argument {.val {name}} must have length > 0.")
156-
}
157-
if (!(is.character(value) | is.null(value) | all(is.na(value)))) {
158-
cli::cli_abort("Argument {.val {name}} must be of character type.")
159-
}
160-
}
161-
)
67+
arg_is_date <- function(..., allow_null = FALSE) {
68+
handle_arg_list(..., .tests = function(name, value) {
69+
assert_date(value, null.ok = allow_null, .var.name = name)
70+
})
16271
}
16372

164-
arg_is_chr_scalar <- function(..., allow_null = FALSE, allow_na = FALSE) {
165-
arg_is_chr(..., allow_null = allow_null, allow_na = allow_na)
166-
arg_is_scalar(..., allow_null = allow_null, allow_na = allow_na)
73+
arg_is_probabilities <- function(..., allow_null = FALSE, allow_na = FALSE) {
74+
handle_arg_list(..., .tests = function(name, value) {
75+
assert_numeric(value, lower = 0, upper = 1, null.ok = allow_null, any.missing = allow_na, .var.name = name)
76+
})
16777
}
16878

169-
170-
arg_is_function <- function(..., allow_null = FALSE) {
171-
handle_arg_list(
172-
...,
173-
tests = function(name, value) {
174-
if (is.null(value) & !allow_null) {
175-
cli::cli_abort("Argument {.val {name}} must be a function.")
176-
}
177-
if (!is.null(value) & !is.function(value)) {
178-
cli::cli_abort("Argument {.val {name}} must be a function.")
179-
}
180-
}
181-
)
79+
arg_is_chr <- function(..., allow_null = FALSE, allow_na = FALSE, allow_empty = FALSE) {
80+
handle_arg_list(..., .tests = function(name, value) {
81+
assert_character(value, null.ok = allow_null, any.missing = allow_na, min.len = as.integer(!allow_empty), .var.name = name)
82+
})
18283
}
18384

184-
185-
186-
arg_is_sorted <- function(..., allow_null = FALSE) {
187-
handle_arg_list(
188-
...,
189-
tests = function(name, value) {
190-
if (is.unsorted(value, na.rm = TRUE) | (is.null(value) & !allow_null)) {
191-
cli::cli_abort("{.val {name}} must be sorted in increasing order.")
192-
}
193-
}
194-
)
85+
arg_is_chr_scalar <- function(..., allow_null = FALSE, allow_na = FALSE) {
86+
handle_arg_list(..., .tests = function(name, value) {
87+
assert_character(value, null.ok = allow_null, any.missing = allow_na, min.len = 1, max.len = 1, .var.name = name)
88+
})
19589
}
19690

91+
arg_is_function <- function(..., allow_null = FALSE) {
92+
handle_arg_list(..., .tests = function(name, value) {
93+
assert_function(value, null.ok = allow_null, .var.name = name)
94+
})
95+
}
19796

198-
arg_to_date <- function(x, allow_null = FALSE, allow_na = FALSE) {
199-
arg_is_scalar(x, allow_null = allow_null, allow_na = allow_na)
97+
arg_to_date <- function(x, allow_null = FALSE) {
98+
arg_is_scalar(x, allow_null = allow_null)
20099
if (!is.null(x)) {
201100
x <- tryCatch(as.Date(x, origin = "1970-01-01"), error = function(e) NA)
202101
}
203-
arg_is_date(x, allow_null = allow_null, allow_na = allow_na)
102+
arg_is_date(x, allow_null = allow_null)
204103
x
205104
}

‎tests/testthat/test-arg_is_.R

+5-12
Original file line numberDiff line numberDiff line change
@@ -44,7 +44,7 @@ test_that("scalar", {
4444
test_that("numeric", {
4545
expect_silent(arg_is_numeric(i, j, x, y))
4646
expect_error(arg_is_numeric(a))
47-
expect_error(arg_is_numeric(d))
47+
expect_silent(arg_is_numeric(d))
4848
expect_silent(arg_is_numeric(c(i, j)))
4949
expect_silent(arg_is_numeric(i, k))
5050
expect_silent(arg_is_numeric(i, j, n, allow_null = TRUE))
@@ -56,7 +56,7 @@ test_that("numeric", {
5656
test_that("positive", {
5757
expect_silent(arg_is_pos(i, j, x, y))
5858
expect_error(arg_is_pos(a))
59-
expect_error(arg_is_pos(d))
59+
expect_silent(arg_is_pos(d))
6060
expect_silent(arg_is_pos(c(i, j)))
6161
expect_error(arg_is_pos(i, k))
6262
expect_silent(arg_is_pos(i, j, n, allow_null = TRUE))
@@ -68,7 +68,7 @@ test_that("positive", {
6868
test_that("nonneg", {
6969
expect_silent(arg_is_nonneg(i, j, x, y))
7070
expect_error(arg_is_nonneg(a))
71-
expect_error(arg_is_nonneg(d))
71+
expect_silent(arg_is_nonneg(d))
7272
expect_silent(arg_is_nonneg(c(i, j)))
7373
expect_error(arg_is_nonneg(i, k))
7474
expect_silent(arg_is_nonneg(i, j, n, allow_null = TRUE))
@@ -96,7 +96,8 @@ test_that("date", {
9696
expect_error(arg_is_date(d, dd, n))
9797
expect_error(arg_is_date(d, dd, nn))
9898
expect_silent(arg_is_date(d, dd, n, allow_null = TRUE))
99-
expect_silent(arg_is_date(d, dd, nn, allow_na = TRUE))
99+
# Upstream issue, see: https://github.com/mllg/checkmate/issues/256
100+
# expect_silent(arg_is_date(d, dd, nn, allow_na = TRUE))
100101
expect_error(arg_is_date(a))
101102
expect_error(arg_is_date(v))
102103
expect_error(arg_is_date(ll))
@@ -136,14 +137,6 @@ test_that("function", {
136137
expect_silent(arg_is_function(g, f = NULL, allow_null = TRUE))
137138
})
138139

139-
test_that("sorted", {
140-
expect_silent(arg_is_sorted(a = 1:5, b = 6:10))
141-
expect_error(arg_is_sorted(a = 5:1, b = 6:10))
142-
expect_error(arg_is_sorted(b = NULL))
143-
expect_silent(arg_is_sorted(b = NULL, allow_null = TRUE))
144-
})
145-
146-
147140
test_that("coerce scalar to date", {
148141
expect_error(arg_to_date("12345"))
149142
expect_s3_class(arg_to_date(12345), "Date")

0 commit comments

Comments
 (0)