-
Notifications
You must be signed in to change notification settings - Fork 4
/
class-projects_stage.R
executable file
·298 lines (242 loc) · 8.3 KB
/
class-projects_stage.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
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
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
#' \code{projects_stage} vector
#'
#' Objects of this class are merely a character string containing a number and a
#' name of one of seven project development stages.
#'
#' A \code{projects_stage} object is either a missing value (\code{NA}) or one
#' of:
#'
#' \code{0: idea}\cr \code{1: design}\cr \code{2: data collection}\cr \code{3:
#' analysis}\cr \code{4: manuscript}\cr \code{5: under review}\cr \code{6:
#' accepted}
#'
#' \code{projects_stage()} validates and coerces a vector of the above integers or strings to a \code{projects_stage} S3 vector.
#'
#' @section Numeric coercion methods: \code{\link{as.integer}()},
#' \code{\link{as.double}()}, and \code{\link{as.numeric}()} return the stage
#' number of the \code{projects_stage} object as an integer/double. The
#' methods for the comparison and value matching functions described below
#' make use of these numeric coercion methods. Users desiring to apply value
#' matching functions other than the ones described below may similarly take
#' advantage of these.
#'
#' @section Comparison and value matching methods: Methods for the
#' \link{Comparison} operators as well as \code{\link{match}()} and
#' \code{\link{\%in\%}} enable users to test equality and to value match among
#' \code{projects_stage} objects and as well as between \code{projects_stage}
#' objects and unclassed numbers/characters. When comparing or value matching
#' against a numeric vector, the \code{projects_stage} object is first coerced
#' to an integer with the \code{as.integer()} method described above. When
#' testing or value matching against a character vector, the character vector
#' is validated against the list of project stages enumerated above.
#'
#' @param x For \code{projects_stage()}, an integer or character vector. For
#'
#' For \code{\link{match}()} and \code{\link{\%in\%}}, an integer, a character
#' string, or a \code{projects_stage} object. See \code{\link{match}()} and
#' \strong{Comparison and value matching methods} below.
#'
#' @param table An integer number, a character string, or a
#' \code{projects_stage} object. See \code{\link{match}()} and
#' \strong{Comparison and value matching methods} below.
#'
#' @param nomatch See \code{\link{match}()}.
#'
#' @param incomparables An integer number, a character string, or a
#' \code{projects_stage} object. See \code{\link{match}()}.
#'
#' @return For \code{projects_stage()}, an S3 vector of class
#' \code{projects_stage}.
#'
#' @seealso \code{\link{Ops}}; \code{\link[methods]{Methods_for_Nongenerics}}.
#'
#' @examples
#' stage <- projects_stage("4: manuscript")
#'
#' as.integer(stage) # 4
#'
#' stage == 4 # TRUE
#' stage != 4 # FALSE
#' stage < 6 # TRUE
#'
#' stage %in% c(3:6) # TRUE
#' match(stage, 0:4) # 5
#'
#' stage %in% c("design", "manusc", "idea") # TRUE
#'
#' more_stages <- projects_stage(c("0: idea", "4: manuscript", "1: design"))
#'
#' match("MAnuscRIPT", more_stages) # 2
#' @export
projects_stage <- function(x = character()) {
x <- vec_cast(x, character())
validate_stage(x)
}
new_projects_stage <- function(x = character()) {
vec_assert(x, character())
new_vctr(x, class = "projects_stage")
}
#' @rdname projects_stage
#' @export
methods::setClass("projects_stage")
#' @export
vec_ptype_abbr.projects_stage <- function(x, ...) "prjstg"
validate_stage <- function(stage, na.ok = TRUE, null.ok = FALSE, n = NULL) {
if (is.null(stage) && null.ok) {
return(NULL)
}
choices <- eval(formals(new_project)$stage)
stage <- trimws(tolower(as.character(stage)))
if (!rlang::is_atomic(stage) || !is.null(n) && length(stage) != n) {
stop("\nstage must be coercible to a character vector of length ", n)
}
stage <-
vapply(
stage,
function(stage) {
if (is.na(stage)) {
if (!na.ok) {
stop("stage must not be missing (NA)")
}
} else {
match_attempt <- pmatch(stage, choices)
if (is.na(match_attempt)) {
match_attempt <- pmatch(stage, substr(choices, 4L, nchar(choices)))
if (is.na(match_attempt)) {
stop(
"\nTo match a stage, user input must either:\n\n",
"- exactly match the integer\n",
"- partially match the text\n\n",
"of one of:\n",
paste(choices, collapse = "\n"),
"\n\n'", stage, "' did not match."
)
}
}
stage <- choices[match_attempt]
}
},
FUN.VALUE = character(1L),
USE.NAMES = FALSE
)
new_projects_stage(stage)
}
#' @rdname projects_stage-vctrs
#' @method vec_ptype2 projects_stage
#' @export
#' @export vec_ptype2.projects_stage
vec_ptype2.projects_stage <- function(x, y, ...)
UseMethod("vec_ptype2.projects_stage", y)
#' @method vec_ptype2.projects_stage default
#' @export
vec_ptype2.projects_stage.default <- function(x, y, ...,
x_arg = "x", y_arg = "y")
vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg)
#' @method vec_ptype2.projects_stage projects_stage
#' @export
vec_ptype2.projects_stage.projects_stage <- function(x, y, ...)
new_projects_stage()
#' @method vec_ptype2.projects_stage character
#' @export
vec_ptype2.projects_stage.character <- function(x, y, ...) character()
#' @method vec_ptype2.character projects_stage
#' @export
vec_ptype2.character.projects_stage <- function(x, y, ...) character()
#' @method vec_cast projects_stage
#' @export vec_cast.projects_stage
#' @export
#' @rdname projects_stage-vctrs
vec_cast.projects_stage <- function(x, to, ...)
UseMethod("vec_cast.projects_stage")
#' @method vec_cast.projects_stage default
#' @export
vec_cast.projects_stage.default <- function(x, to, ...)
vec_default_cast(x, to)
#' @method vec_cast.projects_stage projects_stage
#' @export
vec_cast.projects_stage.projects_stage <- function(x, to, ...) x
#' @method vec_cast.projects_stage character
#' @export
vec_cast.projects_stage.character <- function(x, to, ...) validate_stage(x)
#' @method vec_cast.character projects_stage
#' @export
vec_cast.character.projects_stage <- function(x, to, ...) vec_data(x)
#' @method vec_cast.projects_stage integer
#' @export
vec_cast.projects_stage.integer <- function(x, ...) validate_stage(x)
#' @method vec_cast.integer projects_stage
#' @export
vec_cast.integer.projects_stage <- function(x, ...)
as.integer(substr(vec_data(x), 1L, 1L))
#' @method vec_cast.double projects_stage
#' @export
vec_cast.double.projects_stage <- function(x, ...)
as.double(substr(vec_data(x), 1L, 1L))
#' @method vec_cast.projects_stage double
#' @export
vec_cast.projects_stage.double <- function(x, ...) validate_stage(x)
#' @export
Ops.projects_stage <- function(e1, e2) {
get(.Generic)(
vapply(validate_stage(e1), as.integer, 0L),
vapply(validate_stage(e2), as.integer, 0L)
)
}
# Generic methods for match() --------------------------------------------------
#' @rdname projects_stage
#' @export
match.projects_stage <- function(x,
table,
nomatch = NA_integer_,
incomparables = NULL) {
x <- validate_stage(x)
table <- validate_stage(table)
if (!is.null(incomparables)) {
incomparables <- validate_stage(incomparables)
}
base::match(x, table, nomatch, incomparables)
}
#' @include set_generics.R
#' @rdname projects_stage
#' @export
methods::setMethod(
"match",
methods::signature(x = "projects_stage"),
match.projects_stage
)
#' @include set_generics.R
#' @rdname projects_stage
#' @export
methods::setMethod(
"match",
methods::signature(table = "projects_stage"),
match.projects_stage
)
#' @include set_generics.R
#' @rdname projects_stage
#' @export
methods::setMethod(
"match",
methods::signature(x = "projects_stage", table = "projects_stage"),
match.projects_stage
)
# Generic methods for %in% -----------------------------------------------------
#' @rdname projects_stage
#' @export
`%in%.projects_stage` <- function(x, table) {
match(x, table, nomatch = 0L) > 0L
}
#' @include set_generics.R
#' @rdname projects_stage
#' @export
methods::setMethod(
"%in%",
methods::signature("projects_stage"),
`%in%.projects_stage`
)
#' Internal vctrs methods
#'
#' @import vctrs
#' @keywords internal
#' @name projects_stage-vctrs
NULL