Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- #' A strict version of '%in%' where both the in-group and out-group must be completely specified
- #'
- #' The membership test is strict.
- #' - if 'universe' is defined, then `outgroup = setdiff(universe, ingroup)`
- #' - Every value of 'x' must exist within either 'ingroup' or 'outgroup'
- #' - 'ingroup' and 'outgroup' must be disjoint sets
- #' - May specify only one of 'outgroup' or 'universe'
- #'
- #' @param x input values.
- #' @param ingroup vector of values against which elements of 'x' should be checked
- #' for membership.
- #' @param outgroup vector of values to which the elements of 'x' should not belong
- #' @param universe vector of all possible values to expect
- #'
- #'
- #' @return A logical vector the same length as 'x' which is TRUE if the
- #' correponding value in x is a member of 'ingroup' and is not a member
- #' of 'outgroup'.
- #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- is_within <- function(x, ingroup, outgroup=NULL, universe=NULL) {
- if (!xor(is.null(outgroup), is.null(universe))) {
- stop("is_within(): Must only specify one (and only one) of 'outgroup' or 'universe'")
- }
- #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- # Define outgroup to be disjoint from ingroup if 'universe' given,
- # otherwise check that given ingroup/group are disjoint
- #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- if (!is.null(universe)) {
- outgroup <- setdiff(universe, ingroup)
- } else {
- if (length(intersect(ingroup, outgroup)) > 0L) {
- stop("is_within(): 'ingroup' and 'outgroup' must not have overlapping elements. The following elements were found in both - ",
- deparse(intersect(ingroup, outgroup)))
- }
- }
- #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- # Check classes match
- #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- if (length(intersect(class(x), intersect(class(ingroup), class(outgroup)))) == 0L) {
- stop("is_within(): Classes must be identical. x: ", deparse(class(x)),
- " ingroup: ", deparse(class(ingroup)), " outgroup: ", deparse(class(outgroup)))
- }
- #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- # Check inputs have length >= 1
- #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- if (length(x) == 0L) { stop("is_within(): 'x' must have at least 1 element")}
- if (length(ingroup) == 0L) { stop("is_within(): 'ingroup' must have at least 1 element")}
- #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- # Actually perform the membership tests
- #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- res <- x %in% ingroup
- neg <- x %in% outgroup
- #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- # Check: input values must appear in one of 'ingroup' or 'outgroup', but not both.
- #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- if (any(!xor(res, neg))) {
- stop("is_within(): All elements should appear in the 'ingroup' or 'outgroup' vectors. The following input elements were not found in either - ", deparse(x[!xor(res, neg)]))
- }
- res
- }
Add Comment
Please, Sign In to add comment