https://github.com/cran/aster
Tip revision: 63c8e8a453ea587001e2438a8ce51cf0e1e1675c authored by Charles J. Geyer on 23 March 2009, 00:00:00 UTC
version 0.7-7
version 0.7-7
Tip revision: 63c8e8a
families.R
fam.bernoulli <- function() {
result <- list(name = "bernoulli")
class(result) <- "astfam"
return(result)
}
fam.poisson <- function() {
result <- list(name = "poisson")
class(result) <- "astfam"
return(result)
}
fam.truncated.poisson <- function(truncation) {
stopifnot(is.numeric(truncation))
stopifnot(length(truncation) == 1)
stopifnot(truncation == round(truncation))
stopifnot(truncation >= 0)
result <- list(name = "truncated.poisson", truncation = truncation)
class(result) <- "astfam"
return(result)
}
fam.negative.binomial <- function(size) {
stopifnot(is.numeric(size))
stopifnot(length(size) == 1)
stopifnot(size >= 0)
result <- list(name = "negative.binomial", size = size)
class(result) <- "astfam"
return(result)
}
fam.truncated.negative.binomial <- function(size, truncation) {
stopifnot(is.numeric(size))
stopifnot(length(size) == 1)
stopifnot(size >= 0)
stopifnot(is.numeric(truncation))
stopifnot(length(truncation) == 1)
stopifnot(truncation == round(truncation))
stopifnot(truncation >= 0)
result <- list(name = "truncated.negative.binomial", size = size,
truncation = truncation)
class(result) <- "astfam"
return(result)
}
fam.normal.location <- function(sd) {
stopifnot(is.numeric(sd))
stopifnot(length(sd) == 1)
stopifnot(sd > 0)
result <- list(name = "normal.location", sd = sd)
class(result) <- "astfam"
return(result)
}
fam.default <- function() {
list(fam.bernoulli(), fam.poisson(), fam.truncated.poisson(truncation = 0),
fam.truncated.poisson(truncation = 2))
}
clearfam <- function()
invisible(.C("aster_clear_families", PACKAGE = "aster"))
getsupfambyname <- function(fam) {
stopifnot(is.character(fam))
stopifnot(length(fam) == 1)
foo <- .C("aster_byname_superfamily", name = fam, nhyper = integer(1),
hypername = character(2), PACKAGE = "aster")
foo$name <- fam
return(foo)
}
setfam <- function(famlist) {
stopifnot(is.list(famlist))
stopifnot(all(sapply(famlist, inherits, what = "astfam")))
clearfam()
for (i in seq(along = famlist)) {
fam <- famlist[[i]]
famname <- fam$name
foo <- getsupfambyname(famname)
hyper <- double(2)
if (foo$nhyper >= 1) {
qux <- foo$hypername[1]
bar <- fam[[qux]]
if (is.null(bar))
stop("family \"", famname, "\" needs hyperparameter \"",
foo$hypername[1], "\"")
hyper[1] <- bar
}
if (foo$nhyper >= 2) {
qux <- foo$hypername[2]
bar <- fam[[qux]]
if (is.null(bar))
stop("family \"", famname, "\" needs hyperparameter \"",
foo$hypername[2], "\"")
hyper[2] <- bar
}
.C("aster_add_family", name = famname, hyper = as.double(hyper),
nhyper = as.integer(foo$nhyper), PACKAGE = "aster")
}
}
getfam <- function() {
result <- list()
ifam <- 1
repeat {
foo <- .C("aster_get_family", idx = as.integer(ifam),
name = character(1), hyper = double(2), nhyper = integer(1),
hypername = character(2), origin = double(1), PACKAGE = "aster")
if (foo$name == "")
break;
sally <- list(name = foo$name)
if (foo$nhyper >= 1) {
bar <- foo$hypername[1]
baz <- foo$hyper[1]
sally[[bar]] <- baz
}
if (foo$nhyper >= 2) {
bar <- foo$hypername[2]
baz <- foo$hyper[2]
sally[[bar]] <- baz
}
sally$origin <- foo$origin
result[[ifam]] <- sally
ifam <- ifam + 1
}
return(result)
}
getsupfam <- function() {
result <- list()
ifam <- 1
repeat {
foo <- .C("aster_get_superfamily", idx = as.integer(ifam),
name = character(1), nhyper = integer(1),
hypername = character(2), PACKAGE = "aster")
if (foo$name == "")
break;
sally <- list(name = foo$name)
if (foo$nhyper >= 1) {
bar <- foo$hypername[1]
sally[[bar]] <- NA
}
if (foo$nhyper >= 2) {
bar <- foo$hypername[2]
sally[[bar]] <- NA
}
result[[ifam]] <- sally
ifam <- ifam + 1
}
return(result)
}
as.character.astfam <- function(x, ...) {
nam <- x$name
if (is.null(nam))
stop("astfam object with no name")
x$name <- NULL
if (length(x) == 0)
return(nam)
fred <- ""
for (i in 1:length(x)) {
if (fred != "")
fred <- paste(fred, ", ", sep = "")
fred <- paste(fred, names(x)[i], " = ", x[[i]], sep = "")
}
nam <- paste(nam, "(", fred, ")", sep = "")
return(nam)
}
print.astfam <- function(x, ...) {
foo <- as.character(x)
print(foo)
return(invisible(foo))
}