R/class_schema_setops.R

In jeanmathieupotvin/cargo: Data containers, schemas and prototypes

# setops.R


#' @include globals.R
#' @include internals.R


#' @rdname class_schema_setops
#' @template class_schema_setops
#' @aliases sintersect
#' @export
sintersect <- function(x, y, what = c("inputs", "types"))
{
    stopifnot(is_schema(y))
    what <- match.arg(what)
    if (!is_schema(x)) x <- as_schema(x)

    ix  <- inputs(x)
    iy  <- inputs(y)

    if (what == "inputs") {
        return(iy[match(ix, iy, 0L)])
    } else {
        ixy <- iy[match(ix, iy, 0L)]
        clx <- .vclass(lapply(prototypes(x[match(ixy, ix, 0L)]), archetype))
        cly <- .vclass(lapply(prototypes(y[match(ixy, iy, 0L)]), archetype))
        return(ixy[cly == clx])
    }
}


#' @rdname class_schema_setops
#' @export
sdiff <- function(x, y, what = c("inputs", "types"))
{
    stopifnot(is_schema(y))
    what <- match.arg(what)
    if (!is_schema(x)) x <- as_schema(x)

    ix  <- inputs(x)
    iy  <- inputs(y)

    if (what == "inputs") {
        return(iy[match(iy, ix, 0L) == 0L])
    } else {
        ixy <- iy[match(ix, iy, 0L)]
        clx <- .vclass(lapply(prototypes(x[match(ixy, ix, 0L)]), archetype))
        cly <- .vclass(lapply(prototypes(y[match(ixy, iy, 0L)]), archetype))
        return(ixy[cly != clx])
    }
}


#' @rdname class_schema_setops
#' @export
sequal <- function(x, y, what = c("inputs", "types", "strict"))
{
    what <- match.arg(what)
    if (!is_schema(x)) x <- as_schema(x)
    if (what == "inputs") {
        return(length(sdiff(x, y, "inputs")) == 0L)
    } else if (what == "types") {
        return(length(sdiff(x, y, "types")) == 0L)
    } else {
         return(
             length(sdiff(x, y, "inputs")) + length(sdiff(x, y, "types")) == 0L
        )
    }
}