[Qca-commits] r17 - in pkg: . R data inst man src tests tests/Examples
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Jun 26 15:56:33 CEST 2014
Author: dusadrian
Date: 2014-06-26 15:56:32 +0200 (Thu, 26 Jun 2014)
New Revision: 17
Added:
pkg/DESCRIPTION
pkg/NAMESPACE
pkg/R/
pkg/R/allExpressions.R
pkg/R/base3rows.R
pkg/R/calibrate.R
pkg/R/createChart.R
pkg/R/createMatrix.R
pkg/R/createString.R
pkg/R/deMorgan.R
pkg/R/demoChart.R
pkg/R/eqmcc.R
pkg/R/eqmccLoop.R
pkg/R/factorize.R
pkg/R/findSubsets.R
pkg/R/findSupersets.R
pkg/R/findTh.R
pkg/R/fuzzyand.R
pkg/R/fuzzyor.R
pkg/R/getRow.R
pkg/R/getSolution.R
pkg/R/is.print.R
pkg/R/onAttach.R
pkg/R/pof.R
pkg/R/prettyString.R
pkg/R/prettyTable.R
pkg/R/rowDominance.R
pkg/R/solveChart.R
pkg/R/sortMatrix.R
pkg/R/sortVector.R
pkg/R/superSubset.R
pkg/R/superSubsetOld.R
pkg/R/truthTable.R
pkg/R/verifyQCA.R
pkg/R/writePrimeimp.R
pkg/R/writeSolution.R
pkg/data/
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.HK.RData
pkg/data/d.HMN.tab
pkg/data/d.Kil.tab
pkg/data/d.Kro.tab
pkg/data/d.RS.tab
pkg/data/d.SA.tab
pkg/data/d.SS.tab
pkg/inst/
pkg/inst/CITATION
pkg/inst/ChangeLog
pkg/inst/TODO
pkg/man/
pkg/man/QCA-internal.Rd
pkg/man/QCA.package.Rd
pkg/man/allExpressions.Rd
pkg/man/calibrate.Rd
pkg/man/createMatrix.Rd
pkg/man/d.AS.Rd
pkg/man/d.BWB.Rd
pkg/man/d.Bas.Rd
pkg/man/d.CS.Rd
pkg/man/d.CZH.Rd
pkg/man/d.Emm.Rd
pkg/man/d.HK.Rd
pkg/man/d.HMN.Rd
pkg/man/d.Kil.Rd
pkg/man/d.Kro.Rd
pkg/man/d.RS.Rd
pkg/man/d.SA.Rd
pkg/man/d.SS.Rd
pkg/man/deMorgan.Rd
pkg/man/demoChart.Rd
pkg/man/eqmcc.Rd
pkg/man/factorize.Rd
pkg/man/findSubsets.Rd
pkg/man/findSupersets.Rd
pkg/man/findTh.Rd
pkg/man/getRow.Rd
pkg/man/pof.Rd
pkg/man/solveChart.Rd
pkg/man/superSubset.Rd
pkg/man/truthTable.Rd
pkg/src/
pkg/src/allSol.c
pkg/src/findSubsets.c
pkg/src/m2.c
pkg/src/removeRedundants.c
pkg/src/solveChart.c
pkg/src/superSubset.c
pkg/src/truthTable.c
pkg/tests/
pkg/tests/Examples/
pkg/tests/Examples/QCA-Ex.Rout.save
Log:
Adding back the package folders in the pkg folder
Added: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION (rev 0)
+++ pkg/DESCRIPTION 2014-06-26 13:56:32 UTC (rev 17)
@@ -0,0 +1,13 @@
+Package: QCA
+Version: 1.1-3.2
+Date: 2014-06-26
+Title: A Package for Qualitative Comparative Analysis
+Authors at R: c(person("Adrian", "Dusa", role = c("aut", "cre"),
+ email = "dusa.adrian at unibuc.ro"),
+ person("Alrik", "Thiem", role = "aut",
+ email = "alrik.thiem at unige.ch"))
+Depends: R (>= 3.0.0)
+Imports: lpSolve
+Suggests: VennDiagram
+Description: This package provides functions for performing Qualitative Comparative Analysis (csQCA, tQCA, mvQCA and fsQCA).
+License: GPL (>= 2)
Added: pkg/NAMESPACE
===================================================================
--- pkg/NAMESPACE (rev 0)
+++ pkg/NAMESPACE 2014-06-26 13:56:32 UTC (rev 17)
@@ -0,0 +1,54 @@
+useDynLib(QCA)
+export(.onAttach,
+ allExpressions,
+ base3rows,
+ calibrate,
+ createChart,
+ createMatrix,
+ createString,
+ demoChart,
+ deMorgan,
+ deMorganLoop,
+ eqmcc,
+ eqmccLoop,
+ factorize,
+ findSubsets,
+ findSupersets,
+ findTh,
+ fuzzyand,
+ fuzzyor,
+ getRow,
+ getSolution,
+ is.deMorgan,
+ is.pof,
+ is.qca,
+ is.tt,
+ is.sS,
+ pof,
+ prettyString,
+ prettyTable,
+ print.aE,
+ print.deMorgan,
+ print.fctr,
+ print.pof,
+ print.qca,
+ print.mqca,
+ print.pic,
+ print.sS,
+ print.tt,
+ rowDominance,
+ solveChart,
+ sortMatrix,
+ sortVector,
+ superSubset,
+ truthTable,
+ verify.data,
+ verify.dir.exp,
+ verify.expl,
+ verify.inf.test,
+ verify.qca,
+ verify.mqca,
+ verify.tt,
+ writePrimeimp,
+ writeSolution)
+import(lpSolve)
Property changes on: pkg/NAMESPACE
___________________________________________________________________
Added: svn:executable
+ *
Added: pkg/R/allExpressions.R
===================================================================
--- pkg/R/allExpressions.R (rev 0)
+++ pkg/R/allExpressions.R 2014-06-26 13:56:32 UTC (rev 17)
@@ -0,0 +1,11 @@
+`allExpressions` <-
+function(noflevels, raw=FALSE, arrange=FALSE) {
+ aEmat <- createMatrix(noflevels + 1)
+ if (arrange) {
+ aEmat <- sortMatrix(aEmat)
+ sum.zeros <- apply(aEmat, 1, function(idx) sum(idx == 0))
+ aEmat <- aEmat[order(sum.zeros, decreasing=TRUE), ]
+ }
+ return(structure(list(aE=aEmat - 1, raw=raw), class = "aE"))
+}
+
Property changes on: pkg/R/allExpressions.R
___________________________________________________________________
Added: svn:executable
+ *
Added: pkg/R/base3rows.R
===================================================================
--- pkg/R/base3rows.R (rev 0)
+++ pkg/R/base3rows.R 2014-06-26 13:56:32 UTC (rev 17)
@@ -0,0 +1,15 @@
+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)))
+ }
+
Property changes on: pkg/R/base3rows.R
___________________________________________________________________
Added: svn:executable
+ *
Added: pkg/R/calibrate.R
===================================================================
--- pkg/R/calibrate.R (rev 0)
+++ pkg/R/calibrate.R 2014-06-26 13:56:32 UTC (rev 17)
@@ -0,0 +1,212 @@
+`calibrate` <-
+function (x, type="crisp", thresholds = NA, include = TRUE, logistic = FALSE,
+ idm = 0.95, ecdf = FALSE, p = 1, q = 1) {
+ if (!is.numeric(x)) {
+ cat("\n")
+ stop("x is not numeric.\n\n", call. = FALSE)
+ }
+ if (!(type %in% c("crisp", "fuzzy"))) {
+ cat("\n")
+ stop("Unknown calibration type.\n\n", call. = FALSE)
+ }
+ if (all(is.na(thresholds))) {
+ cat("\n")
+ stop("Threshold value(s) not specified.\n\n", call. = FALSE)
+ }
+ if (type == "crisp") {
+ xrange <- range(x, na.rm=TRUE)
+ if (any(as.numeric(unclass(cut(thresholds, breaks=c(-Inf, xrange, Inf)))) != 2)) {
+ cat("\n")
+ stop("Threshold value(s) outside the range of x.\n\n", call. = FALSE)
+ }
+ return(as.numeric(unclass(cut(x, breaks=c(-Inf, thresholds, Inf), right=!include))) - 1)
+ # the built-in findInterval() was interesting, but doesn't cope well with the include argument
+ }
+ else if (type == "fuzzy") {
+ check.equal <- function(x, y) {
+ check.vector <- as.logical(unlist(lapply(x, all.equal, y)))
+ check.vector[is.na(check.vector)] <- FALSE
+ return(check.vector)
+ }
+ if (!(length(thresholds) %in% c(3, 6))) {
+ cat("\n")
+ stop("For fuzzy data, thresholds should be of type:\n\"c(thEX, thCR, thIN)\"\nor\n\"c(thEX1, thCR1, thIN1, thIN2, thCR2, thEX2)\".\n\n", call. = FALSE)
+ }
+ if (idm <= 0.5 | idm >= 1) {
+ cat("\n")
+ stop("The inclusion degree of membership has to be bigger than 0.5 and less than 1.\n\n", call. = FALSE)
+ }
+ # needed because sometimes thresholds values inherit names, e.g. from being calculated with quantile()
+ thresholds <- as.vector(thresholds)
+
+ if (length(thresholds) == 3) {
+ thEX <- thresholds[1]
+ thCR <- thresholds[2]
+ thIN <- thresholds[3]
+ if (logistic) {
+ if (thresholds[1] > thresholds[3]) {
+ thEX <- thresholds[3]
+ thIN <- thresholds[1]
+ }
+
+ y <- (x < thCR) + 1
+ result <- 1/(1 + exp(-((x - thCR) * (c(1, -1)[y]*log(idm/(1 - idm))/(c(thIN, thEX)[y] - thCR)))))
+
+ if (thresholds[1] > thresholds[3]) {
+ return(1 - result)
+ }
+ else {
+ return(result)
+ }
+ }
+ else {
+ if (any(table(c(thEX, thCR, thIN)) > 1)) {
+ cat("\n")
+ warning("Some thresholds equal, that should not be equal.\n\n", call. = FALSE)
+ }
+ increasing <- TRUE
+ if (thIN < thCR & thCR < thEX) {
+ increasing <- FALSE
+ }
+
+ if (ecdf) {
+ ecdfx <- x[-which(x < min(thresholds))]
+ ecdfx <- ecdfx[-which(ecdfx > max(thresholds))]
+ Fn <- ecdf(ecdfx)
+ }
+
+ fs <- rep(NA, length(x))
+ for (i in seq(length(x))) {
+ if (increasing) {
+ if (x[i] < thEX | check.equal(x[i], thEX)) {
+ fs[i] <- 0
+ }
+ else if (x[i] < thCR | check.equal(x[i], thCR)) {
+ fs[i] <- (((thEX - x[i])/(thEX - thCR))^p)/2
+ if (ecdf) {
+ fs[i] <- (Fn(x[i])/Fn(thCR))/2
+ }
+ }
+ else if (x[i] < thIN | check.equal(x[i], thIN)) {
+ fs[i] <- 1 - (((thIN - x[i])/(thIN - thCR))^q)/2
+ if (ecdf) {
+ fs[i] <- 1 - ((1 - Fn(x[i]))/(1 - Fn(thCR)))/2
+ }
+ }
+ else {
+ fs[i] <- 1
+ }
+ }
+ else {
+ # return(list(Fn, thIN, thCR, thEX))
+ if (x[i] < thIN | check.equal(x[i], thIN)) {
+ fs[i] <- 1
+ }
+ else if (x[i] < thCR | check.equal(x[i], thCR)) {
+ fs[i] <- 1 - (((thIN - x[i])/(thIN - thCR))^q)/2
+ if (ecdf) {
+ fs[i] <- 1 - (Fn(x[i])/Fn(thCR))/2
+ }
+ }
+ else if (x[i] < thEX | check.equal(x[i], thEX)) {
+ fs[i] <- (((thEX - x[i])/(thEX - thCR))^p)/2
+ if (ecdf) {
+ fs[i] <- ((1 - Fn(x[i]))/(1 - Fn(thCR)))/2
+ }
+ }
+ else {
+ fs[i] <- 0
+ }
+ }
+ }
+ }
+ return(fs)
+ }
+ else {
+ thEX1 <- thresholds[1]
+ thCR1 <- thresholds[2]
+ thIN1 <- thresholds[3]
+ thIN2 <- thresholds[4]
+ thCR2 <- thresholds[5]
+ thEX2 <- thresholds[6]
+ if (thCR1 < min(thEX1, thIN1) | thCR1 > max(thEX1, thIN1)) {
+ cat("\n")
+ stop("First crossover threshold not between first exclusion and inclusion thresholds.\n\n", call. = FALSE)
+ }
+ if (thCR2 < min(thEX2, thIN2) | thCR2 > max(thEX2, thIN2)) {
+ cat("\n")
+ stop("Second crossover threshold not between second exclusion and inclusion thresholds.\n\n", call. = FALSE)
+ }
+ if (any(table(c(thEX1, thCR1, thIN1)) > 1) | any(table(c(thIN2, thCR2, thEX2)) > 1) | thCR1 == thCR2) {
+ cat("\n")
+ stop("Some thresholds equal, that should not be equal.\n\n", call. = FALSE)
+ }
+ increasing <- TRUE
+ if (thIN1 < thCR1 & thCR1 < thEX1 & thEX1 <= thEX2 & thEX2 < thCR2 & thCR2 < thIN2) {
+ increasing <- FALSE
+ }
+ if (increasing) {
+ if (thEX1 == thEX2) {
+ cat("\n")
+ stop("some thresholds equal that should not be equal.\n\n", call. = FALSE)
+ }
+ }
+ else {
+ if (thIN1 == thIN2) {
+ cat("\n")
+ stop("some thresholds equal that should not be equal.\n\n", call. = FALSE)
+ }
+ }
+ fs <- rep(NA, length(x))
+ for (i in seq(length(x))) {
+ if (increasing) {
+ if (x[i] < thEX1 | check.equal(x[i], thEX1)) {
+ fs[i] <- 0
+ }
+ else if (x[i] < thCR1 | check.equal(x[i], thCR1)) {
+ fs[i] <- (((thEX1 - x[i])/(thEX1 - thCR1))^p)/2
+ }
+ else if (x[i] < thIN1) {
+ fs[i] <- 1 - (((thIN1 - x[i])/(thIN1 - thCR1))^q)/2
+ }
+ else if (x[i] < thIN2 | check.equal(x[i], thIN2)) {
+ fs[i] <- 1
+ }
+ else if (x[i] < thCR2 | check.equal(x[i], thCR2)) {
+ fs[i] <- 1 - (((thIN2 - x[i])/(thIN2 - thCR2))^q)/2
+ }
+ else if (x[i] < thEX2 | check.equal(x[i], thEX2)) {
+ fs[i] <- (((thEX2 - x[i])/(thEX2 - thCR2))^p)/2
+ }
+ else {
+ fs[i] <- 0
+ }
+ }
+ else {
+ if (x[i] < thIN1 | check.equal(x[i], thIN1)) {
+ fs[i] <- 1
+ }
+ else if (x[i] < thCR1 | check.equal(x[i], thCR1)) {
+ fs[i] <- 1 - (((thIN1 - x[i])/(thIN1 - thCR1))^q)/2
+ }
+ else if (x[i] < thEX1) {
+ fs[i] <- (((thEX1 - x[i])/(thEX1 - thCR1))^p)/2
+ }
+ else if (x[i] < thEX2 | check.equal(x[i], thEX2)) {
+ fs[i] <- 0
+ }
+ else if (x[i] < thCR2 | check.equal(x[i], thCR2)) {
+ fs[i] <- (((thEX2 - x[i])/(thEX2 - thCR2))^p)/2
+ }
+ else if (x[i] < thIN2 | check.equal(x[i], thIN2)) {
+ fs[i] <- 1 - (((thIN2 - x[i])/(thIN2 - thCR2))^q)/2
+ }
+ else {
+ fs[i] <- 1
+ }
+ }
+ }
+ return(fs)
+ }
+ }
+}
Added: pkg/R/createChart.R
===================================================================
--- pkg/R/createChart.R (rev 0)
+++ pkg/R/createChart.R 2014-06-26 13:56:32 UTC (rev 17)
@@ -0,0 +1,23 @@
+`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)
+}
+
Property changes on: pkg/R/createChart.R
___________________________________________________________________
Added: svn:executable
+ *
Added: pkg/R/createMatrix.R
===================================================================
--- pkg/R/createMatrix.R (rev 0)
+++ pkg/R/createMatrix.R 2014-06-26 13:56:32 UTC (rev 17)
@@ -0,0 +1,27 @@
+`createMatrix` <-
+function(noflevels, logical = FALSE) {
+ conds <- length(noflevels)
+ pwr <- unique(noflevels)
+ if (any(pwr > 2)) {
+ logical <- FALSE
+ }
+ if (length(pwr) == 1) {
+ create <- function(idx) {
+ rep.int(c(sapply(seq_len(pwr) - 1, function(x) rep.int(x, pwr^(idx - 1)))),
+ pwr^conds/pwr^idx)
+ }
+ retmat <- sapply(rev(seq_len(conds)), create)
+ }
+ else {
+ mbase <- c(rev(cumprod(rev(noflevels))), 1)[-1]
+ orep <- cumprod(rev(c(rev(noflevels)[-1], 1)))
+ retmat <- sapply(seq_len(conds), function(x) {
+ rep.int(rep.int(seq_len(noflevels[x]) - 1, rep.int(mbase[x], noflevels[x])), orep[x])
+ })
+ }
+ if (logical) {
+ retmat <- matrix(as.logical(retmat), nrow=nrow(retmat), ncol=ncol(retmat))
+ }
+ return(retmat)
+}
+
Property changes on: pkg/R/createMatrix.R
___________________________________________________________________
Added: svn:executable
+ *
Added: pkg/R/createString.R
===================================================================
--- pkg/R/createString.R (rev 0)
+++ pkg/R/createString.R 2014-06-26 13:56:32 UTC (rev 17)
@@ -0,0 +1,26 @@
+`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)
+}
+
Property changes on: pkg/R/createString.R
___________________________________________________________________
Added: svn:executable
+ *
Added: pkg/R/deMorgan.R
===================================================================
--- pkg/R/deMorgan.R (rev 0)
+++ pkg/R/deMorgan.R 2014-06-26 13:56:32 UTC (rev 17)
@@ -0,0 +1,523 @@
+`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)
+ }
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/qca -r 17
More information about the Qca-commits
mailing list