Nothing
setMethod("RCLSMIX",
signature(model = "RCLSMIX"),
function(model, ...)
{
o <- length(model@x)
d <- array(data = NA, dim = o, dimnames = NULL)
c <- array(data = list(NULL), dim = c(o, model@s), dimnames = NULL)
w <- array(data = list(NULL), dim = c(o, model@s), dimnames = NULL)
pdf <- array(data = list(NULL), dim = c(o, model@s), dimnames = NULL)
theta1 <- array(data = list(NULL), dim = c(o, model@s), dimnames = NULL)
theta2 <- array(data = list(NULL), dim = c(o, model@s), dimnames = NULL)
theta3 <- array(data = list(NULL), dim = c(o, model@s), dimnames = NULL)
for (io in 1:o) {
for (is in 1:model@s) {
Names <- names(model@x[[io]]@Theta[[is]])
pdf[[io, is]] <- unlist(model@x[[io]]@Theta[[is]][grep("pdf", Names)])
theta1[[io, is]] <- unlist(model@x[[io]]@Theta[[is]][grep("theta1", Names)])
theta1[[io, is]][is.na(theta1[[io, is]])] <- 0
theta2[[io, is]] <- unlist(model@x[[io]]@Theta[[is]][grep("theta2", Names)])
theta2[[io, is]][is.na(theta2[[io, is]])] <- 0
theta3[[io, is]] <- unlist(model@x[[io]]@Theta[[is]][grep("theta3", Names)])
theta3[[io, is]][is.na(theta3[[io, is]])] <- 0
c[[io, is]] <- length(model@x[[io]]@w[[is]])
w[[io, is]] <- model@x[[io]]@w[[is]]
d[io] <- length(pdf[[io, is]]) / c[[io, is]]
}
}
output <- .C(C_RCLSMIX,
n = as.integer(model@ntest),
X = as.double(unlist(model@Dataset)),
s = as.integer(model@s),
o = as.integer(o),
d = as.integer(d),
c = as.integer(unlist(c)),
w = as.double(unlist(w)),
pdf = as.character(unlist(pdf)),
theta1 = as.double(unlist(theta1)),
theta2 = as.double(unlist(theta2)),
theta3 = as.double(unlist(theta3)),
P = as.double(unlist(model@P)),
Z = integer(model@ntest),
error = integer(1),
PACKAGE = "rebmix")
if (output$error == 1) {
stop("in RCLSMIX!", call. = FALSE); return(NA)
}
model@Zp <- factor(output$Z, levels = levels(model@Zt))
rm(list = ls()[!(ls() %in% c("model"))])
return(model)
}) ## RCLSMIX
setMethod("RCLSMIX",
signature(model = "RCLSMVNORM"),
function(model, ...)
{
o <- length(model@x)
d <- array(data = NA, dim = o, dimnames = NULL)
c <- array(data = list(NULL), dim = c(o, model@s), dimnames = NULL)
w <- array(data = list(NULL), dim = c(o, model@s), dimnames = NULL)
pdf <- array(data = list(NULL), dim = c(o, model@s), dimnames = NULL)
theta1 <- array(data = list(NULL), dim = c(o, model@s), dimnames = NULL)
theta2 <- array(data = list(NULL), dim = c(o, model@s), dimnames = NULL)
for (io in 1:o) {
for (is in 1:model@s) {
Names <- names(model@x[[io]]@Theta[[is]])
pdf[[io, is]] <- unlist(model@x[[io]]@Theta[[is]][grep("pdf", Names)])
theta1[[io, is]] <- unlist(model@x[[io]]@Theta[[is]][grep("theta1", Names)])
theta1[[io, is]][is.na(theta1[[io, is]])] <- 0
theta2[[io, is]] <- unlist(model@x[[io]]@Theta[[is]][grep("theta2", Names)])
theta2[[io, is]][is.na(theta2[[io, is]])] <- 0
c[[io, is]] <- length(model@x[[io]]@w[[is]])
w[[io, is]] <- model@x[[io]]@w[[is]]
d[io] <- length(pdf[[io, is]]) / c[[io, is]]
}
}
output <- .C(C_RCLSMVNORM,
n = as.integer(model@ntest),
X = as.double(unlist(model@Dataset)),
s = as.integer(model@s),
o = as.integer(o),
d = as.integer(d),
c = as.integer(unlist(c)),
w = as.double(unlist(w)),
pdf = as.character(unlist(pdf)),
theta1 = as.double(unlist(theta1)),
theta2 = as.double(unlist(theta2)),
P = as.double(unlist(model@P)),
Z = integer(model@ntest),
error = integer(1),
PACKAGE = "rebmix")
if (output$error == 1) {
stop("in RCLSMVNORM!", call. = FALSE); return(NA)
}
model@Zp <- factor(output$Z, levels = levels(model@Zt))
rm(list = ls()[!(ls() %in% c("model"))])
return(model)
}) ## RCLSMIX
setMethod("RCLSMIX",
signature(model = "ANY"),
function(model,
x,
Dataset,
Zt, ...)
{
digits <- getOption("digits"); options(digits = 15)
message("RCLSMIX Version 2.15.0")
flush.console()
levels <- levels(Zt)
model <- new(model,
x = x,
Dataset = Dataset,
Zt = Zt)
model <- RCLSMIX(model = model, ...)
levels(model@Zt) <- levels
levels(model@Zp) <- levels
model@CM <- table(model@Zt, model@Zp)
model@Accuracy <- sum(diag(model@CM)) / model@ntest
model@Error <- 1.0 - model@Accuracy
model@Precision <- diag(model@CM) / apply(model@CM, 1, sum)
model@Sensitivity <- diag(model@CM) / apply(model@CM, 2, sum)
model@Specificity <- (model@ntest - apply(model@CM, 1, sum)) / (model@ntest - apply(model@CM, 2, sum))
model@Chunks <- 1:length(x)
options(digits = digits)
rm(list = ls()[!(ls() %in% c("model"))])
return(model)
}) ## RCLSMIX
setMethod("BFSMIX",
signature(model = "ANY"),
function(model,
x,
Dataset,
Zt, ...)
{
digits <- getOption("digits"); options(digits = 15)
message("BFSMIX Version 2.15.0")
flush.console()
temp <- new(model,
x = x,
Dataset = Dataset,
Zt = Zt)
Zr <- factor(rep(1:temp@s, temp@ntrain))
rm(temp)
OPEN <- 1:length(x); CLOSED <- numeric(); Error <- 1.0
repeat {
k <- NA
for (j in OPEN) {
EVAL <- c(CLOSED, j)
temp <- new(model,
x = x[EVAL],
Dataset = do.call("cbind", lapply(x[EVAL], function(x) do.call("rbind", x@Dataset))),
Zt = Zr)
temp <- RCLSMIX(model = temp, ...)
temp@Zp <- factor(temp@Zp, levels = levels(temp@Zt))
temp@CM <- table(temp@Zt, temp@Zp)
temp@Accuracy <- sum(diag(temp@CM)) / temp@ntest
temp@Error <- 1.0 - temp@Accuracy
temp@Precision <- diag(temp@CM) / apply(temp@CM, 1, sum)
temp@Sensitivity <- diag(temp@CM) / apply(temp@CM, 2, sum)
temp@Specificity <- (temp@ntest - apply(temp@CM, 1, sum)) / (temp@ntest - apply(temp@CM, 2, sum))
temp@Chunks <- EVAL
if (temp@Error < Error) {
Error <- temp@Error; k <- j
}
rm(temp)
}
if (is.na(k)) {
break
}
else {
OPEN <- OPEN[-which(OPEN == k)]; CLOSED <- c(CLOSED, k)
}
}
model <- new(model,
x = x[CLOSED],
Dataset = as.data.frame(Dataset[, CLOSED]),
Zt = Zt)
model <- RCLSMIX(model = model, ...)
model@Zp <- factor(model@Zp, levels = levels(model@Zt))
model@CM <- table(model@Zt, model@Zp)
model@Accuracy <- sum(diag(model@CM)) / model@ntest
model@Error <- 1.0 - model@Accuracy
model@Precision <- diag(model@CM) / apply(model@CM, 1, sum)
model@Sensitivity <- diag(model@CM) / apply(model@CM, 2, sum)
model@Specificity <- (model@ntest - apply(model@CM, 1, sum)) / (model@ntest - apply(model@CM, 2, sum))
model@Chunks <- CLOSED
options(digits = digits)
rm(list = ls()[!(ls() %in% c("model"))])
return(model)
}) ## BFSMIX
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.