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
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
|
#' @rdname are_set_equal
#' @export
are_disjoint_sets <- function(x, y, .xname = get_name_in_parent(x), .yname = get_name_in_parent(y))
{
intersectionxy <- intersect(x, y)
if(length(intersectionxy) > 0)
{
return(
false(
gettext(
"%s and %s have common elements: %s."
),
.xname,
.yname,
toString(intersectionxy, width = 100)
)
)
}
TRUE
}
#' @rdname are_set_equal
#' @export
are_intersecting_sets <- function(x, y, .xname = get_name_in_parent(x), .yname = get_name_in_parent(y))
{
intersectionxy <- intersect(x, y)
if(length(intersectionxy) == 0)
{
return(
false(
gettext(
"%s and %s have no common elements."
),
.xname,
.yname
)
)
}
TRUE
}
#' Set comparisons
#'
#' Checks on the contents of two vectors (ignoring the order of the elements).
#' @param x A vector.
#' @param y Another vector.
#' @param strictly Logical. If \code{TRUE}, \code{x} and \code{y} should not
#' be set equal.
#' @param .xname Not intended to be used directly.
#' @param .yname Not intended to be used directly.
#' @param severity How severe should the consequences of the assertion be?
#' Either \code{"stop"}, \code{"warning"}, \code{"message"}, or \code{"none"}.
#' @return The \code{is_*} functions return \code{TRUE} or \code{FALSE}.
#' The \code{assert_*} functions throw an error in the event of failure.
#' @seealso \code{\link[base]{sets}}, \code{\link[sets]{set_is_equal}}
#' @examples
#' # Same contents, different order, returns TRUE
#' are_set_equal(1:5, 5:1)
#'
#' # Different lengths
#' are_set_equal(1:5, 1:6)
#'
#' # First vector contains values not in second vector
#' are_set_equal(1:5, c(1:4, 4))
#'
#' # Second vector contains values not in first vector
#' are_set_equal(c(1:4, 4), 1:5)
#'
#' # Is x a subset of y?
#' is_subset(1:4, 1:5)
#' is_subset(1:5, 1:4)
#'
#' # Is x a superset of y?
#' is_superset(1:5, 1:4)
#' is_superset(1:4, 1:5)
#'
#' # The strictly argument checks for a strict sub/superset
#' is_subset(1:5, 1:5, strictly = TRUE)
#' is_superset(1:5, 1:5, strictly = TRUE)
#'
#' # Do x and y have common elements?
#' are_intersecting_sets(1:4, 3:6)
#' are_disjoint_sets(1:4, 3:6)
#'
#' # Types are coerced to be the same, as per base::setdiff
#' are_set_equal(1:4, c("4", "3", "2", "1"))
#'
#' # Errors are thrown in the event of failure
#' assert_are_set_equal(1:5, 5:1)
#' assertive.base::dont_stop(assert_are_set_equal(1:5, 1:6))
#'
#' assert_is_subset(1:4, 1:5)
#' assertive.base::dont_stop(assert_is_subset(1:5, 1:4))
#'
#' assert_is_superset(1:5, 1:4)
#' assertive.base::dont_stop(assert_is_superset(1:4, 1:5))
#'
#' # A common use case: checking that data contains required columns
#' required_cols <- c("Time", "weight", "Diet")
#' assert_is_superset(colnames(ChickWeight), required_cols)
#' @export
are_set_equal <- function(x, y, .xname = get_name_in_parent(x), .yname = get_name_in_parent(y))
{
x <- unique(x)
y <- unique(y)
if(length(x) != length(y))
{
return(
false(
gettext(
"%s and %s have different numbers of elements (%d versus %d)."
),
.xname,
.yname,
length(x),
length(y)
)
)
}
if(!(ok <- is_subset(x, y, FALSE, .xname, .yname)))
{
return(ok)
}
if(!(ok <- is_subset(y, x, FALSE, .yname, .xname)))
{
return(ok)
}
TRUE
}
#' @rdname are_set_equal
#' @export
is_set_equal <- function(x, y, .xname = get_name_in_parent(x), .yname = get_name_in_parent(y))
{
.Deprecated("are_set_equal")
are_set_equal(x, y, .xname, .yname)
}
#' @rdname are_set_equal
#' @export
is_subset <- function(x, y, strictly = FALSE, .xname = get_name_in_parent(x), .yname = get_name_in_parent(y))
{
diffxy <- setdiff(x, y)
if(length(diffxy) > 0)
{
return(
false(
ngettext(
length(diffxy),
"The element %s in %s is not in %s.",
"The elements %s in %s are not in %s."
),
toString(sQuote(diffxy), width = 100),
.xname,
.yname
)
)
}
if(strictly && length(setdiff(y, x)) == 0)
{
return(false("%s and %s are set equal.", .xname, .yname))
}
TRUE
}
#' @rdname are_set_equal
#' @export
is_superset <- function(x, y, strictly = FALSE, .xname = get_name_in_parent(x), .yname = get_name_in_parent(y))
{
is_subset(y, x, strictly, .yname, .xname)
}
|
