[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