[Qca-commits] r49 - in pkg: . R data inst/staticdocs man src
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Jul 20 14:47:27 CEST 2018
Author: dusadrian
Date: 2018-07-20 14:47:26 +0200 (Fri, 20 Jul 2018)
New Revision: 49
Removed:
pkg/R/base3rows.R
pkg/R/createChart.R
pkg/R/createString.R
pkg/R/deMorgan.R
pkg/R/demoChart.R
pkg/R/eqmcc.R
pkg/R/eqmccLoop.R
pkg/R/is.print.R
pkg/R/superSubsetOld.R
pkg/data/d.AS.tab
pkg/data/d.BWB.tab
pkg/data/d.Bas.tab
pkg/data/d.CS.tab
pkg/data/d.CZH.tab
pkg/data/d.Emm.tab
pkg/data/d.HMN.tab
pkg/src/allSol.c
pkg/src/m2.c
pkg/src/removeRedundants.c
pkg/src/solveChart.c
pkg/src/superSubset.c
pkg/tests/
Modified:
pkg/DESCRIPTION
pkg/inst/staticdocs/QCA.package.html
pkg/man/QCA.package.Rd
Log:
version 3.3
Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2018-07-20 08:26:24 UTC (rev 48)
+++ pkg/DESCRIPTION 2018-07-20 12:47:26 UTC (rev 49)
@@ -1,6 +1,6 @@
Package: QCA
Version: 3.3
-Date: 2018-07-14
+Date: 2018-07-20
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: 2018-07-14 04:11:31 UTC; dusadrian
+Packaged: 2018-07-20 12:36:49 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
Deleted: pkg/R/base3rows.R
===================================================================
--- pkg/R/base3rows.R 2018-07-20 08:26:24 UTC (rev 48)
+++ pkg/R/base3rows.R 2018-07-20 12:47:26 UTC (rev 49)
@@ -1,15 +0,0 @@
-base3rows <- function(nofconditions) {
- multiplier <- 0
- gap <- NULL
- for (i in 2:nofconditions) {
- multiplier <- 3*multiplier + 1
- gap <- c(gap, multiplier, gap)
- }
-
- linejump <- (3^nofconditions + 1)/2
- rownums <- c(linejump, sapply(gap, function(jump) {
- linejump <<- linejump + jump + 2
- }))
- return(sort(c(rownums, rownums + 1)))
-}
-
Deleted: pkg/R/createChart.R
===================================================================
--- pkg/R/createChart.R 2018-07-20 08:26:24 UTC (rev 48)
+++ pkg/R/createChart.R 2018-07-20 12:47:26 UTC (rev 49)
@@ -1,23 +0,0 @@
-`createChart` <-
-function (input, copyinput, rows, cols) {
- input2 <- matrix(logical(length(input)), dim(input))
- input2[input > 0] <- TRUE
-
- result <- sapply(seq(nrow(input)), function(x) {
- apply(copyinput, 1, function(y) {
- all(input[x, input2[x,]] == y[input2[x,]])
- })
- })
-
- if (nrow(copyinput) == 1) {
- result <- matrix(result)
- }
- else {
- result <- t(result)
- }
-
- if (!missing(rows)) rownames(result) <- rows
- if (!missing(cols)) colnames(result) <- cols
- return(result)
-}
-
Deleted: pkg/R/createString.R
===================================================================
--- pkg/R/createString.R 2018-07-20 08:26:24 UTC (rev 48)
+++ pkg/R/createString.R 2018-07-20 12:47:26 UTC (rev 49)
@@ -1,26 +0,0 @@
-`createString` <-
-function(mydata, collapse="*", uplow=FALSE, use.tilde=FALSE) {
- mydata <- changemydata <- as.matrix(mydata)
- conditions <- colnames(mydata)
- if (uplow) {
- changemydata[mydata == 0] <- tolower(rep(conditions, each=nrow(mydata))[mydata == 0])
- changemydata[mydata == 1] <- toupper(rep(conditions, each=nrow(mydata))[mydata == 1])
- }
- else if (use.tilde) {
- changemydata[mydata == 0] <- paste("~", toupper(rep(conditions, each=nrow(mydata))[mydata == 0]), sep="")
- changemydata[mydata == 1] <- toupper(rep(conditions, each=nrow(mydata))[mydata == 1])
- }
- else {
- for (i in sort(unique(as.vector(mydata)))) {
- changemydata[mydata == i] <- paste(rep(conditions, each=nrow(mydata))[mydata == i], "{", i, "}", sep="")
- }
- }
-
- input <- rep(NA, nrow(mydata))
-
- for (i in 1:nrow(mydata)) {
- input[i] <- paste(changemydata[i, ], collapse = collapse)
- }
- return(input)
-}
-
Deleted: pkg/R/deMorgan.R
===================================================================
--- pkg/R/deMorgan.R 2018-07-20 08:26:24 UTC (rev 48)
+++ pkg/R/deMorgan.R 2018-07-20 12:47:26 UTC (rev 49)
@@ -1,523 +0,0 @@
-`deMorgan` <-
-function(expression, prod.split = "", use.tilde = FALSE) {
-
- # print("bla")
-
- # TO DO: capture and error the usage of both "cD" and "D*E" in the same expression
-
-
- # STRUCTURE of the big.list
-
- # level 1: split by separate components
- # "A + B(C + D*~E)" has two components "A" and "B(C + D*~E)"
-
- # level 2: split by brackets
- # "B(C + D*~E)" has "B" and "C + D*~E"
-
- # level 3: split by "+"
- # "C + D*~E" has "C" and "D*~E"
-
- # level 4: split by "*"
- # "D*~E" has "D" and "~E"
-
- # level 5: split by "~" (the result is only a vector, not a list)
- # "~E" has "~" and "E"
-
-
- # big.list <- splitMainComponents(expression)
- # big.list <- splitBrackets(big.list)
- # big.list <- removeSingleStars(big.list)
- # big.list <- splitPluses(big.list)
- # big.list <- splitStars(big.list)
- # big.list <- splitTildas(big.list)
- # big.list <- solveBrackets(big.list)
- # big.list <- simplifyList(big.list)
-
- if (class(expression) == "deMorgan") {
- expression <- paste(expression[[1]][[2]], collapse = " + ")
- }
-
- splitMainComponents <- function(expression) {
- ind.char <- unlist(strsplit(expression, split=""))
-
- # remove all spaces (or white space)
- ind.char <- ind.char[ind.char != " "]
-
- if (grepl("\\(", expression)) {
- # split the string in individual characters
-
- open.brackets <- which(ind.char == "(")
- closed.brackets <- which(ind.char == ")")
-
- invalid <- ifelse(grepl("\\)", expression), length(open.brackets) != length(closed.brackets), FALSE)
-
- if (invalid) {
- cat("\n")
- stop("Invalid expression, open bracket \"(\" not closed with \")\".\n\n", call. = FALSE)
- }
-
-
- all.brackets <- sort(c(open.brackets, closed.brackets))
-
- if (length(all.brackets) > 2) {
- for (i in seq(3, length(all.brackets))) {
- if (all.brackets[i] - all.brackets[i - 1] == 1) {
- open.brackets <- setdiff(open.brackets, all.brackets[seq(i - 1, i)])
- closed.brackets <- setdiff(closed.brackets, all.brackets[seq(i - 1, i)])
- }
-
- if (all.brackets[i] - all.brackets[i - 1] == 2) {
- if (ind.char[all.brackets[i] - 1] != "+") {
- open.brackets <- setdiff(open.brackets, all.brackets[seq(i - 1, i)])
- closed.brackets <- setdiff(closed.brackets, all.brackets[seq(i - 1, i)])
- }
- }
- }
- }
-
- for (i in seq(length(open.brackets))) {
- plus.signs <- which(ind.char == "+")
- last.plus.sign <- plus.signs[plus.signs < open.brackets[i]]
- if (length(last.plus.sign) > 0) {
- open.brackets[i] <- max(last.plus.sign) + 1
- }
- else {
- if (1 == 1) {
- open.brackets[i] <- 1
- }
- }
- next.plus.sign <- plus.signs[plus.signs > closed.brackets[i]]
- if(length(next.plus.sign) > 0) {
- closed.brackets[i] <- min(next.plus.sign) - 1
- }
- else {
- closed.brackets[i] <- length(ind.char)
- }
- }
-
- # create an empty list with at least 3 times as many components as number of open brackets (just to make sure I have enough)
- big.list <- vector(mode="list", length = length(open.brackets) + 2)
-
- if (length(open.brackets) == 1) {
- # there is only one open bracket
- if (open.brackets > 1) {
- # there's something before that open bracket
- big.list[[1]] <- paste(ind.char[seq(1, open.brackets - 2)], collapse = "")
- }
- nep <- min(which(unlist(lapply(big.list, is.null))))
- big.list[[nep]] <- paste(ind.char[seq(open.brackets, closed.brackets)], collapse = "")
- if (closed.brackets < length(ind.char)) {
- # there is something beyond the closed bracket
- nep <- min(which(unlist(lapply(big.list, is.null))))
- big.list[[nep]] <- paste(ind.char[seq(closed.brackets + 2, length(ind.char))], collapse = "")
- }
- }
- else {
- for (i in seq(length(open.brackets))) {
- if (i == 1) {
- # check if there's anything meaningful before the FIRST bracket
- # i.e. containing a "+" sign, like "A + B(C + D)"
- # before the first bracket is "A + B", but only B should be multiplied with "C + D"
-
- if (open.brackets[1] > 1) {
- # there is something before the first bracket
- big.list[[1]] <- paste(ind.char[seq(1, open.brackets[1] - 2)], collapse = "")
- }
-
- nep <- min(which(unlist(lapply(big.list, is.null))))
- big.list[[nep]] <- paste(ind.char[seq(open.brackets[i], closed.brackets[i])], collapse = "")
-
- }
- else {
- nep <- min(which(unlist(lapply(big.list, is.null))))
- big.list[[nep]] <- paste(ind.char[seq(open.brackets[i], closed.brackets[i])], collapse = "")
-
- if (i == length(closed.brackets)) {
- if (closed.brackets[i] < length(ind.char)) {
- # there is something beyond the last closed bracket
- nep <- min(which(unlist(lapply(big.list, is.null))))
-
- big.list[[nep]] <- paste(ind.char[seq(closed.brackets[i] + 2, length(ind.char))], collapse = "")
-
- }
- }
-
- }
- }
- }
-
- nulls <- unlist(lapply(big.list, is.null))
-
- if (any(nulls)) {
- big.list <- big.list[-which(nulls)]
- }
-
- }
- else {
- big.list <- vector("list", length = 1)
- big.list[[1]] <- paste(ind.char, collapse="")
- }
-
- return(big.list)
- }
-
-
- #####
- # split each main component by separating brackets components
- splitBrackets <- function(big.list) {
- return(lapply(big.list, function(x) {
- as.list(unlist(strsplit(unlist(strsplit(x, split="\\(")), split="\\)")))
- }))
- }
-
-
-
- #####
- # remove individual components with single "*" signs
- removeSingleStars <- function(big.list) {
- return(lapply(big.list, function(x) {
- single.components <- unlist(lapply(x, function(y) {
- return(y == "*")
- }))
- return(x[!single.components])
- }))
- }
-
-
-
-
- #####
- # split by "+"
- splitPluses <- function(big.list) {
- return(lapply(big.list, function(x) {
- lapply(x, function(y) {
- plus.split <- unlist(strsplit(y, "\\+"))
- return(as.list(plus.split[plus.split != ""]))
- })
- }))
- }
-
-
-
- #####
- # split by "*"
- splitStars <- function(big.list) {
- return(lapply(big.list, function(x) {
- lapply(x, function(y) {
- lapply(y, function(z) {
- star.split <- unlist(strsplit(z, ifelse(prod.split == "", "", paste("\\", prod.split, sep=""))))
- star.split <- star.split[star.split != ""]
- if (prod.split == "") {
- tilda <- star.split == "~"
- if (any(tilda)) {
- tilda.pos <- which(tilda)
- if (max(tilda.pos) == length(star.split)) {
- cat("\n")
- stop(paste("Unusual expression \"", z, "\": terminated with a \"~\" sign?\n\n", sep=""), call. = FALSE)
- }
- star.split[tilda.pos + 1] <- paste("~", star.split[tilda.pos + 1], sep="")
- star.split <- star.split[-tilda.pos]
- }
- }
-
- return(as.list(star.split[star.split != ""]))
- })
- })
- }))
- }
-
-
-
-
- #####
- # split by "~"
- splitTildas <- function (big.list) {
- return(lapply(big.list, function(x) {
- lapply(x, function(y) {
- lapply(y, function(z) {
- lapply(z, function(w) {
- if (grepl("~", w)) {
- wsplit <- unlist(strsplit(w, split=""))
- if (max(which(wsplit == "~")) > 1) {
- cat("\n")
- stop(paste("Unusual expression: ", w, ". Perhaps you meant \"*~\"?\n\n", sep=""), call. = FALSE)
- }
- else {
- return(c("~", sub("~", "", w)))
- }
- }
- else {
- return(w)
- }
- })
- })
- })
- }))
- }
-
-
-
-
- ######
- # determine if and which main components have brackets, and SOLVE them
- solveBrackets <- function(big.list) {
- bracket.comps <- which(unlist(lapply(big.list, length)) > 1)
- if (length(bracket.comps) > 0) {
- for (i in bracket.comps) {
- lengths <- unlist(lapply(big.list[[i]], length))
- indexes <- createMatrix(lengths) + 1
- ncol.ind <- ncol(indexes)
- i.list <- vector("list", length = nrow(indexes))
-
- for (j in seq(length(i.list))) {
- i.list[[j]] <- vector("list", length = prod(dim(indexes)))
- start.position <- 1
-
- for (k in seq(ncol.ind)) {
- for (l in seq(length(big.list[[i]][[k]][[indexes[j, k]]]))) {
- i.list[[j]][[start.position]] <- big.list[[i]][[k]][[indexes[j, k]]][[l]]
- start.position <- start.position + 1
- }
- }
-
- if (start.position <= length(i.list[[j]])) {
- i.list[[j]] <- i.list[[j]][- seq(start.position, length(i.list[[j]]))]
- }
- }
-
-
- big.list[[i]] <- list(i.list)
- }
- }
-
- return(big.list)
- }
-
-
-
-
- simplifyList <- function(big.list) {
- lengths <- unlist(lapply(big.list, function(x) length(x[[1]])))
-
- big.list.copy <- vector("list", length = sum(lengths))
-
- start.position <- 1
-
- for (i in seq(length(big.list))) {
- for (j in seq(lengths[i])) {
- big.list.copy[[start.position]] <- big.list[[i]][[1]][[j]]
- start.position <- start.position + 1
- }
- }
- return(big.list.copy)
- }
-
-
-
-
- negateValues <- function(big.list, tilda = TRUE) {
- lapply(big.list, function(x) {
- lapply(x, function(y) {
- if (tilda) {
- if (length(y) > 1) {
- y <- toupper(y[2])
- }
- else {
- if (use.tilde) {
- y <- c("~", toupper(y))
- }
- else {
- y <- tolower(y)
- }
- }
- }
- else {
- if (y == toupper(y)) {
- if (use.tilde) {
- y <- c("~", toupper(y))
- }
- else {
- y <- tolower(y)
- }
- }
- else {
- y <- toupper(y)
- }
- }
- })
- })
- }
-
-
-
-
- removeDuplicates <- function(big.list) {
-
- big.list <- lapply(big.list, function(x) {
-
- values <- unlist(lapply(x, paste, collapse=""))
- x <- x[!duplicated(values)]
-
-
- # now trying to eliminate those which have both positive and negative
- # like "~A" and "A", or "a" and "A"
- ind.values <- unlist(x)
- ind.values <- ind.values[ind.values != "~"]
- ind.values <- toupper(ind.values)
-
- if (length(x) == 0 | any(table(ind.values) > 1)) {
- return(NULL)
- }
- else {
- return(x)
- }
- })
-
- big.list <- big.list[!unlist((lapply(big.list, is.null)))]
-
-
- # big.list.pasted
- blp <- lapply(big.list, function(x) {
- unlist(lapply(x, paste, collapse=""))
- })
-
- redundants <- vector(length = length(big.list))
-
- pairings <- combn(length(big.list), 2)
-
- for (i in seq(ncol(pairings))) {
- blp1 <- blp[[pairings[1, i]]]
- blp2 <- blp[[pairings[2, i]]]
- if (length(blp1) == length(blp2)) {
- if (all(sort(blp1) == sort(blp2))) {
- redundants[pairings[2, i]] <- TRUE
- }
- }
- else {
- if (length(blp1) < length(blp2)) {
- if (length(setdiff(blp1, blp2)) == 0) {
- redundants[pairings[2, i]] <- TRUE
- }
- }
- else {
- if (length(setdiff(blp2, blp1)) == 0) {
- redundants[pairings[1, i]] <- TRUE
- }
- }
- }
- }
-
- return(big.list[!redundants])
-
- }
-
-
-
- if (is.qca(expression)) {
- result <- deMorganLoop(expression)
- }
- else if (is.character(expression) & length(expression) == 1) {
-
- if (grepl("\\{", expression)) {
- if (grepl("~", expression)) {
- cat("\n")
- stop("Impossible combination of both \"~\" and \"{}\" multi-value notation.\n\n", call. = FALSE)
- }
- use.tilde <- FALSE
- }
-
- if (prod.split == "" & grepl("\\*", expression)) {
- # cat("\n")
- # stop("The \"*\" symbol was found: consider using the argument prod.split = \"*\".\n\n", call. = FALSE)
- prod.split <- "*"
- }
-
- if (prod.split != "" & prod.split != "*") {
- if (!grepl(prod.split, expression)) {
- cat("\n")
- stop("The product operator \"", prod.split, "\" was not found.\n\n", call. = FALSE)
- }
- }
-
- big.list <- simplifyList(solveBrackets(splitTildas(splitStars(splitPluses(removeSingleStars(splitBrackets(splitMainComponents(expression))))))))
-
- flat.vector <- unlist(big.list)
- unique.values <- unique(flat.vector)
-
- already.letters <- all(nchar(unique.values) == 1)
-
- tilda <- ifelse(any(flat.vector == "~"), TRUE, FALSE)
-
- if (tilda) {
- use.tilde <- TRUE
- }
-
- if (tilda & prod.split == "" & any(toupper(flat.vector) != flat.vector)) {
- cat("\n")
- stop("Unusual usage of both \"~\" sign and lower letters.\n\n", call. = FALSE)
- }
-
- negated.string <- paste("(", paste(unlist(lapply(negateValues(big.list, tilda), function(x) {
- paste(unlist(lapply(x, paste, collapse = "")), collapse = " + ")
- })), collapse = ")("), ")", sep="")
-
-
- big.list <- simplifyList(solveBrackets(splitTildas(splitStars(splitPluses(removeSingleStars(splitBrackets(splitMainComponents(negated.string))))))))
-
-
- # big.list <- splitMainComponents(negated.string)
- # big.list <- splitBrackets(big.list)
- # big.list <- removeSingleStars(big.list)
- # big.list <- splitPluses(big.list)
- # big.list <- splitStars(big.list)
- # big.list <- splitTildas(big.list)
- # big.list <- solveBrackets(big.list)
- # big.list <- simplifyList(big.list)
-
-
- initial <- expression
- negated <- unlist(lapply(removeDuplicates(big.list), function(x) {
- copyx <- unlist(lapply(x, function(y) {
- y <- y[y != "~"]
- }))
- x <- x[order(copyx)]
- paste(unlist(lapply(x, paste, collapse="")), collapse = prod.split)
- }))
-
- result <- list(S1 = list(initial, negated))
-
- }
-
- return(structure(result, class = "deMorgan"))
-}
-
-
-
-
-
-`deMorganLoop` <-
-function(qca.object) {
- prod.split <- qca.object$opts$collapse
-
- if ("i.sol" %in% names(qca.object)) {
- result <- vector("list", length=length(qca.object$i.sol))
- for (i in seq(length(qca.object$i.sol))) {
- names(result) <- names(qca.object$i.sol)
- result[[i]] <- lapply(qca.object$i.sol[[i]]$solution, paste, collapse = " + ")
- for (j in length(result[[i]])) {
- result[[i]][j] <- deMorgan(result[[i]][[j]], prod.split)
- }
- }
- }
- else {
- result <- lapply(lapply(qca.object$solution, paste, collapse = " + "), function(x) {
- deMorgan(x, prod.split)[[1]]
- })
- names(result) <- paste("S", seq(length(result)), sep="")
- }
- return(result)
-}
-
-
-
-
Deleted: pkg/R/demoChart.R
===================================================================
--- pkg/R/demoChart.R 2018-07-20 08:26:24 UTC (rev 48)
+++ pkg/R/demoChart.R 2018-07-20 12:47:26 UTC (rev 49)
@@ -1,20 +0,0 @@
-`demoChart` <-
-function(primes = c(""), configs = c(""), prod.split="") {
- if (prod.split != "") prod.split <- paste("\\", prod.split, sep="")
-
- primes.split <- strsplit(primes, prod.split)
- configs.split <- strsplit(configs, prod.split)
-
- mtrx <- matrix(FALSE, nrow=length(primes), ncol=length(configs))
-
- for (i in seq(nrow(mtrx))) {
- for (j in seq(ncol(mtrx))) {
- mtrx[i, j] <- all(primes.split[[i]] %in% configs.split[[j]])
- }
- }
-
- colnames(mtrx) <- configs
- rownames(mtrx) <- primes
- return(mtrx)
-}
-
Deleted: pkg/R/eqmcc.R
===================================================================
--- pkg/R/eqmcc.R 2018-07-20 08:26:24 UTC (rev 48)
+++ pkg/R/eqmcc.R 2018-07-20 12:47:26 UTC (rev 49)
@@ -1,689 +0,0 @@
-`eqmcc` <-
-function(data, outcome = c(""), neg.out = FALSE, conditions = c(""),
- relation = "suf", n.cut = 1, incl.cut1 = 1, incl.cut0 = 1,
- explain = c("1"), include = c(""), row.dom = FALSE, min.dis = TRUE,
- omit = c(), dir.exp = c(), details = FALSE, show.cases = FALSE,
- inf.test = c(""), use.tilde = FALSE, use.letters = FALSE, ...) {
-
- m2 <- FALSE
-
- metacall <- match.call()
-
- other.args <- list(...)
-
- if ("rowdom" %in% names(other.args)) {
- row.dom <- other.args$rowdom
- }
-
- if ("all.sol" %in% names(other.args)) {
- if (is.logical(other.args$all.sol)) {
- min.dis <- !other.args$all.sol
- }
- }
-
- PRI <- FALSE
- if ("direxp" %in% names(other.args)) {
- dir.exp <- other.args$direxp
- }
-
- if ("PRI" %in% names(other.args)) {
- if (is.logical(other.args$PRI)) {
- PRI <- other.args$PRI[1] # [1] just to make sure only the first value is taken, should someone incorrectly provide a vector
- }
- }
-
- print.truth.table <- details & !is.tt(data)
-
- if (all(include == "")) {
- if (!is.null(dir.exp)) {
- cat("\n")
- stop("Directional expectations were specified, without including the remainders.\n\n", call. = FALSE)
- }
- else {
- include <- explain
- }
- }
-
- if (!is.tt(data)) {
-
- if (length(outcome) > 1) {
-
- return(eqmccLoop(data=data, outcome=outcome, neg.out=neg.out, conditions=conditions, n.cut=n.cut,
- incl.cut1=incl.cut1, incl.cut0 = incl.cut0, explain=explain, 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, ...=...))
- }
-
- outcome.copy <- outcome
- indata <- data # important before altering the outcome, if multi-value
-
- names(data) <- toupper(names(data))
- conditions <- toupper(conditions)
- outcome <- toupper(outcome)
-
- if (grepl("[{]", outcome)) { # there is a "{" sign in the outcome's name
- outcome <- unlist(strsplit(outcome, split = ""))
- outcome.value <- as.numeric(outcome[which(outcome == "{") + 1])
- outcome <- paste(outcome[seq(1, which(outcome == "{") - 1)], collapse="")
-
- if (!any(unique(data[, outcome]) == outcome.value)) {
- cat("\n")
- stop(paste("The value {", outcome.value, "} does not exist in the outcome.\n\n", sep=""), call. = FALSE)
- }
- data[, outcome] <- ifelse(data[, outcome] == outcome.value, 1, 0)
- }
-
- if (all(conditions == c(""))) {
- conditions <- names(data)[-which(names(data) == outcome)]
- }
-
- data <- data[, c(conditions, outcome)]
-
- # dir.exp should now be a list, in the same order as the conditions' names
- verify.qca(data, outcome, conditions, explain, include, use.letters)
-
- complete <- FALSE
- if ("complete" %in% names(other.args)) {
- complete <- other.args$complete
- }
-
- tt <- truthTable(data=data, outcome=outcome, conditions=conditions, show.cases=show.cases, n.cut=n.cut, incl.cut1=incl.cut1,
- incl.cut0=incl.cut0, use.letters=use.letters, neg.out=neg.out, complete=complete, PRI=PRI)
-
-
- tt$initial.data <- indata
- indata <- data # data is already altered in outcome value, if initially multi-value
-
- recdata <- tt$recoded.data
- conditions <- toupper(conditions)
- outcome <- toupper(outcome)
- names(indata) <- c(conditions, outcome)
-
- dir.exp <- verify.dir.exp(recdata, outcome, conditions, 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
- chexplain <- c(0, 1)[which(0:1 %in% explain)]
- chinclude <- c(0, 1)[which(0:1 %in% include)]
- if (length(chinclude) > 0) {
- if (any(chinclude != chexplain)) {
- chinclude <- chinclude[which(chinclude != chexplain)]
- cat("\n")
- stop(paste("You cannot include ", chinclude, " since you want to explain ", chexplain, ".\n\n", sep=""), call. = FALSE)
- }
- }
-
- # check if explain has both 1 and 0
- if (length(chexplain) == 2) {
- cat("\n")
- stop("You cannot explain both 0 and 1.\n\n", call. = FALSE)
- }
-
- tt <- data
- indata <- tt$initial.data
- recdata <- tt$recoded.data
- conditions <- colnames(recdata)[seq(length(tt$noflevels))]
- outcome <- colnames(recdata)[ncol(recdata)]
-
- 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, conditions, 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(conditions))] <- as.data.frame(lapply(tt$tt[, seq(length(conditions))], function(x) {
- x[x %in% c("-", "dc")] <- -1
- return(as.numeric(x))
- }))
-
- expl.incl <- unique(c(explain, 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% explain
-
- if (all(!subset.tt)) {
- cat("\n")
- stop(paste("None of the values in OUT is explained. Please check the truth table.\n\n", sep=""), 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) {
- cat("\n")
- stop("Nothing to explain. Please check the truth table.\n\n", call. = FALSE)
- }
-
- incl.rem <- "?" %in% include
- if (nrow(excl.matrix) == 0 & incl.rem) {
- cat("\n")
- stop(paste("All combinations have been included into analysis. The solution is 1.\n",
- "Please check the truth table.", "\n\n", sep=""), call. = FALSE)
- }
-
- # expl.matrix needs to be unaltered for the incl.rem argument
- expressions <- expl.matrix
-
- recdata[, conditions] <- as.data.frame(lapply(recdata[, conditions], 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 {
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/qca -r 49
More information about the Qca-commits
mailing list