https://github.com/cran/aster
Tip revision: 39d4bf9f99bbff5d96f3f4093cdc7a39ca03a29a authored by Charles J. Geyer on 15 March 2017, 08:04:36 UTC
version 0.9.1
version 0.9.1
Tip revision: 39d4bf9
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)
}