R/ctabs.R

In libcoin: Linear Test Statistics for Permutation Inference

# R Header

###    Copyright (C) 2017-2023 Torsten Hothorn
###
###    This file is part of the 'libcoin' R add-on package.
###
###    'libcoin' is free software: you can redistribute it and/or modify
###    it under the terms of the GNU General Public License as published by
###    the Free Software Foundation, version 2.
###
###    'libcoin' is distributed in the hope that it will be useful,
###    but WITHOUT ANY WARRANTY; without even the implied warranty of
###    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
###    GNU General Public License for more details.
###
###    You should have received a copy of the GNU General Public License
###    along with 'libcoin'.  If not, see <http://www.gnu.org/licenses/>.
###
###
###    DO NOT EDIT THIS FILE
###
###    Edit 'libcoin.w' and run 'nuweb -r libcoin.w'

ctabs <-
function(ix, iy = integer(0), block = integer(0), weights = integer(0),
         subset = integer(0), checkNAs = TRUE)
{
    stopifnot(is.integer(ix) || is.factor(ix))
    N <- length(ix)

    # Check ix
    
    if (is.null(attr(ix, "levels"))) {
        rg <- range(ix)
        if (anyNA(rg))
            stop("no missing values allowed in ix")
        stopifnot(rg[1] >= 0)
        attr(ix, "levels") <- seq_len(rg[2])
    } else {
        ## lev can be data.frame (see inum::inum)
        lev <- attr(ix, "levels")
        if (!is.vector(lev)) lev <- seq_len(NROW(lev))
        attr(ix, "levels") <- lev
        if (checkNAs) stopifnot(!anyNA(ix))
    }
    

    if (length(iy) > 0) {
        stopifnot(length(iy) == N)
        stopifnot(is.integer(iy) || is.factor(iy))
        # Check iy
        
        if (is.null(attr(iy, "levels"))) {
            rg <- range(iy)
            if (anyNA(rg))
                stop("no missing values allowed in iy")
            stopifnot(rg[1] >= 0)
            attr(iy, "levels") <- seq_len(rg[2])
        } else {
            ## lev can be data.frame (see inum::inum)
            lev <- attr(iy, "levels")
            if (!is.vector(lev)) lev <- seq_len(NROW(lev))
            attr(iy, "levels") <- lev
            if (checkNAs) stopifnot(!anyNA(iy))
        }
        
    }

    # Check weights, subset, block
    
    if (is.null(weights)) weights <- integer(0)

    if (length(weights) > 0) {
        if (!((N == length(weights)) && all(weights >= 0)))
            stop("incorrect weights")
        if (checkNAs) stopifnot(!anyNA(weights))
    }

    if (is.null(subset)) subset <- integer(0)

    if (length(subset) > 0 && checkNAs) {
        rs <- range(subset)
        if (anyNA(rs)) stop("no missing values allowed in subset")
        if (!((rs[2] <= N) && (rs[1] >= 1L)))
            stop("incorrect subset")
    }

    if (is.null(block)) block <- integer(0)

    if (length(block) > 0) {
        if (!((N == length(block)) && is.factor(block)))
            stop("incorrect block")
        if (checkNAs) stopifnot(!anyNA(block))
    }
    

    if (length(iy) == 0)
        if (length(block) == 0)
            .Call(R_OneTableSums, ix, weights, subset)
        else
            .Call(R_TwoTableSums, ix, block, weights, subset)[, -1, drop = FALSE]
    else if (length(block) == 0)
        .Call(R_TwoTableSums, ix, iy, weights, subset)
    else
        .Call(R_ThreeTableSums, ix, iy, block, weights, subset)
}