Nothing
eQMC <- function(data, outcome = c(""), neg.out = FALSE, exo.facs = c(""),
relation = "suf", n.cut = 1, incl.cut1 = 1, incl.cut0 = 1,
minimize = c("1"), sol.type = "ps", row.dom = FALSE, min.dis = FALSE,
omit = c(), dir.exp = c(), details = FALSE, show.cases = FALSE,
inf.test = c(""), use.tilde = FALSE, use.letters = FALSE, ...) {
# specify solution types (argument 'include' to be replaced in future version)
if (sol.type == "cs") {include <- c("")}
else if (sol.type == "cs+") {include <- c("C")}
else if (sol.type == "ps") {include <- c("?")}
else if (sol.type == "ps+") {include <- c("?", "C")}
else {errmsg <- paste0("The specified solution type, ", sol.type,", does not
exist. Either \"ps\" or \"ps+\" should normally be used.")
cat("\n")
stop(paste(strwrap(errmsg, exdent = 7), collapse = "\n"), call. = FALSE)
}
metacall <- match.call()
other.args <- list(...)
PRI <- FALSE
if ("PRI" %in% names(other.args)) {
if (is.logical(other.args$PRI)) {
PRI <- other.args$PRI
}
}
# before: print.truth.table <- details & !is.tt(data)
print.truth.table <- FALSE
if (all(include == "")) {
if (!is.null(dir.exp)) {
errmsg <- paste0("Directional expectations cannot be specified in
conjunction with the conservative solution. Please use
sol.type = \"ps\" or sol.type = \"ps+\" for this purpose.")
cat("\n")
stop(paste(strwrap(errmsg, exdent = 7), collapse = "\n"), call. = FALSE)
}
else {
include <- minimize
}
}
if (!is.tt(data)) {
# if "matrix", first turn into "data.frame"
if (is.matrix(data)) {
data <- as.data.frame(data)
}
if (length(outcome) > 1) {
return(eQMCLoop(data = data, outcome = outcome, neg.out = neg.out,
exo.facs = exo.facs, n.cut = n.cut, incl.cut1 = incl.cut1,
incl.cut0 = incl.cut0, minimize = minimize, include = include,
row.dom = row.dom, min.dis = min.dis, omit = omit,
dir.exp = dir.exp, details = details, show.cases = show.cases,
use.tilde = use.tilde, use.letters = use.letters,
inf.test = inf.test, relation = relation,
... = ...))
}
verify.qca(minimize = minimize)
outcome.copy <- outcome
indata <- data # important before altering the outcome, if multi-value
if (grepl("[{]", outcome)) {
outcome <- substr(outcome, 1, regexpr("[{]", outcome)[1] - 1)
outcome.value <- as.numeric(substr(outcome.copy, regexpr("[{]", outcome.copy)[1] + 1,
regexpr("}", outcome.copy)[1] - 1))
data[, outcome] <- ifelse(data[, outcome] == outcome.value, 1, 0)
}
complete <- FALSE
if ("complete" %in% names(other.args)) {
complete <- other.args$complete
}
tt <- truthTable(data = data, outcome = outcome, neg.out = neg.out,
exo.facs = exo.facs, n.cut = n.cut, incl.cut1 = incl.cut1,
incl.cut0 = incl.cut0, complete = complete,
show.cases = show.cases, use.letters = use.letters,
PRI = PRI)
# if no exogenous factors are specified, use all factors except that of the outcome
if (all(gsub("\\s", "", exo.facs, perl = TRUE) == "")) {
exo.facs <- colnames(data)[-which(colnames(data) == outcome)]
}
# make sure all relevant labels are uppercase
idx.names <- match(colnames(data[, c(exo.facs, outcome)]), colnames(data))
colnames(data)[idx.names] <- toupper(colnames(data)[idx.names])
exo.facs <- toupper(exo.facs)
outcome <- toupper(outcome)
data <- data[, c(exo.facs, outcome)]
tt$initial.data <- indata
indata <- data # data is already altered in outcome value, if initially multi-value
recdata <- tt$recoded.data
colnames(indata) <- c(exo.facs, outcome)
# dir.exp should now be a list, in the same order as exo.facs
dir.exp <- verify.dir.exp(recdata, outcome, exo.facs, dir.exp)
if (!is.null(dir.exp)) {
names(dir.exp) <- toupper(names(dir.exp))
}
rowsNotMissing <- which(tt$tt$OUT != "?")
}
else { # data already is a tt
chminimize <- c(0, 1)[which(0:1 %in% minimize)]
chinclude <- c(0, 1)[which(0:1 %in% include)]
if (length(chinclude) > 0) {
if (any(chinclude != chminimize)) {
chinclude <- chinclude[which(chinclude != chminimize)]
stop(paste("\nYou cannot include ", chinclude, " since you want to minimize ", chminimize, ".\n\n", sep=""), call. = FALSE)
}
}
# check if minimize has both 1 and 0
if (length(chminimize) == 2) {
stop("\nPositive and negative minterms must not be combined.\n\n", call. = FALSE)
}
tt <- data
indata <- tt$initial.data
recdata <- tt$recoded.data
exo.facs <- colnames(recdata)[seq(length(tt$noflevels))]
outcome <- colnames(recdata)[ncol(recdata)]
use.letters <- tt$opts$use.letters
rowsNotMissing <- which(tt$tt$OUT != "?")
if (any(tt$tt$OUT == "?")) {
missings <- which(tt$tt$OUT == "?")
tt$tt <- tt$tt[-missings, ]
}
neg.out <- tt$neg.out
dir.exp <- verify.dir.exp(recdata, outcome, exo.facs, dir.exp)
if (!is.null(dir.exp)) {
names(dir.exp) <- toupper(names(dir.exp))
}
}
uplow <- TRUE
noflevels <- tt$noflevels
# check if the column names are not already letters
alreadyletters <- sum(nchar(colnames(recdata)[-ncol(recdata)])) == ncol(recdata) - 1
output <- list()
output$tt <- tt
output$opts$print.truth.table <- print.truth.table
tt$tt[, seq(length(exo.facs))] <- as.data.frame(lapply(tt$tt[, seq(length(exo.facs))], function(x) {
x[x %in% c("-", "dc")] <- -1
return(as.numeric(x))
}))
expl.incl <- unique(c(minimize, include)) # here "include" may contain contradictions; missings are irrelevant as they were already erased
subset.tt <- tt$tt[, "OUT"] %in% expl.incl
expl.matrix <- as.matrix(tt$tt[subset.tt, seq(length(noflevels))])
expl.matrix <- matrix(as.numeric(expl.matrix), ncol = length(noflevels)) + 1
rownames(expl.matrix) <- tt$indexes[subset.tt]
subset.tt <- !tt$tt[, "OUT"] %in% expl.incl
excl.matrix <- as.matrix(tt$tt[subset.tt, seq(length(noflevels))])
excl.matrix <- matrix(as.numeric(excl.matrix), ncol = length(noflevels)) + 1
subset.tt <- tt$tt[, "OUT"] %in% minimize
if (all(!subset.tt)) {
stop(paste0("\nNone of the output function values is minimized. Please check the truth table.\n\n"), call. = FALSE)
}
inputt <- as.matrix(tt$tt[subset.tt, seq(length(noflevels))])
rownms <- rownames(inputt)
inputt <- matrix(as.numeric(inputt), ncol=length(noflevels)) + 1
inputcases <- tt$cases[rowsNotMissing][subset.tt]
nofcases1 <- sum(tt$tt$n[tt$tt$OUT == 1])
nofcases0 <- sum(tt$tt$n[tt$tt$OUT == 0])
nofcasesC <- sum(tt$tt$n[tt$tt$OUT == "C"])
tomit <- logical(nrow(expl.matrix))
tomitinputt <- logical(nrow(inputt))
if (is.matrix(omit)) {
cnoflevels <- noflevels
for (i in seq(ncol(omit))) {
if (any(omit[, i] < 0)) {
omit[, i][omit[, i] < 0] <- noflevels[i]
cnoflevels[i] <- noflevels[i] + 1
}
}
omitrows <- drop(rev(c(1, cumprod(rev(cnoflevels))))[-1] %*% t(omit)) + 1
tomit <- rownames(expl.matrix) %in% omitrows
tomitinputt <- rownms %in% omitrows
excl.matrix <- rbind(excl.matrix, omit + 1)
}
else if (is.vector(omit)) {
tomit <- rownames(expl.matrix) %in% omit
tomitinputt <- rownms %in% omit
excl.matrix <- unique(rbind(excl.matrix, getRow(noflevels, as.numeric(omit)) + 1))
}
output$excluded <- sort(drop(rev(c(1, cumprod(rev(noflevels))))[-1] %*% t(excl.matrix - 1)) + 1)
expl.matrix <- expl.matrix[!tomit, , drop = FALSE]
inputt <- inputt[!tomitinputt, , drop = FALSE]
inputcases <- inputcases[!tomitinputt]
if (nrow(expl.matrix) == 0) {
stop("\nAll observed minterms have the same function value. Please check the truth table.\n\n", call. = FALSE)
}
incl.rem <- "?" %in% include
if (nrow(excl.matrix) == 0 & incl.rem) {
stop("\nAll observed minterms have the same function value. Please check the truth table.\n\n", call. = FALSE)
}
# expl.matrix needs to be unaltered for the incl.rem argument
expressions <- expl.matrix
recdata[, exo.facs] <- as.data.frame(lapply(recdata[, exo.facs], function(x) {
x[x %in% c("-", "?", "dc")] <- -1
return(as.numeric(x))
}))
# check if the data has multiple values
if (any(recdata[, seq(ncol(recdata) - 1)] > 1)) {
uplow <- FALSE
use.tilde <- FALSE
}
if (use.tilde) {
uplow <- FALSE
}
collapse <- ifelse(alreadyletters & uplow | use.tilde, "", "*")
changed <- FALSE
# if not already letters and user specifies using letters for conditions, change it
if (use.letters & !alreadyletters) {
colnames(expressions) <- colnames(inputt) <- colnames(expl.matrix) <- LETTERS[seq(ncol(inputt))]
changed <- TRUE
collapse <- ifelse(!uplow | use.tilde, "*", "")
}
else {
colnames(expressions) <- colnames(inputt) <- colnames(expl.matrix) <- colnames(recdata[, seq(ncol(inputt))])
if (use.tilde) {
collapse <- "*"
}
}
output$initials <- writePrimeimp(inputt, collapse=collapse, uplow=uplow, use.tilde=use.tilde)
initial <- drop(rev(c(1, cumprod(rev(noflevels))))[-1] %*% t(inputt - 1)) + 1
minExpressions <- function(expressions) {
minimized <- TRUE
while (any(minimized)) {
minimized <- logical(nrow(expressions))
distance <- dist(expressions, method="manhattan")
distance <- as.matrix(distance)
distance[!upper.tri(distance)] <- NA
tbc <- as.matrix(which(distance == 1, arr.ind=TRUE))
if (nrow(tbc) > 0) {
differences <- t(apply(tbc, 1, function(idx) expressions[idx[1], ] != expressions[idx[2], ]))
result <- matrix(0, nrow=0, ncol=ncol(differences))
for (i in seq.int(nrow(differences))) {
stable.values <- expressions[tbc[i, 1], !differences[i, , drop=FALSE], drop=FALSE]
subset.minimize <- apply(expressions[, !differences[i, , drop=FALSE], drop=FALSE], 1, function(x) all(x == stable.values))
if (sum(subset.minimize) == noflevels[differences[i, ]]) {
minimized[subset.minimize] <- TRUE
minimization.result <- expressions[tbc[i, 1], , drop=FALSE]
minimization.result[differences[i, ]] <- 0
result <- rbind(result, as.vector(minimization.result))
}
}
}
if (sum(minimized) > 0) {
expressions <- rbind(expressions[!minimized, ], unique(result))
}
}
return(expressions)
}
expressions <- minExpressions(expressions)
c.sol <- p.sol <- getSolution(expressions = expressions, collapse = collapse,
uplow = uplow, use.tilde = use.tilde, inputt = inputt,
row.dom = row.dom, initial = initial, min.dis = min.dis,
... = ...)
mbase <- rev(c(1, cumprod(rev(noflevels + 1))))[-1]
if (incl.rem) {
expressions <- sort(setdiff(findSupersets(noflevels + 1, expl.matrix), findSupersets(noflevels + 1, excl.matrix)))
expressions <- .Call("removeRedundants", expressions, noflevels, mbase, PACKAGE="QCApro")
expressions <- getRow(noflevels + 1, expressions)
colnames(expressions) <- colnames(inputt)
p.sol <- getSolution(expressions = expressions, collapse = collapse,
uplow = uplow, use.letters = use.letters, use.tilde = use.tilde, inputt = inputt,
row.dom = row.dom, initial = initial, min.dis = min.dis,
... = ...)
}
output$PIs <- p.sol$all.PIs
output$PIchart <- structure(list(p.sol$mtrx), class = "pic")
output$primes <- p.sol$reduced$expressions
output$solution <- p.sol$solution.list[[1]]
output$essential <- p.sol$solution.list[[2]]
expr.cases <- rep(NA, nrow(p.sol$reduced$expressions))
tt.rows <- createString(inputt - 1, collapse=collapse, uplow, use.tilde)
mtrxlines <- demoChart(rownames(p.sol$reduced$expressions), tt.rows, ifelse((use.letters & uplow) | (alreadyletters & uplow), "", "*"))
for (l in seq(length(expr.cases))) {
expr.cases[l] <- paste(inputcases[mtrxlines[l, ]], collapse="; ")
}
if (length(p.sol$solution.list[[1]]) == 1) {
listIC <- pof(p.sol$reduced$expressions - 1, tt$outcome, indata, showc=TRUE, cases=expr.cases, neg.out=neg.out,
relation = "sufficiency", via.eQMC = TRUE)
listIC$opts$show.cases <- show.cases
}
else {
listIC <- pof(p.sol$reduced$expressions - 1, tt$outcome, indata, showc=TRUE, cases=expr.cases, neg.out=neg.out,
relation = "sufficiency", via.eQMC = TRUE, solution.list=output$solution, essential=output$essential)
listIC$opts$show.cases <- show.cases
}
output$pims <- listIC$pims
listIC$pims <- NULL
output$IC <- listIC
output$numbers <- c(OUT1 = nofcases1, OUT0 = nofcases0, OUTC = nofcasesC,
Total = nofcases1 + nofcases0 + nofcasesC)
output$inputcases <- inputcases
output$opts$minimize <- minimize
output$opts$neg.out <- neg.out
output$opts$details <- details
output$opts$show.cases <- show.cases
output$opts$use.letters <- use.letters
output$opts$collapse <- collapse
if (PRI) {
output$opts$PRI <- other.args$PRI[1]
}
output$SA <- lapply(p.sol$solution.list[[1]], function(x) {
p.expressions <- p.sol$reduced$expressions[x, , drop=FALSE]
temp <- apply(p.expressions, 1, function(pr) {
indices <- rev(which(!pr))
SA <- NULL
for (k in indices) {
if (is.null(SA)) {
SA <- drop(mbase %*% pr) + sum(mbase[!pr])
}
tempSA <- SA
for (lev in seq(noflevels[k] - 1)) {
tempSA <- c(tempSA, SA + mbase[k]*lev)
}
SA <- tempSA
}
return(SA)
})
if (all(is.null(temp))) {
return(NULL)
}
else {
temp <- sort(unique(as.vector(unlist(temp))))
temp <- temp[!temp %in% drop(mbase %*% t(inputt))]
if (length(temp) > 0) {
SA <- getRow(noflevels + 1, temp + 1) - 1
colnames(SA) <- colnames(inputt)
rownames(SA) <- drop(c(rev(cumprod(rev(noflevels))), 1)[-1] %*% t(SA)) + 1
return(SA)
}
else {
return(NULL)
}
}
})
prettyNums <- formatC(seq(length(p.sol$solution.list[[1]])), digits = nchar(length(p.sol$solution.list[[1]])) - 1, flag = 0)
names(output$SA) <- paste0("M", prettyNums)
if (!is.null(dir.exp) & all(include != c(""))) {
i.sol <- vector("list", length(c.sol$solution.list[[1]])*length(p.sol$solution.list[[1]]))
index <- 1
for (c.s in seq(length(c.sol$solution.list[[1]]))) {
c.expressions <- c.sol$reduced$expressions[c.sol$solution.list[[1]][[c.s]], , drop = FALSE]
for (p.s in seq(length(p.sol$solution.list[[1]]))) {
p.expressions <- p.sol$reduced$expressions[p.sol$solution.list[[1]][[p.s]], , drop = FALSE]
dir.exp.matrix <- matrix(matrix(ncol = length(exo.facs), nrow = 0))
for (i in seq(nrow(c.expressions))) {
comp <- c.expressions[i, ]
for (j in seq(nrow(p.expressions))) {
pars <- p.expressions[j, ]
dir.exp.temp <- rep(-1, length(pars))
equals <- comp[pars > 0] == pars[pars > 0]
if (all(equals) > 0) {
res <- lapply(dir.exp, function(x) return(-1))
equals <- which(pars > 0)
for (k in equals) {
res[[k]] <- sort(drop(as.numeric(pars[k] - 1)))
}
dir.exp.temp[equals] <- c.expressions[i, equals] - 1
notequals <- setdiff(which(comp > 0), equals)
if (length(notequals) > 0) {
for (k in notequals) {
dir.exp.k <- unique(c(names(
dir.exp[[exo.facs[k]]]
)[dir.exp[[exo.facs[k]]] == 1], c.expressions[i, k] - 1))
if (length(dir.exp.k) != noflevels[k]) {
equals <- sort(c(equals, k))
res[[k]] <- sort(drop(as.numeric(dir.exp.k)))
}
}
}
dir.exp.matrix <- rbind(dir.exp.matrix, expand.grid(res))
}
else {
}
}
}
names(i.sol)[index] <- paste0("C", c.s, "P", p.s)
EC <- matrix(ncol = length(exo.facs), nrow = 0)
colnames(EC) <- colnames(inputt)
for (dir.exp.i in seq(nrow(dir.exp.matrix))) {
dir.exp.x <- dir.exp.matrix[dir.exp.i, ]
if (!is.null(output$SA[[p.s]])) {
SArows <- apply(output$SA[[p.s]], 1, function(x) {
return(all(x[dir.exp.x >= 0] == dir.exp.x[dir.exp.x >= 0]))
})
subSA <- output$SA[[p.s]][SArows, , drop = FALSE]
EC <- rbind(EC, subSA[setdiff(rownames(subSA), rownames(EC)), , drop = FALSE])
}
}
i.sol[[index]]$EC <- EC[order(as.numeric(rownames(EC))), , drop = FALSE]
i.sol[[index]]$DC <- output$SA[[p.s]][setdiff(rownames(output$SA[[p.s]]),
rownames(EC)), , drop = FALSE]
i.sol[[index]]$NSEC <- matrix(ncol = ncol(EC), nrow = 0)
colnames(i.sol[[index]]$NSEC) <- colnames(EC)
nsecs <- TRUE
while (nsecs) {
expl.matrix.i.sol <- unique(rbind(expl.matrix, i.sol[[index]]$EC + 1))
tomit <- logical(nrow(expl.matrix.i.sol))
if (is.matrix(omit)) {
cnoflevels <- noflevels
for (i in seq(ncol(omit))) {
if (any(omit[, i] < 0)) {
omit[, i][omit[, i] < 0] <- noflevels[i]
cnoflevels[i] <- noflevels[i] + 1
}
}
tomit <- rownames(expl.matrix) %in% (drop(rev(c(1, cumprod(rev(cnoflevels))))[-1] %*% t(omit)) + 1)
}
else if (is.vector(omit)) {
if (is.numeric(omit)) {
tomit <- rownames(expl.matrix) %in% as.character(omit)
}
}
expl.matrix.i.sol <- expl.matrix.i.sol[!tomit, , drop = FALSE]
expressions <- minExpressions(expl.matrix.i.sol)
i.sol.index <- getSolution(expressions = expressions,
collapse = collapse, uplow = uplow, use.tilde = use.tilde,
inputt = inputt, row.dom = row.dom, initial = initial,
min.dis = min.dis, ... = ...)
i.sol.index$expressions <- i.sol.index$expressions[rowSums(i.sol.index$mtrx) > 0, , drop = FALSE]
if (nrow(i.sol[[index]]$EC) > 0) {
nsec <- !vector(length = nrow(i.sol[[index]]$EC))
for (i in seq(nrow(i.sol.index$expressions))) {
i.sol.PI <- i.sol.index$expressions[i, ]
for (j in seq(length(nsec))) {
j.EC <- i.sol[[index]]$EC[j, ]
if (all(i.sol.PI[i.sol.PI > 0] == (j.EC[i.sol.PI > 0] + 1))) {
nsec[j] <- FALSE
}
}
}
nsecs <- any(nsec)
}
else {
nsecs <- FALSE
}
if (nsecs) {
i.sol[[index]]$NSEC <- rbind(i.sol[[index]]$NSEC,
i.sol[[index]]$EC[which(nsec), , drop = FALSE])
i.sol[[index]]$EC <- i.sol[[index]]$EC[-which(nsec), , drop = FALSE]
}
}
i.sol[[index]]$PIchart <- structure(list(i.sol.index$mtrx), class = "pic")
i.sol[[index]]$c.sol <- c.sol$solution.list[[1]][[c.s]]
i.sol[[index]]$p.sol <- p.sol$solution.list[[1]][[p.s]]
i.sol[[index]]$solution <- i.sol.index$solution.list[[1]]
i.sol[[index]]$essential <- i.sol.index$solution.list[[2]]
i.sol[[index]]$primes <- i.sol.index$reduced$expressions
expr.cases <- rep(NA, nrow(i.sol.index$reduced$expressions))
tt.rows <- createString(inputt - 1, collapse=collapse, uplow, use.tilde)
mtrxlines <- demoChart(rownames(i.sol.index$reduced$expressions), tt.rows, ifelse((use.letters & uplow) | (alreadyletters & uplow), "", "*"))
for (l in seq(length(expr.cases))) {
expr.cases[l] <- paste(inputcases[mtrxlines[l, ]], collapse="; ")
}
if (length(i.sol.index$solution.list[[1]]) == 1) {
i.sol[[index]]$IC <- pof(i.sol.index$reduced$expressions - 1,
outcome, indata, showc = TRUE, cases = expr.cases,
relation = "sufficiency", neg.out = neg.out,
via.eQMC = TRUE)
i.sol[[index]]$IC$opts$show.cases <- show.cases
}
else {
i.sol[[index]]$IC <- pof(i.sol.index$reduced$expressions - 1,
outcome, indata, showc = TRUE, cases = expr.cases,
relation = "sufficiency", neg.out = neg.out,
via.eQMC = TRUE, solution.list = i.sol.index$solution.list[[1]],
essential = i.sol.index$solution.list[[2]])
i.sol[[index]]$IC$opts$show.cases <- show.cases
}
i.sol[[index]]$pims <- i.sol[[index]]$IC$pims
i.sol[[index]]$IC$pims <- NULL
index <- index + 1
}
}
output$i.sol <- i.sol
}
# put SAs and ECs in data frames
output$SA <- lapply(output$SA, as.data.frame)
if (any(names(output) == "i.sol")) {
for (i in seq(length(output$i.sol))) {
output$i.sol[[i]]$EC <- as.data.frame(output$i.sol[[i]]$EC)
}
}
if (!is.tt(data)) {
output$tt$outcome <- outcome.copy
}
output$relation <- relation
output$call <- metacall
return(structure(output, class = "qca"))
}
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.