R/zzz.R

In swager/causalForest: Causal Trees and Forests

.onUnload <- function(libpath) library.dynam.unload("causalTree", libpath)

.noGenerics <- TRUE

tree.depth <- function (nodes)
{
    depth <- floor(log(nodes, base = 2) + 1e-7)
    depth - min(depth)
}

string.bounding.box <- function(s)
{
    s2 <- strsplit(s, "\n")
    rows <- sapply(s2, length)
    columns <- sapply(s2, function(x) max(nchar(x, "w")))
    list(columns = columns, rows = rows)
}

node.match <- function(nodes, nodelist, leaves, print.it = TRUE)
{
    node.index <- match(nodes, nodelist, 0L)
    bad <- nodes[node.index == 0L]
    ## FIXME: plurals?
    if (length(bad) > 0 && print.it)
        warning(gettextf("supplied nodes %s are not in this tree",
                         paste(bad, collapse = ",")), domain = NA)
    good <- nodes[node.index > 0L]
    if (!missing(leaves) && any(leaves <- leaves[node.index])) {
        warning(gettextf("supplied nodes %s are leaves",
                paste(good[leaves], collapse = ",")), domain = NA)
        node.index[node.index > 0L][!leaves]
    } else node.index[node.index > 0L]
}

descendants <- function(nodes, include = TRUE)
{
    n <- length(nodes)
    if (n == 1L) return(matrix(TRUE, 1L, 1L))
    ind <- 1:n
    desc <- matrix(FALSE, n, n)
    if (include) diag(desc) <- TRUE
    parents <- match((nodes %/% 2L), nodes)
    lev <- floor(log(nodes, base = 2))
    desc[1L, 2L:n] <- TRUE
    for (i in max(lev):2L) {
        desc[cbind(ind[parents[lev == i]], ind[lev == i])] <- TRUE
        parents[lev == i] <- parents[parents[lev == i]]
        lev[lev == i] <- i - 1L
    }
    desc
}

causalTree_env <- new.env()