R/outer.R

Defines functions gset_outer set_outer

Documented in gset_outer set_outer

set_outer <-
function(X, Y, FUN = "*", ..., SIMPLIFY = TRUE, quote = FALSE)
{
    ## convenience
    nx <- deparse(substitute(X))
    if(missing(Y)) {
        Y <- X
        ny <- nx
    } else if(is.function(Y) || is.character(Y)) {
        FUN <- Y
        Y <- X
        ny <- nx
    } else ny <- deparse(substitute(Y))

    FUN <- match.fun(FUN)

    ## convert to lists
    xlabs <- LABELS(X, quote = quote)
    ylabs <- LABELS(Y, quote = quote)
    X <- as.list(X)
    Y <- as.list(Y)

    ## loop
    xrep <- rep.int(X, times = (ylen <- length(Y)))
    yrep <- rep(Y, each = (xlen <- length(X)))
    ret <- mapply(FUN, xrep, yrep, MoreArgs = list(...), SIMPLIFY = FALSE)

    ## simplify if sensible
    if(SIMPLIFY && all(sapply(ret, is.atomic)))
        ret <- unlist(ret, recursive = FALSE)

    ## make matrix
    dim(ret) <- c(xlen, ylen)
    dimnames(ret) <- list(xlabs, ylabs)
    ret
}

cset_outer <-
gset_outer <-
function(X, Y, FUN = "*", ..., SIMPLIFY = TRUE, quote = FALSE)
    set_outer(X = X, Y = Y, FUN = FUN, ..., SIMPLIFY = SIMPLIFY, quote = quote)

Try the sets package in your browser

Any scripts or data that you put into this service are public.

sets documentation built on March 7, 2023, 7:58 p.m.