Nothing
#' \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 <- as.character(x)
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
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.