Stricter membership testing in #rstats

is_within.R

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' 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
}