limitedDiversity <- function (truth.tab, outcome = "", exo.facs = c(""),
sol.type = "ps", dir.exp = c(), n.drop = 1,
c.minterms = FALSE) {
# unique models
usols <- list()
# solution space
sol.space <- list()
# if truth.tab is an object of class "tt" generated by truthTable function,...
if (is.tt(truth.tab)) {
# extract the bare truth table, also eliminating remainders if truth table
# was built with complete = TRUE
truth.tab <- truth.tab$tt[truth.tab$tt$OUT != "?" , -(which(
colnames(truth.tab$tt) %in% c("n", "incl", "PRI", "pval1", "pval0")
))]
# if present, replace "C" by c.minterms and turn OUT into numeric vector
truth.tab$OUT[truth.tab$OUT == "C"] <- c.minterms
truth.tab$OUT <- as.numeric(truth.tab$OUT)
# if the name of the outcome is not 'OUT' and 'outcome' is not ""
if (outcome != "OUT" & nchar(gsub(" ", "", outcome)) != 0) {
errmsg <- paste0("You are using an object of class 'tt'. In this case,
the outcome must be set to 'OUT'. It is currently
specified as '", outcome, "'.")
cat("\n")
stop(paste(strwrap(errmsg, exdent = 7), collapse = "\n"),
call. = FALSE)
}
else {
outcome <- "OUT"
exo.facs <- colnames(truth.tab)[-length(colnames(truth.tab))]
}
}
rows.truth.tab <- nrow(truth.tab)
# if the number of truth table rows is smaller than n.drop
if (rows.truth.tab < n.drop) {
errmsg <- paste0("The number of minterms to be dropped (", n.drop,
") cannot be larger than the number of observed minterms
in the truth table (", rows.truth.tab,").")
cat("\n")
stop(paste(strwrap(errmsg, exdent = 7), collapse = "\n"), call. = FALSE)
}
# if any other value/s apart from only 0 or only 1 are assigned to c.minterms
if (length(c.minterms) > 1 & !c.minterms %in% c(0,1)) {
errmsg <- paste0("The number of minterms to be dropped (", n.drop,
") cannot be larger than the number of observed minterms
in the truth table (", rows.truth.tab,").")
cat("\n")
stop(paste(strwrap(errmsg, exdent = 7), collapse = "\n"), call. = FALSE)
}
# combinations of minterms to be dropped
cbs <- combn(rows.truth.tab, n.drop)
solist <- lapply(seq(ncol(cbs)), function (x) {
# for intermediate solutions
if (length(dir.exp) > 0) {
try({sol.space <- unname(
sapply(eQMC(truth.tab[-cbs[, x], ], outcome = outcome,
exo.facs = exo.facs, sol.type = sol.type,
dir.exp = dir.exp)$i.sol, "[[", "solution")
)},
silent = TRUE)
}
# conservative and parsimonious solutions
else {
try({sol.space <- eQMC(truth.tab[-cbs[, x], ], outcome = outcome,
exo.facs = exo.facs,
sol.type = sol.type)$solution},
silent = TRUE)
}
if (length(sol.space) > 0) {
if (is.list(unlist(sol.space, recursive = FALSE)) == FALSE) {
for (sol in seq(length(sol.space))) {
sol.space[[sol]] <- paste(sort(sol.space[[sol]]),
collapse = "+")
}
}
else {
sol.space <- unlist(sol.space, recursive = FALSE)
for (sol in seq(length(sol.space))) {
sol.space[[sol]] <- paste(sort(sol.space[[sol]]),
collapse = "+")
}
}
sol.space <- unlist(sol.space)
}
else {
sol.space <- ""
}
return(sol.space)
})
solsfull <- solist
solist <- unlist(solist)
for (sol in seq(length(solist))) {
poslist <- which(unlist(lapply(usols, all.equal, solist[[sol]])) == TRUE)
if (length(poslist) == 0) {
usols[[length(usols) + 1]] <- solist[sol]
solist[sol] <- names(usols)[length(usols)] <- length(usols)
}
else {
solist[sol] <- names(usols)[poslist]
}
}
soltable <- table(unlist(solist))
soldf <- data.frame(N = as.vector(soltable),
ID = as.integer(names(soltable)),
SHARE = round(prop.table(as.vector(soltable)), 4)*100)
rownames(soldf) <- unlist(usols)
return(list(model.shares = soldf[order(-soldf$SHARE, soldf$ID), ],
solutions = solsfull, tt = truth.tab))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.