[Qca-commits] r68 - in pkg: . R inst inst/gui/www/js inst/staticdocs man src
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sun Feb 24 15:49:07 CET 2019
Author: dusadrian
Date: 2019-02-24 15:49:07 +0100 (Sun, 24 Feb 2019)
New Revision: 68
Modified:
pkg/DESCRIPTION
pkg/NAMESPACE
pkg/R/causalChain.R
pkg/R/compute.R
pkg/R/factorize.R
pkg/R/getInfo.R
pkg/R/getSolution.R
pkg/R/minimize.R
pkg/R/negate.R
pkg/R/pof.R
pkg/R/print.R
pkg/R/recode.R
pkg/R/simplify.R
pkg/R/superSubset.R
pkg/R/translate.R
pkg/R/truthTable.R
pkg/R/validateNames.R
pkg/R/verifyQCA.R
pkg/inst/ChangeLog
pkg/inst/gui/www/js/maincode.js
pkg/inst/staticdocs/CV.html
pkg/inst/staticdocs/LegacyDatasets.html
pkg/inst/staticdocs/Lipset.html
pkg/inst/staticdocs/QCA.package.html
pkg/inst/staticdocs/RS.html
pkg/inst/staticdocs/SOPexpression.html
pkg/inst/staticdocs/XYplot.html
pkg/inst/staticdocs/Xplot.html
pkg/inst/staticdocs/calibrate.html
pkg/inst/staticdocs/causalChain.html
pkg/inst/staticdocs/chartFunctions.html
pkg/inst/staticdocs/export.html
pkg/inst/staticdocs/factorize.html
pkg/inst/staticdocs/findRows.html
pkg/inst/staticdocs/findTh.html
pkg/inst/staticdocs/fuzzyops.html
pkg/inst/staticdocs/implicantMatrixFunctions.html
pkg/inst/staticdocs/index.html
pkg/inst/staticdocs/intersection.html
pkg/inst/staticdocs/minimize.html
pkg/inst/staticdocs/modelFit.html
pkg/inst/staticdocs/negate.html
pkg/inst/staticdocs/pof.html
pkg/inst/staticdocs/recode.html
pkg/inst/staticdocs/retention.html
pkg/inst/staticdocs/runGUI.html
pkg/inst/staticdocs/subsetsAndSupersets.html
pkg/inst/staticdocs/truthTable.html
pkg/man/QCA.package.Rd
pkg/man/SOPexpression.Rd
pkg/man/factorize.Rd
pkg/man/minimize.Rd
pkg/man/truthTable.Rd
pkg/src/QCA.c
Log:
version 3.4-2, faster function pof()
Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2019-01-28 14:02:39 UTC (rev 67)
+++ pkg/DESCRIPTION 2019-02-24 14:49:07 UTC (rev 68)
@@ -1,6 +1,6 @@
Package: QCA
-Version: 3.4-1
-Date: 2019-01-28
+Version: 3.4-2
+Date: 2019-02-24
Title: Qualitative Comparative Analysis
Authors at R: c(person("Adrian", "Dusa", role = c("aut", "cre", "cph"),
email = "dusa.adrian at unibuc.ro"),
@@ -28,7 +28,7 @@
minimal causal combination that explains a given phenomenon.
License: GPL (>= 2)
NeedsCompilation: yes
-Packaged: 2019-01-28 13:53:26 UTC; dusadrian
+Packaged: 2019-02-24 14:46:25 UTC; dusadrian
Author: Adrian Dusa [aut, cre, cph],
jQuery Foundation [cph] (jQuery library and jQuery UI library),
jQuery contributors [ctb, cph] (jQuery library; authors listed in
Modified: pkg/NAMESPACE
===================================================================
--- pkg/NAMESPACE 2019-01-28 14:02:39 UTC (rev 67)
+++ pkg/NAMESPACE 2019-02-24 14:49:07 UTC (rev 68)
@@ -1,7 +1,7 @@
import(shiny)
import(venn)
import(fastdigest)
-importFrom("utils", "packageDescription", "remove.packages", "capture.output", "data", "loadhistory", "savehistory")
+importFrom("utils", "packageDescription", "remove.packages", "capture.output", "data", "loadhistory", "savehistory", "tail")
importFrom("stats", "glm", "predict", "quasibinomial", "binom.test", "cutree", "dist", "hclust", "na.omit", "dbinom", "setNames")
importFrom("grDevices", "dev.cur", "dev.new", "dev.list")
importFrom("graphics", "abline", "axis", "box", "mtext", "par", "title", "text")
Modified: pkg/R/causalChain.R
===================================================================
--- pkg/R/causalChain.R 2019-01-28 14:02:39 UTC (rev 67)
+++ pkg/R/causalChain.R 2019-02-24 14:49:07 UTC (rev 68)
@@ -41,7 +41,7 @@
allargs$incl.cut <- 0.5
}
verify.qca(data)
- noflevels <- getInfo(data, colnames(data), colnames(data)[1])
+ noflevels <- getLevels(data)
mv <- noflevels > 2
names(noflevels) <- names(mv) <- colnames(data)
if (class(ordering) == "character") {
Modified: pkg/R/compute.R
===================================================================
--- pkg/R/compute.R 2019-01-28 14:02:39 UTC (rev 67)
+++ pkg/R/compute.R 2019-02-24 14:49:07 UTC (rev 68)
@@ -24,7 +24,7 @@
# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
`compute` <-
-function(expression = "", data, separate = FALSE) {
+function(expression = "", data = NULL, separate = FALSE) {
expression <- gsub("[[:space:]]", "", expression)
enchar <- nchar(expression)
if (identical(substring(expression, 1, 2), "~(") & identical(substring(expression, enchar, enchar), ")")) {
@@ -32,7 +32,7 @@
}
negated <- identical(unname(substring(expression, 1, 2)), "1-")
expression <- gsub("1-", "", expression)
- if (missing(data)) {
+ if (is.null(data)) {
syscalls <- parse(text = paste(unlist(lapply(sys.calls(), deparse)), collapse = "\n"))
if (any(withdata <- grepl("with\\(", syscalls))) {
withdata <- which(withdata)
@@ -40,7 +40,7 @@
data <- get(unlist(strsplit(gsub("with\\(", "", syscalls[withdata]), split = ","))[1], envir = length(syscalls) - withdata)
}
else {
- colnms <- validateNames(notilde(expression), sort(toupper(eval.parent(parse(text = "ls()", n = 1)))))
+ colnms <- colnames(validateNames(notilde(expression), sort(toupper(eval.parent(parse(text = "ls()", n = 1))))))
data <- vector(mode = "list", length = length(colnms))
for (i in seq(length(data))) {
data[[i]] <- eval.parent(parse(text = sprintf("get(\"%s\")", colnms[i]), n = 1))
Modified: pkg/R/factorize.R
===================================================================
--- pkg/R/factorize.R 2019-01-28 14:02:39 UTC (rev 67)
+++ pkg/R/factorize.R 2019-02-24 14:49:07 UTC (rev 68)
@@ -24,7 +24,7 @@
# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
`factorize` <-
-function(input, snames = "", noflevels, pos = FALSE, use.tilde = FALSE, ...) {
+function(input, snames = "", noflevels = NULL, pos = FALSE, use.tilde = FALSE, ...) {
other.args <- list(...)
if (any(names(other.args) == "tilde")) {
use.tilde <- other.args$tilde
Modified: pkg/R/getInfo.R
===================================================================
--- pkg/R/getInfo.R 2019-01-28 14:02:39 UTC (rev 67)
+++ pkg/R/getInfo.R 2019-02-24 14:49:07 UTC (rev 68)
@@ -56,7 +56,7 @@
return(x[x < 0])
}
else {
- return(as.character(x[x %in% c("-", "dc")]))
+ return(as.character(x[is.element(x, c("-", "dc"))]))
}
})))
if (length(dc.code) == 0) {
@@ -67,11 +67,11 @@
stop(simpleError("Multiple \"Don't care\" codes found.\n\n"))
}
colnms <- colnames(data)
- data <- as.data.frame(lapply(data, function(x) {
+ data[] <- lapply(data, function(x) {
x <- as.character(x)
x[x == dc.code] <- -1
return(asNumeric(x))
- }))
+ })
colnames(data) <- colnms
data[data < 0] <- -1
fuzzy.cc <- apply(data[, conditions, drop = FALSE], 2, function(x) {
@@ -97,8 +97,5 @@
noflevels[noflevels == 1] <- 2
noflevels[fuzzy.cc] <- 2
noflevels <- as.integer(noflevels)
- if (length(conditions) == ncol(data)) {
- return(noflevels)
- }
return(list(data = data, fuzzy.cc = fuzzy.cc, hastime = hastime, dc.code = dc.code, noflevels = as.numeric(noflevels)))
}
Modified: pkg/R/getSolution.R
===================================================================
--- pkg/R/getSolution.R 2019-01-28 14:02:39 UTC (rev 67)
+++ pkg/R/getSolution.R 2019-02-24 14:49:07 UTC (rev 68)
@@ -99,6 +99,7 @@
tokeep <- sort(unique(as.vector(unique(sol.matrix))))
all.PIs <- rownames(mtrx)[tokeep]
solm <- sol.matrix
+ sol.matrix[sol.matrix == 0] <- NA
sol.matrix <- matrix(rownames(mtrx)[sol.matrix], nrow = nrow(sol.matrix))
reduced$expressions <- reduced$expressions[tokeep, , drop = FALSE]
solution.list <- writeSolution(sol.matrix, mtrx)
Modified: pkg/R/minimize.R
===================================================================
--- pkg/R/minimize.R 2019-01-28 14:02:39 UTC (rev 67)
+++ pkg/R/minimize.R 2019-02-24 14:49:07 UTC (rev 68)
@@ -127,18 +127,11 @@
outcome <- toupper(outcome)
outcome.copy <- outcome
indata <- input
- if (tilde1st(outcome)) {
- neg.out <- TRUE
- outcome <- substring(outcome, 2)
- }
- if (!is.element(toupper(curlyBrackets(outcome, outside = TRUE)), colnames(input))) {
+ if (!is.element(toupper(curlyBrackets(notilde(outcome), outside = TRUE)), colnames(input))) {
cat(enter)
stop(simpleError(paste0("Inexisting outcome name.", enter, enter)))
}
- outcome.name <- ifelse (tilde1st(outcome), substring(outcome, 2), outcome)
- if (grepl("\\{|\\}", outcome)) {
- outcome.name <- curlyBrackets(outcome.name, outside = TRUE)
- }
+ outcome.name <- curlyBrackets(notilde(outcome), outside = TRUE)
if (identical(conditions, "")) {
conditions <- names(input)[-which(names(input) == outcome.name)]
}
@@ -367,19 +360,18 @@
conds <- conditions[match(colnames(p.sol$reduced$expressions), LETTERS)]
}
}
- if (length(output$solution) == 1) {
- listIC <- pof(p.sol$reduced$expressions - 1, tt$options$outcome, indata, showc=TRUE, cases=expr.cases, neg.out=neg.out,
- relation = "sufficiency", conditions = conds)
- listIC$options$show.cases <- show.cases
+ poflist <- list(setms = paste(rownames(p.sol$reduced$expressions), collapse = "+"),
+ outcome = tt$options$outcome, data = indata, neg.out = neg.out,
+ use.letters = tt$options$use.letters, show.cases = TRUE, cases = expr.cases,
+ conditions = conds, relation = "sufficiency", minimize = TRUE)
+ if (length(output$solution) > 1) {
+ poflist$solution.list <- output$solution
+ poflist$essential <- output$essential
}
- else {
- listIC <- pof(p.sol$reduced$expressions - 1, tt$options$outcome, indata, showc=TRUE, cases=expr.cases, neg.out=neg.out,
- relation = "sufficiency", conditions = conds, solution.list=output$solution, essential=output$essential)
- listIC$options$show.cases <- show.cases
- }
+ listIC <- do.call("pof", poflist)
+ listIC$options$show.cases <- show.cases
output$pims <- listIC$pims
- attr(output$pims, "conditions") <- conds
- listIC$pims <- NULL
+ attr(output$pims, "conditions") <- conditions
output$IC <- listIC
output$numbers <- c(OUT1 = nofcases1, OUT0 = nofcases0, OUTC = nofcasesC, Total = nofcases1 + nofcases0 + nofcasesC)
mtrx <- p.sol$mtrx[p.sol$all.PIs, , drop = FALSE]
@@ -422,16 +414,29 @@
prettyNums <- formatC(seq(length(p.sol$solution.list[[1]])), digits = nchar(length(p.sol$solution.list[[1]])) - 1, flag = 0)
if (!identical(dir.exp, "") & !identical(include, "") & !identical(c.sol$solution.list, NA)) {
dir.exp <- verify.dir.exp(recdata, outcome, conditions, noflevels, dir.exp)
- EClist <- .Call("C_getEC", dir.exp, c.sol$expressions, c.sol$sol.matrix, p.sol$expressions, p.sol$sol.matrix, output$SA, PACKAGE = "QCA")
+ if (!is.null(output$SA[[1]])) {
+ EClist <- .Call("C_getEC", dir.exp, c.sol$expressions, c.sol$sol.matrix, p.sol$expressions, p.sol$sol.matrix, output$SA, PACKAGE = "QCA")
+ }
+ else {
+ ECmat <- as.data.frame(matrix(ncol = length(conditions), nrow = 0))
+ colnames(ECmat) <- colnames(inputt)
+ }
i.sol <- vector("list", ncol(c.sol$sol.matrix)*ncol(p.sol$sol.matrix))
index <- 1
for (c.s in seq(ncol(c.sol$sol.matrix))) {
for (p.s in seq(ncol(p.sol$sol.matrix))) {
names(i.sol)[index] <- paste("C", c.s, "P", p.s, sep = "")
- i.sol[[index]]$EC <- EClist[[index]]
- i.sol[[index]]$DC <- output$SA[[p.s]][setdiff(rownames(output$SA[[p.s]]), rownames(EClist[[index]])), , drop = FALSE]
- i.sol[[index]]$NSEC <- matrix(ncol = ncol(EClist[[index]]), nrow = 0)
- colnames(i.sol[[index]]$NSEC) <- colnames(EClist[[index]])
+ if (is.null(output$SA[[1]])) {
+ i.sol[[index]]$EC <- ECmat
+ i.sol[[index]]$DC <- ECmat
+ i.sol[[index]]$NSEC <- ECmat
+ }
+ else {
+ i.sol[[index]]$EC <- EClist[[index]]
+ i.sol[[index]]$DC <- output$SA[[p.s]][setdiff(rownames(output$SA[[p.s]]), rownames(EClist[[index]])), , drop = FALSE]
+ i.sol[[index]]$NSEC <- matrix(ncol = ncol(EClist[[index]]), nrow = 0)
+ colnames(i.sol[[index]]$NSEC) <- colnames(EClist[[index]])
+ }
nsecs <- TRUE
while (nsecs) {
pos.matrix.i.sol <- unique(rbind(pos.matrix, i.sol[[index]]$EC + 1))
@@ -452,7 +457,7 @@
}
}
pos.matrix.i.sol <- pos.matrix.i.sol[!tomit, , drop = FALSE]
- expressions <- .Call("C_QMC", pos.matrix.i.sol, noflevels, PACKAGE = "QCA")
+ expressions <- .Call("C_QMC", as.matrix(pos.matrix.i.sol), noflevels, PACKAGE = "QCA")
i.sol.index <- getSolution(expressions=expressions, mv=mv, use.tilde=use.tilde, collapse=collapse, inputt=inputt, row.dom=row.dom, initial=rownms, all.sol=all.sol, indata=indata, ...=...)
i.sol.index$expressions <- i.sol.index$expressions[rowSums(i.sol.index$mtrx) > 0, , drop = FALSE]
if (nrow(i.sol[[index]]$EC) > 0) {
@@ -504,18 +509,16 @@
for (l in seq(length(expr.cases))) {
expr.cases[l] <- paste(inputcases[which(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,
- conditions = conditions)
- i.sol[[index]]$IC$options$show.cases <- show.cases
+ poflist <- list(setms = paste(rownames(i.sol.index$reduced$expressions), collapse = "+"),
+ outcome = tt$options$outcome, data = indata, neg.out = neg.out,
+ use.letters = tt$options$use.letters, show.cases = TRUE, cases = expr.cases,
+ conditions = conditions, relation = "sufficiency", minimize = TRUE)
+ if (length(i.sol.index$solution.list[[1]]) > 1) {
+ poflist$solution.list <- i.sol.index$solution.list[[1]]
+ poflist$essential <- i.sol.index$solution.list[[2]]
}
- 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, conditions = conditions,
- solution.list = i.sol.index$solution.list[[1]], essential = i.sol.index$solution.list[[2]])
- i.sol[[index]]$IC$options$show.cases <- show.cases
- }
+ i.sol[[index]]$IC <- do.call("pof", poflist)
+ i.sol[[index]]$IC$options$show.cases <- show.cases
i.sol[[index]]$pims <- i.sol[[index]]$IC$pims
attr(i.sol[[index]]$pims, "conditions") <- conditions
i.sol[[index]]$IC$pims <- NULL
Modified: pkg/R/negate.R
===================================================================
--- pkg/R/negate.R 2019-01-28 14:02:39 UTC (rev 67)
+++ pkg/R/negate.R 2019-02-24 14:49:07 UTC (rev 68)
@@ -48,13 +48,23 @@
}
if (is.character(expression)) {
star <- any(grepl("[*]", expression))
+ if (!identical(snames, "")) {
+ snames <- splitstr(snames)
+ if (any(nchar(snames) > 1)) {
+ star <- TRUE
+ }
+ }
if (any(hastilde(expression))) {
use.tilde <- TRUE
}
mv <- any(grepl("[{|}]", expression))
+ if (mv) start <- FALSE
negateit <- function(x, snames, noflevels) {
- x <- simplify(x, snames = snames, noflevels = noflevels)
- trexp <- translate(x, snames = snames, noflevels = noflevels)
+ callist <- list(expression = x)
+ if (!missing(snames)) callist$snames <- snames
+ if (!missing(noflevels)) callist$noflevels <- noflevels
+ x <- do.call("simplify", callist)
+ trexp <- do.call("translate", callist)
snames <- colnames(trexp)
if (missing(noflevels)) {
noflevels <- rep(2, ncol(trexp))
Modified: pkg/R/pof.R
===================================================================
--- pkg/R/pof.R 2019-01-28 14:02:39 UTC (rev 67)
+++ pkg/R/pof.R 2019-02-24 14:49:07 UTC (rev 68)
@@ -26,94 +26,16 @@
`pof` <-
function(setms, outcome, data, relation = "necessity", inf.test = "",
incl.cut = c(0.75, 0.5), add = NULL, ...) {
- funargs <- lapply(match.call(), deparse)
+ funargs <- lapply(lapply(match.call(), deparse)[-1], function(x) gsub("\"|[[:space:]]", "", x))
other.args <- list(...)
- conds <- ""
- condnegated <- NULL
- if (inherits(tryCatch(eval(setms), error = function(e) e), "error")) {
- setms <- funargs$setms
- toverify <- gsub("1-", "", gsub("[[:space:]]", "", notilde(setms)))
- toverify <- unique(unlist(lapply(strsplit(toverify, split = "[+]"), strsplit, split = "[*]")))
- if (!all(found <- is.element(toupper(toverify), toupper(eval.parent(parse(text = "ls()", n = 1)))))) {
- cat("\n")
- stop(simpleError(sprintf("Object '%s' not found.\n\n", toverify[which(!found)[1]])))
- }
+ if (missing(setms)) {
+ cat("\n")
+ stop(simpleError("The \"setms\" argument is missing.\n\n"))
}
- else {
- if (grepl("coms|pims", funargs$setms)) {
- toverify <- notilde(gsub("1-", "", gsub("[[:space:]]", "", funargs$setms)))
- if (grepl("[$]", toverify)) {
- toverify <- unlist(strsplit(toverify, split = "\\$"))[1]
- if (grepl("pims", funargs$setms)) {
- tt <- eval.parent(parse(text = sprintf("%s$tt", toverify)))
- conds <- tt$options$conditions
- if (tt$options$use.letters) {
- conds <- LETTERS[seq(length(conds))]
- }
- }
- else {
- conds <- eval.parent(parse(text = sprintf("%s$options$conditions", toverify)))
- }
- }
- }
+ if (!(nec(relation) | suf(relation))) {
+ cat("\n")
+ stop(simpleError("The relation should be either \"necessity\" or \"sufficiency\".\n\n"))
}
- missingdata <- missing(data)
- if (is.character(setms)) {
- if (setms == tolower(setms) & setms != toupper(setms)) {
- if (eval.parent(parse(text = sprintf("is.element(\"%s\", ls())", toupper(setms))), n = 1)) {
- conds <- toupper(setms)
- setms <- eval.parent(parse(text = sprintf("get(\"%s\")", toupper(setms))), n = 1)
- setms <- QCA::getLevels(setms) - setms - 1
- condnegated <- TRUE
- }
- }
- }
- else {
- if (inherits(testit <- tryCatch(eval(setms), error = function(e) e), "error")) {
- setms <- deparse(funargs$setms)
- }
- else {
- testit <- capture.output(testit)
- if (is.character(testit) & length(testit) == 1) {
- if (hastilde(testit)) {
- if (eval.parent(parse(text = sprintf("is.element(\"%s\", ls())", notilde(testit))), n = 1)) {
- setms <- eval.parent(parse(text = sprintf("get(\"%s\")", notilde(testit))), n = 1)
- setms <- QCA::getLevels(setms) - setms - 1
- condnegated <- TRUE
- }
- else {
- setms <- testit
- }
- }
- }
- }
- }
- outcomename <- ""
- outnegated <- NULL
- if (inherits(tryCatch(eval(outcome), error = function(e) e), "error")) {
- outcome <- funargs$outcome
- }
- if (!is.character(outcome)) {
- testit <- tryCatch(eval(outcome), error = function(e) e)
- if (inherits(testit, "error")) {
- outcome <- deparse(funargs$outcome)
- }
- else {
- testit <- capture.output(testit)
- if (is.character(testit) & length(testit) == 1) {
- if (hastilde(testit)) {
- if (eval.parent(parse(text = sprintf("is.element(\"%s\", ls())", notilde(testit))), n = 1)) {
- outcome <- eval.parent(parse(text = sprintf("get(\"%s\")", notilde(testit))), n = 1)
- outcome <- QCA::getLevels(outcome) - outcome - 1
- outnegated <- TRUE
- }
- else {
- outcome <- testit
- }
- }
- }
- }
- }
icp <- 0.75
ica <- 0.5
if (is.character(incl.cut) & length(incl.cut) == 1) {
@@ -124,538 +46,345 @@
ica <- incl.cut[2]
}
neg.out <- FALSE
- if ("neg.out" %in% names(other.args)) {
+ if (is.element("neg.out", names(other.args))) {
neg.out <- other.args$neg.out
}
- if ("incl.cut1" %in% names(other.args) & identical(icp, 0.75)) {
+ if (is.element("incl.cut1", names(other.args)) & identical(icp, 0.75)) {
icp <- other.args$incl.cut1
}
- if ("incl.cut0" %in% names(other.args) & identical(ica, 0.5)) {
+ if (is.element("incl.cut0", names(other.args)) & identical(ica, 0.5)) {
ica <- other.args$incl.cut0
}
- syscalls <- unlist(lapply(lapply(sys.calls(), as.character), "[[", 1))
- force.rows <- is.element("force.rows", names(other.args))
- if (is.null(outnegated)) {
- outnegated <- identical(substr(gsub("[[:space:]]", "", funargs$outcome), 1, 2), "1-")
+ complete <- FALSE
+ if (is.element("complete", names(other.args))) {
+ if (is.logical(other.args$complete)) {
+ complete <- other.args$complete
+ }
}
- if (is.null(condnegated)) {
- condnegated <- identical(substr(gsub("[[:space:]]", "", funargs$setms), 1, 2), "1-")
- }
- fuzzyop <- FALSE
- if (is.element("Recall", syscalls)) {
- mins <- other.args$mins
- outcome <- other.args$vo
- sum.outcome <- other.args$so
- pims <- other.args$pims
- incl.cov <- matrix(nrow = ncol(mins), ncol = 4)
- }
- else {
- outcomename <- "Y"
- if (!missing(data)) {
- if (is.matrix(data)) {
- data <- as.data.frame(data)
- }
- if (is.element("data.frame", class(data))) {
- data <- as.data.frame(data)
- }
- colnames(data) <- toupper(colnames(data))
- for (i in colnames(data)) {
- if (!is.numeric(data[, i])) {
- if (possibleNumeric(data[, i])) {
- data[, i] <- asNumeric(data[, i])
- }
+ if (!is.null(funargs$data)) {
+ if (is.matrix(data)) {
+ data <- as.data.frame(data)
+ }
+ if (is.element("data.frame", class(data))) {
+ data <- as.data.frame(data)
+ }
+ colnames(data) <- toupper(colnames(data))
+ for (i in colnames(data)) {
+ if (!is.numeric(data[, i])) {
+ if (possibleNumeric(data[, i])) {
+ data[, i] <- asNumeric(data[, i])
}
}
}
- if (is.element("character", class(setms))) {
- if (length(setms) == 1) {
- if (missing(data)) {
- syscalls <- unlist(lapply(sys.calls(), deparse))
- if (any(withdata <- grepl("with\\(", syscalls))) {
- data <- get(unlist(strsplit(gsub("with\\(", "", syscalls), split = ","))[1], envir = length(syscalls) - which(withdata))
- }
- else {
- toverify <- gsub("1-", "", gsub("[[:space:]]", "", notilde(setms)))
- if (all(is.character(outcome)) & length(outcome) == 1) {
- toverify <- paste(toverify, notilde(outcome), sep = "*")
- }
- colnms <- validateNames(gsub("<|=|>", "", toverify), sort(toupper(eval.parent(parse(text = "ls()", n = 1)))))
- data <- vector(mode = "list", length = length(colnms))
- for (i in seq(length(data))) {
- data[[i]] <- eval.parent(parse(text = sprintf("get(\"%s\")", colnms[i]), n = 1))
- }
- if (length(unique(unlist(lapply(data, length)))) > 1) {
- cat("\n")
- stop(simpleError("Objects should be vectors of the same length.\n\n"))
- }
- names(data) <- colnms
- data <- as.data.frame(data)
- }
+ if (is.element("minimize", names(other.args))) {
+ if (is.element("use.letters", names(other.args))) {
+ if (other.args$use.letters) {
+ colnames(data)[seq(1, ncol(data) - 1)] <- LETTERS[seq(1, ncol(data) - 1)]
}
- expression <- setms
- if (grepl("<=>", expression)) {
- cat("\n")
- stop(simpleError("Incorrect expression: relation can only be => or <=.\n\n"))
- }
- multivalue <- grepl("[{|}]", expression)
- conditions <- colnames(data)
- if (missing(outcome)) {
- outcome <- ""
- }
- expression <- unlist(strsplit(expression, split = "<="))
- if (length(expression) == 1) {
- expression <- unlist(strsplit(expression, split = "=>"))
- if (length(expression) > 1) {
- relation <- "suf"
- outcome <- trimstr(expression[2])
- expression <- trimstr(expression[1])
- }
- }
- else {
- outcome <- trimstr(expression[2])
- expression <- trimstr(expression[1])
- }
- if (identical(outcome, "")) {
- cat("\n")
- stop(simpleError("Expression without outcome.\n\n"))
- }
- else {
- if (is.character(outcome)) {
- conditions <- setdiff(conditions, outcome)
- if (!is.element(toupper(notilde(curlyBrackets(outcome, outside = TRUE))), colnames(data))) {
- cat("\n")
- stop(simpleError("The outcome in the expression is not found in the data.\n\n"))
- }
- }
- }
- if (is.character(outcome)) {
- if (tilde1st(outcome)) {
- neg.out <- TRUE
- outcome <- notilde(outcome)
- }
- if (grepl("[{|}]", outcome)) {
- outcome.value <- curlyBrackets(outcome)
- outcome <- curlyBrackets(outcome, outside=TRUE)
- data[, toupper(outcome)] <- as.numeric(data[, toupper(outcome)] %in% splitstr(outcome.value))
- }
- else if (!is.element(outcome, colnames(data))) {
- if (!is.element(outcome, c(tolower(outcome), toupper(outcome)))) {
- cat("\n")
- stop(simpleError("The outcome name should not contain both lower and upper case letters.\n\n"))
- }
- data[, toupper(outcome)] <- QCA::getLevels(data[, toupper(outcome)]) - data[, toupper(outcome)] - 1
- }
- outcome <- toupper(outcome)
- }
- complete <- FALSE
- if (is.element("complete", names(other.args))) {
- if (is.logical(other.args$complete)) {
- complete <- other.args$complete
- }
- }
- if (is.character(outcome)) {
- verify.qca(data[, which(colnames(data) == outcome), drop = FALSE])
- data2 <- data[, -which(colnames(data) == outcome), drop = FALSE]
- texp <- translate(expression, data = data2)
- data2 <- data2[, apply(texp, 2, function(x) any(x >= 0)), drop = FALSE]
- verify.qca(data2)
- setms <- compute(expression, data2, separate = TRUE)
- if (is.data.frame(setms)) {
- setms$expression <- compute(expression, data2)
- }
- else {
- setms <- setNames(as.data.frame(setms), expression)
- }
- }
- else {
- texp <- translate(expression, data = data)
- data <- data[, apply(texp, 2, function(x) any(x >= 0)), drop = FALSE]
- verify.qca(data)
- setms <- compute(expression, data, separate = TRUE)
- if (is.data.frame(setms)) {
- setms$expression <- compute(expression, data)
- }
- else {
- setms <- setNames(as.data.frame(setms), expression)
- }
- }
- fuzzyop <- TRUE
}
- else {
- cat("\n")
- stop(simpleError("Only one expression allowed.\n\n"))
- }
}
- error <- FALSE
- if (all(is.character(outcome)) & length(outcome) == 1) {
- if (missing(data)) {
- cat("\n")
- stop(simpleError("The data argument is missing, with no default.\n\n"))
+ }
+ conditions <- outcomename <- ""
+ condnegated <- outnegated <- FALSE
+ `extract` <- function(x, snames = "", data = NULL) {
+ if (grepl("<=>", x)) {
+ cat("\n")
+ stop(simpleError("Incorrect expression: relation can only be '=>' or '<='.\n\n"))
+ }
+ multivalue <- grepl("[{|}]", x)
+ relation <- ifelse(grepl("=", x), ifelse(grepl("=>", x), "suf", "nec"), NA)
+ x <- gsub("<=|=>", "@", gsub("[[:space:]]", "", x))
+ x <- unlist(strsplit(x, split = "@"))
+ if (identical(substring(x[1], 1, 2), "1-")) {
+ x[1] <- negate(gsub("1-", "", x[1]), snames = snames)
+ }
+ outmtrx <- NA
+ if (length(x) > 1) {
+ outmtrx <- validateNames(x[2], snames = snames, data = data)
+ }
+ if (!is.na(outmtrx) & !is.null(data)) {
+ data <- data[, -which(is.element(colnames(data), colnames(outmtrx)))]
+ }
+ condmtrx <- validateNames(x[1], snames = snames, data = data)
+ return(list(condmtrx = condmtrx, outmtrx = outmtrx, expression = x[1],
+ relation = relation, multivalue = multivalue))
+ }
+ `error` <- function(x, type = 1) {
+ cat("\n")
+ if (type == 1) {
+ stop(simpleError("Complex expressions should be quoted.\n\n"))
+ }
+ else if (type == 2) {
+ stop(simpleError(sprintf("Object '%s' not found.\n\n", x)))
+ }
+ else if (type == 3) {
+ stop(simpleError(sprintf("Incorrect specification of '%s'.\n\n", x)))
+ }
+ else if (type == 4) {
+ if (grepl("$", x)) {
+ x <- unlist(strsplit(x, split = "[$]"))
+ x <- tail(x, 1)
}
- else {
- outcome <- toupper(outcome)
- if (tilde1st(outcome)) {
- neg.out <- TRUE
- outcome <- notilde(outcome)
- }
- if (identical(substr(gsub("[[:space:]]|\"", "", funargs$outcome), 1, 2), "1-")) {
- neg.out <- TRUE
- outcome <- gsub("1-", "", gsub("[[:space:]]|\"", "", funargs$outcome))
- }
- if (!is.element(toupper(curlyBrackets(outcome, outside = TRUE)), colnames(data))) {
- cat("\n")
- stop(simpleError("Inexisting outcome name.\n\n"))
- }
- if (grepl("[{|}]", outcome)) {
- outcome.value <- curlyBrackets(outcome)
- outcome <- curlyBrackets(outcome, outside=TRUE)
- data[, toupper(outcome)] <- is.element(data[, toupper(outcome)], splitstr(outcome.value)) * 1
- }
- outcomename <- toupper(outcome)
- outcome <- data[, outcomename]
- }
+ stop(simpleError(sprintf("Invalid entry: '%s'.\n\n", x)))
}
- else if (is.vector(outcome)) {
- verify.qca(outcome)
- if (!inherits(tc <- tryCatch(getName(funargs$outcome), error = function(e) e), "error")) {
- outcomename <- tc
- }
+ else if (type == 5) {
+ stop(simpleError("Tilde negation should be quoted.\n\n"))
}
- else {
- cat("\n")
- stop(simpleError("The outcome should be either a column name in a dataset\n or a vector of set membership values.\n\n"))
+ else if (type == 6) {
+ stop(simpleError("The data argument is missing, with no default.\n\n"))
}
- if (!(nec(relation) | suf(relation))) {
- cat("\n")
- stop(simpleError("The relationship should be either \"necessity\" or \"sufficiency\".\n\n"))
+ }
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/qca -r 68
More information about the Qca-commits
mailing list