/
AllClasses.R
60 lines (60 loc) · 1.65 KB
/
AllClasses.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
#' goalie logical assert check return
#'
#' Contains a `logical` with `cause` attributes.
#'
#' @export
#' @note Updated 2023-10-02.
#'
#' @return `goalie`.
setClass(
Class = "goalie",
contains = "logical",
slots = list("cause" = "character")
)
setValidity(
Class = "goalie",
method = function(object) {
if (anyNA(object)) {
return("Object contains NA.")
}
if (!is.null(names(object))) {
return("Object is named.")
}
cause <- slot(object, name = "cause")
if (!is.character(cause)) {
return("Cause attribute is not character.")
}
if (!is.null(names(cause))) {
return("Cause attribute is named.")
}
if (!identical(length(object), length(cause))) {
return("Cause attribute not the same length as check return.")
}
if (any(object)) {
ok <- vapply(
X = cause[which(object == TRUE)],
FUN = identical,
y = NA_character_,
FUN.VALUE = logical(1L),
USE.NAMES = FALSE
)
if (!all(ok)) {
return("TRUE values must have NA cause.")
}
}
ok <- vapply(
X = cause[which(object == FALSE)],
FUN = function(x) {
isTRUE(nzchar(x)) || return(FALSE)
isFALSE(is.na(x)) || return(FALSE)
TRUE
},
FUN.VALUE = logical(1L),
USE.NAMES = FALSE
)
if (!all(ok)) {
return("FALSE values must have non-empty character cause.")
}
TRUE
}
)