https://github.com/cran/aster
Raw File
Tip revision: 61fc3cd89e7f6776279333b534652356c7059f89 authored by Charles J. Geyer on 13 June 2021, 03:40 UTC
version 1.1-2
Tip revision: 61fc3cd
transform.R
astertransform <- function(arg, obj, from = c("unconditional", "conditional"),
    to.cond = c("unconditional", "conditional"),
    to.mean = c("mean.value", "canonical")) {
    from <- match.arg(from)
    to.cond <- match.arg(to.cond)
    to.mean <- match.arg(to.mean)
    stopifnot(inherits(obj, "aster"))
    nind <- nrow(obj$x)
    nnode <- ncol(obj$x)
    setfam(obj$famlist)
    stopifnot(is.numeric(arg))
    stopifnot(all(is.finite(arg)))
    stopifnot(length(arg) == nind * nnode)
    if (to.mean == "canonical") {
        if (from == "unconditional" && to.cond == "conditional") {
            result <- .C(C_aster_phi2theta, nind = as.integer(nind),
                nnode = as.integer(nnode), pred = as.integer(obj$pred),
                fam = as.integer(obj$fam), phi = as.double(arg),
                theta = matrix(as.double(0), nind, nnode))$theta
        }
        if (from == "conditional" && to.cond == "unconditional") {
            result <- .C(C_aster_theta2phi, nind = as.integer(nind),
                nnode = as.integer(nnode), pred = as.integer(obj$pred),
                fam = as.integer(obj$fam), theta = as.double(arg),
                phi = matrix(as.double(0), nind, nnode))$phi
        }
        if (from == to.cond) {
            result <- arg
        }
    } else {
        ### to.mean == "mean.value"
        if (from == "conditional") {
            theta <- arg
        }
        if (from == "unconditional") {
            theta <- .C(C_aster_phi2theta, nind = as.integer(nind),
                nnode = as.integer(nnode), pred = as.integer(obj$pred),
                fam = as.integer(obj$fam), phi = as.double(arg),
                theta = matrix(as.double(0), nind, nnode))$theta
        }
        result <- .C(C_aster_theta2ctau, nind = as.integer(nind),
            nnode = as.integer(nnode), pred = as.integer(obj$pred),
            fam = as.integer(obj$fam), theta = as.double(theta),
            ctau = matrix(as.double(0), nind, nnode))$ctau
        if (to.cond == "unconditional") {
            result <- .C(C_aster_ctau2tau, nind = as.integer(nind),
               nnode = as.integer(nnode), pred = as.integer(obj$pred),
               fam = as.integer(obj$fam), root = as.double(obj$root),
               ctau = as.double(result), tau = matrix(as.double(0),
                 nind, nnode))$tau
        }
    }
    clearfam()
    return(result)
}
back to top