[Qca-commits] r56 - in pkg: . R inst inst/gui inst/gui/www/js inst/staticdocs man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Nov 1 23:32:34 CET 2018
Author: dusadrian
Date: 2018-11-01 23:32:34 +0100 (Thu, 01 Nov 2018)
New Revision: 56
Added:
pkg/R/Electron.R
pkg/R/getLevels.R
Modified:
pkg/DESCRIPTION
pkg/NAMESPACE
pkg/R/calibrate.R
pkg/R/findRows.R
pkg/R/getSolution.R
pkg/R/minimize.R
pkg/R/onAttach.R
pkg/R/pof.R
pkg/R/pofind.R
pkg/R/prettyString.R
pkg/R/print.R
pkg/R/superSubset.R
pkg/R/translate.R
pkg/R/truthTable.R
pkg/R/verifyQCA.R
pkg/inst/CITATION
pkg/inst/ChangeLog
pkg/inst/gui/server.R
pkg/inst/gui/www/js/maincode.js
pkg/inst/staticdocs/QCA.package.html
pkg/man/QCA-internal.Rd
pkg/man/QCA.package.Rd
pkg/man/findRows.Rd
pkg/man/truthTable.Rd
Log:
version 3.3-2
Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2018-08-27 20:04:52 UTC (rev 55)
+++ pkg/DESCRIPTION 2018-11-01 22:32:34 UTC (rev 56)
@@ -1,6 +1,6 @@
Package: QCA
Version: 3.3-2
-Date: 2018-08-27
+Date: 2018-11-02
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-08-27 20:01:07 UTC; dusadrian
+Packaged: 2018-11-01 22:28:58 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 2018-08-27 20:04:52 UTC (rev 55)
+++ pkg/NAMESPACE 2018-11-01 22:32:34 UTC (rev 56)
@@ -1,11 +1,12 @@
import(shiny)
import(venn)
import(fastdigest)
-importFrom("utils", "packageDescription", "remove.packages", "capture.output")
+importFrom("utils", "packageDescription", "remove.packages", "capture.output", "data", "loadhistory", "savehistory")
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")
importFrom("methods", "is")
+importFrom("fastdigest", "fastdigest")
useDynLib(QCA, .registration = TRUE)
@@ -32,8 +33,8 @@
fuzzyand,
fuzzyor,
getInfo,
+ getLevels,
getRow,
- getNoflevels,
intersection,
makeChart,
minimize,
@@ -69,9 +70,9 @@
verify.tt,
Xplot,
XYplot,
-
+
possibleNumeric,
-
+
dashes,
hastilde,
tilde1st,
@@ -98,14 +99,17 @@
outsideBrackets,
curlyBrackets,
roundBrackets,
-
+
getSolution,
prettyString,
rowDominance,
sortMatrix,
sortVector,
writePrimeimp,
- writeSolution
+ writeSolution,
+
+ # Electron-js specific
+ GUIcall
)
S3method(print, "aE")
@@ -123,4 +127,3 @@
S3method(print, "sS")
S3method(print, "translate")
S3method(print, "tt")
-
Added: pkg/R/Electron.R
===================================================================
--- pkg/R/Electron.R (rev 0)
+++ pkg/R/Electron.R 2018-11-01 22:32:34 UTC (rev 56)
@@ -0,0 +1,280 @@
+# Copyright (c) 2018, Adrian Dusa
+# All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, in whole or in part, are permitted provided that the
+# following conditions are met:
+# * Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer.
+# * Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in the
+# documentation and/or other materials provided with the distribution.
+# * The names of its contributors may NOT be used to endorse or promote products
+# derived from this software without specific prior written permission.
+#
+# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+# DISCLAIMED. IN NO EVENT SHALL ADRIAN DUSA BE LIABLE FOR ANY
+# DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+# LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+# ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+`GUIcall` <- function(commandlist) {
+ ev <- get("invisibleEnvironment", envir = globalenv())
+ nms <- names(commandlist)
+ result <- c()
+ `hashobjs` <- function(...) {
+ return(lapply(globalenv(), function(x) fastdigest::fastdigest(x)))
+ }
+ `jsonify` <- function(x) {
+ nms <- names(x)
+ result <- ""
+ for (i in seq(length(x))) {
+ xi <- x[[i]]
+ if (inherits(xi, "list")) {
+ if (length(xi) > 0) {
+ nmsi <- names(xi)
+ if (is.null(nmsi)) {
+ result <- paste(result, "'", nms[i], "'", ": [", Recall(xi), "]", sep = "")
+ }
+ else {
+ if (is.null(xi)) {
+ result <- paste(result, "'", nms[i], "'", ": undefined", sep = "")
+ }
+ else {
+ result <- paste(result, "'", nms[i], "'", ": {", Recall(xi), "}", sep = "")
+ }
+ }
+ }
+ else {
+ result <- paste(result, "'", nms[i], "'", ": {}", sep = "")
+ }
+ }
+ else {
+ collapse <- ", "
+ prefix <- ""
+ if (is.character(xi)) {
+ collapse <- "`, `"
+ prefix <- "`"
+ }
+ if (is.logical(x[[i]])) x[[i]] <- QCA::recode(x[[i]], "TRUE = true; FALSE = false")
+ result <- paste(result,
+ ifelse (is.null(nms[i]),
+ sprintf(ifelse(length(x[[i]]) > 1, " [ %s%s%s ]", "%s%s%s"), prefix, paste(x[[i]], collapse = collapse), prefix),
+ sprintf(ifelse(length(x[[i]]) > 1, "'%s': [ %s%s%s ]", "'%s': %s%s%s"), nms[i], prefix, paste(x[[i]], collapse = collapse), prefix)
+ )
+ )
+ }
+ if (i < length(x)) {
+ result <- paste(result, ",", sep = "")
+ }
+ }
+ return(result)
+ }
+ `scrollobj` <- function(...) {
+ x <- list(...)
+ scrollvh <- lapply(x$scrollvh, function(x) unlist(x) + 1)
+ ev$visiblerows <- x$visiblerows + 1
+ ev$visiblecols <- x$visiblecols + 1
+ if (!x$alldata) {
+ scrollvh <- scrollvh[x$dataset]
+ }
+ tosend <- vector(mode = "list", length = length(scrollvh))
+ names(tosend) <- names(scrollvh)
+ for (n in names(scrollvh)) {
+ data <- get(n, ev)
+ nrowd <- nrow(data)
+ ncold <- ncol(data)
+ dscrollvh <- scrollvh[[n]]
+ srow <- min(dscrollvh[1], nrowd - min(nrowd, x$visiblerows) + 1)
+ scol <- min(dscrollvh[2], ncold - min(ncold, x$visiblecols) + 1)
+ erow <- min(srow + x$visiblerows, nrowd)
+ ecol <- min(scol + x$visiblecols, ncold)
+ tosend[[n]] <- list(
+ theData = unname(as.list(data[seq(srow, erow), seq(scol, ecol), drop = FALSE])),
+ dataCoords = paste(srow, scol, erow, ecol, ncold, sep="_"),
+ scrollvh = c(srow, scol) - 1
+ )
+ }
+ return(jsonify(list(scrollData = tosend)))
+ }
+ `infobjs` <- function(objs, scrollvh) {
+ funargs <- lapply(match.call(), deparse)
+ type <- funargs$objs
+ if (!identical(type, "added") & !identical(type, "modified")) {
+ type <- "infobjs"
+ }
+ visiblerows <- ev$visiblerows
+ visiblecols <- ev$visiblecols
+ misscroll <- missing(scrollvh)
+ toreturn <- list()
+ objtype <- unlist(lapply(mget(objs, globalenv()), function(x) {
+ if (is.data.frame(x)) {
+ return(1)
+ }
+ else if (is(x, "tt")) {
+ return(2)
+ }
+ else if (is(x, "qca")) {
+ return(3)
+ }
+ return(0)
+ }))
+ if (any(objtype > 0)) {
+ if (any(objtype == 1)) {
+ toreturn$data <- lapply(names(objtype[objtype == 1]), function(n) {
+ x <- globalenv()[[n]]
+ dscrollvh <- c(1, 1)
+ if (!misscroll) {
+ if (is.element(n, names(scrollvh))) {
+ dscrollvh <- scrollvh[[n]]
+ }
+ }
+ nrowd <- nrow(x)
+ ncold <- ncol(x)
+ srow <- min(dscrollvh[1], nrowd - min(nrowd, visiblerows) + 1)
+ scol <- min(dscrollvh[2], ncold - min(ncold, visiblecols) + 1)
+ erow <- min(srow + visiblerows - 1, nrowd)
+ ecol <- min(scol + visiblecols - 1, ncold)
+ return(list(
+ nrows = nrowd,
+ ncols = ncold,
+ rownames = rownames(x),
+ colnames = colnames(x),
+ numerics = as.vector(unlist(lapply(x, QCA::possibleNumeric))),
+ calibrated = as.vector(unlist(lapply(x, function(x) {
+ all(na.omit(x) >= 0 & na.omit(x) <= 1)
+ }))),
+ binary = as.vector(unlist(lapply(x, function(x) all(is.element(x, 0:1))))),
+ scrollvh = c(srow, scol) - 1,
+ theData = unname(as.list(x[seq(srow, erow), seq(scol, ecol), drop = FALSE])),
+ dataCoords = paste(srow, scol, erow, ecol, ncol(x), sep = "_")
+ ))
+ })
+ names(toreturn$data) <- names(objtype[objtype == 1])
+ }
+ if (any(objtype == 2)) {
+ toreturn$tt <- lapply(mget(names(objtype[objtype == 2]), globalenv()), function(x) {
+ components <- c("indexes", "noflevels", "cases", "options", "colnames", "numerics")
+ x$indexes <- x$indexes - 1
+ x$options$conditions <- toupper(x$options$conditions)
+ cnds <- x$options$conditions
+ if (x$options$use.letters) {
+ cnds <- LETTERS[seq(length(cnds))]
+ }
+ x$options$outcome <- list(notilde(x$options$outcome))
+ if (length(x$options$incl.cut) == 1) {
+ x$options$incl.cut <- list(x$options$incl.cut)
+ }
+ if (length(cnds) <= 7) {
+ x$id <- apply(x$tt[, cnds], 1, function(x) {
+ ifelse(any(x == 1), paste(which(x == 1), collapse=""), "0")
+ })
+ components <- c(components, "id", "tt")
+ }
+ x$colnames <- colnames(x$initial.data)
+ x$numerics <- as.vector(unlist(lapply(x$initial.data, QCA::possibleNumeric)))
+ return(x[components])
+ })
+ }
+ if (any(objtype == 3)) {
+ toreturn$qmc <- lapply(mget(names(objtype[objtype == 3]), .GlobalEnv), function(x) {
+ components <- c("indexes", "noflevels", "cases", "options")
+ x <- x$tt
+ x$options$conditions <- toupper(x$options$conditions)
+ cnds <- x$options$conditions
+ if (x$options$use.letters) {
+ cnds <- LETTERS[seq(length(cnds))]
+ }
+ if (length(cnds) <= 7) {
+ x$id <- apply(x$tt[, cnds], 1, function(x) {
+ ifelse(any(x == 1), paste(which(x == 1), collapse=""), "0")
+ })
+ components <- c(components, "id", "tt")
+ }
+ x$indexes <- x$indexes - 1
+ return(x[components])
+ })
+ }
+ toreturn <- list(toreturn)
+ names(toreturn) <- type
+ return(jsonify(toreturn))
+ }
+ }
+ `Changes` <- function(...) {
+ changes <- gsub("`", "'", readLines(system.file("ChangeLog", package = "QCA")))
+ return(jsonify(list(changes = changes)))
+ }
+ `packages` <- function(x) {
+ attached <- data()$results[, -2]
+ packages <- unique(attached[, "Package"])
+ if (!identical(sort(packages), sort(x))) {
+ attached <- lapply(packages, function(x) {
+ x <- attached[attached[, "Package"] == x, 2:3, drop = FALSE]
+ x <- x[x[, 2] != "Internal Functions", , drop = FALSE]
+ if (nrow(x) == 0) return(list())
+ titles <- as.list(x[, 2])
+ names(titles) <- x[, 1]
+ return(titles)
+ })
+ names(attached) <- packages
+ return(jsonify(list(packages = attached)))
+ }
+ }
+ `xyplot` <- function(...) {
+ arglist <- list(...)
+ if (is.element("dataset", names(arglist))) {
+ xyplot_before <- fastdigest::fastdigest(get(arglist$dataset, globalenv())[, c(arglist$x, arglist$y), drop = FALSE])
+ }
+ }
+ `calibration` <- function(...) {
+ arglist <- list(...)
+ if (is.element("dataset", names(arglist))) {
+ hashcalib <- fastdigest::fastdigest(get(arglist$dataset, globalenv())[, arglist$x, drop = FALSE])
+ if (arglist$thsetter) {
+ recalibrate <- TRUE
+ }
+ }
+ }
+ `thinfo` <- function(...) {
+ }
+ `scrollvh` <- function(...) {
+ }
+ `editorSize` <- function(visiblerows, visiblecols) {
+ ev$visiblerows <- visiblerows
+ ev$visiblecols <- visiblecols
+ }
+ for (n in nms) {
+ if (is.element(n, c("source", "options", "library"))) {
+ do.call(n, commandlist[[n]])
+ }
+ else {
+ result <- c(result, do.call(n, commandlist[[n]]))
+ }
+ }
+ hashes <- hashobjs()
+ added <- setdiff(names(hashes), names(ev$hashes))
+ deleted <- setdiff(names(ev$hashes), names(hashes))
+ common <- intersect(names(hashes), names(ev$hashes))
+ modified <- names(ev$hashes)[!is.element(ev$hashes[common], hashes[common])]
+ ev$hashes <- hashes
+ if (length(added) > 0) result <- c(result, infobjs(added))
+ if (length(modified) > 0) result <- c(result, infobjs(modified))
+ if (length(deleted) > 0) result <- c(result, jsonify(list(deleted = deleted)))
+ savehistory(file = "temphistory")
+ history <- readLines("temphistory")
+ if (ev$firstHistory) {
+ ev$firstHistory <- FALSE
+ history[length(history) - 1] <- "library(QCA)"
+ }
+ writeLines(history[seq(length(history) - 1)], con = "temphistory")
+ loadhistory(file = "temphistory")
+ unlink(".temphistory")
+ if (length(result) > 0) {
+ cat("{", paste(result, collapse = ", "), "}")
+ }
+}
Modified: pkg/R/calibrate.R
===================================================================
--- pkg/R/calibrate.R 2018-08-27 20:04:52 UTC (rev 55)
+++ pkg/R/calibrate.R 2018-11-01 22:32:34 UTC (rev 56)
@@ -27,10 +27,10 @@
function (x, type = "fuzzy", method = "direct", thresholds = NA,
logistic = TRUE, idm = 0.95, ecdf = FALSE, below = 1, above = 1, ...) {
other.args <- list(...)
- if ("q" %in% names(other.args)) {
+ if (is.element("q", names(other.args))) {
above <- other.args$q
}
- if ("p" %in% names(other.args)) {
+ if (is.element("p", names(other.args))) {
below <- other.args$p
}
if (possibleNumeric(x)) {
@@ -40,11 +40,11 @@
cat("\n")
stop(simpleError("x is not numeric.\n\n"))
}
- if (!(type %in% c("crisp", "fuzzy"))) {
+ if (!is.element(type, c("crisp", "fuzzy"))) {
cat("\n")
stop(simpleError("Unknown calibration type.\n\n"))
}
- if (!(method %in% c("direct", "indirect", "TFR"))) {
+ if (!is.element(method, c("direct", "indirect", "TFR"))) {
cat("\n")
stop(simpleError("Unknown calibration method.\n\n"))
}
@@ -100,7 +100,7 @@
}
if (lth == 3) {
if (!is.null(names(thresholds))) {
- if (length(unique(nth)) == sum(nth %in% c("e", "c", "i"))) {
+ if (length(unique(nth)) == sum(is.element(nth, c("e", "c", "i")))) {
thresholds <- thresholds[match(c("e", "c", "i"), nth)]
}
}
@@ -184,7 +184,7 @@
}
else {
if (!is.null(nth)) {
- if (length(unique(nth)) == sum(nth %in% c("e1", "c1", "i1", "i2", "c2", "e2"))) {
+ if (length(unique(nth)) == sum(is.element(nth, c("e1", "c1", "i1", "i2", "c2", "e2")))) {
thresholds <- thresholds[match(c("e1", "c1", "i1", "i2", "c2", "e2"), nth)]
}
}
Modified: pkg/R/findRows.R
===================================================================
--- pkg/R/findRows.R 2018-08-27 20:04:52 UTC (rev 55)
+++ pkg/R/findRows.R 2018-11-01 22:32:34 UTC (rev 56)
@@ -24,7 +24,7 @@
# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
`findRows` <-
-function(expression = "", obj, remainders = TRUE, type = 1) {
+function(expression = "", obj, remainders = TRUE, type = 1, ...) {
if (any(type == 0)) {
type <- 0
}
@@ -36,6 +36,7 @@
cat("\n")
stop(simpleError("The truth table object is missing.\n\n"))
}
+ other.args <- list(...)
if (methods::is(obj, "tt")) {
noflevels <- obj$noflevels
conditions <- obj$options$conditions
@@ -51,6 +52,16 @@
call$outcome <- paste("~", call$outcome, sep = "")
}
call$incl.cut <- rev(obj$options$incl.cut)
+ if (length(other.args) > 0) {
+ if (length(setdiff(names(other.args), c("incl.cut", "n.cut", "pri.cut"))) > 0) {
+ cat("\n")
+ stop(simpleError("Only cutoff arguments can be specified for the negation of the outcome.\n\n"))
+ }
+ nms <- names(other.args)
+ for (i in seq(length(nms))) {
+ call[[nms[i]]] <- other.args[[nms[i]]]
+ }
+ }
nobj <- suppressWarnings(do.call("truthTable", call))
}
}
@@ -74,7 +85,7 @@
trexp <- attr(translate(paste(expression, collapse = "+"), snames = conditions), "retlist")
result <- matrix(ncol = length(trexp[[1]]), nrow = 0)
if (is.matrix(obj)) {
- noflevels <- getNoflevels(obj)
+ noflevels <- getLevels(obj)
}
for (i in seq(length(trexp))) {
rowi <- trexp[[i]]
Added: pkg/R/getLevels.R
===================================================================
--- pkg/R/getLevels.R (rev 0)
+++ pkg/R/getLevels.R 2018-11-01 22:32:34 UTC (rev 56)
@@ -0,0 +1,34 @@
+# Copyright (c) 2018, Adrian Dusa
+# All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, in whole or in part, are permitted provided that the
+# following conditions are met:
+# * Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer.
+# * Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in the
+# documentation and/or other materials provided with the distribution.
+# * The names of its contributors may NOT be used to endorse or promote products
+# derived from this software without specific prior written permission.
+#
+# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+# DISCLAIMED. IN NO EVENT SHALL ADRIAN DUSA BE LIABLE FOR ANY
+# DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+# LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+# ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+`getLevels` <-
+function(data) {
+ data <- as.data.frame(data)
+ colnames <- paste("V", ncol(data), sep = ".")
+ noflevels <- apply(data, 2, max) + 1
+ noflevels[noflevels == 1] <- 2
+ noflevels[apply(data, 2, function(x) any(x %% 1 > 0))] <- 2
+ return(as.vector(noflevels))
+}
Modified: pkg/R/getSolution.R
===================================================================
--- pkg/R/getSolution.R 2018-08-27 20:04:52 UTC (rev 55)
+++ pkg/R/getSolution.R 2018-11-01 22:32:34 UTC (rev 56)
@@ -41,6 +41,13 @@
}
expressions <- expressions[[1]]
}
+ else if (is.matrix(expressions)) {
+ if (nrow(expressions) == 1 & identical(unique(as.vector(expressions)), 0L)) {
+ if (enter) cat("\n")
+ stop(simpleError(paste0("All truth table configurations are used, all conditions are minimized.\n",
+ " Please check the truth table.", ifelse(enter, "\n\n", ""))))
+ }
+ }
if (FALSE) {
if (!missing(indata)) {
hastime <- logical(ncol(expressions))
@@ -77,10 +84,9 @@
if (row.dom & is.null(sol.matrix)) {
reduced.rows <- rowDominance(mtrx)
if (length(reduced.rows) > 0) {
- reduced$mtrx <- mtrx[reduced.rows, , drop=FALSE]
- reduced$expressions <- expressions[reduced.rows, , drop=FALSE]
+ reduced$mtrx <- mtrx[reduced.rows, , drop = FALSE]
+ reduced$expressions <- expressions[reduced.rows, , drop = FALSE]
}
- sol.matrix <- NULL
}
mtrx <- reduced$mtrx
setColnames(mtrx, initial)
@@ -88,17 +94,19 @@
if (nrow(mtrx) > 150 & nrow(mtrx) * ncol(mtrx) > 1500) {
message(sprintf("Starting to search all possible solutions in a PI chart with %d rows and %d columns.\nThis will take some time...", nrow(mtrx), ncol(mtrx)))
}
- sol.matrix <- solveChart(mtrx, all.sol = all.sol, ...=...)
+ sol.matrix <- solveChart(mtrx, all.sol = all.sol, ... = ...)
}
tokeep <- sort(unique(as.vector(unique(sol.matrix))))
all.PIs <- rownames(mtrx)[tokeep]
+ solm <- sol.matrix
sol.matrix <- matrix(rownames(mtrx)[sol.matrix], nrow = nrow(sol.matrix))
- reduced$expressions <- reduced$expressions[tokeep, , drop=FALSE]
+ reduced$expressions <- reduced$expressions[tokeep, , drop = FALSE]
solution.list <- writeSolution(sol.matrix, mtrx)
}
else {
all.PIs <- NA
solution.list <- NA
+ solm <- NA
}
- return(list(mtrx=mtrx, reduced=reduced, expressions=expressions, all.PIs=all.PIs, solution.list=solution.list))
+ return(list(expressions=expressions, mtrx=mtrx, reduced=reduced, all.PIs=all.PIs, solution.list=solution.list, sol.matrix=solm))
}
Modified: pkg/R/minimize.R
===================================================================
--- pkg/R/minimize.R 2018-08-27 20:04:52 UTC (rev 55)
+++ pkg/R/minimize.R 2018-11-01 22:32:34 UTC (rev 56)
@@ -47,7 +47,7 @@
inf.test <- if (is.element("inf.test", names(other.args))) other.args$inf.test else ""
relation <- if (is.element("relation", names(other.args))) other.args$relation else "sufficiency"
neg.out <- ifelse (is.element("neg.out", names(other.args)), other.args$neg.out, FALSE)
- enter <- ifelse (is.element("enter", names(other.args)), other.args$enter, TRUE)
+ enter <- ifelse (is.element("enter", names(other.args)), "", "\n")
if (is.null(exclude)) {
if (is.element("omit", names(other.args))) {
exclude <- other.args$omit
@@ -60,18 +60,18 @@
other.args$data <- NULL
}
if (any(is.element(c("min.dis", "mindis"), names(other.args)))) {
- if (enter) cat("\n")
- stop(simpleError(paste0("Argument \"min.dis\" is obsolete, please use the formal argument \"all.sol\".", ifelse(enter, "\n\n", ""))))
+ cat(enter)
+ stop(simpleError(paste0("Argument \"min.dis\" is obsolete, please use the formal argument \"all.sol\".", enter, enter)))
}
if (missing(input)) {
- if (enter) cat("\n")
- stop(simpleError(paste0("The input (a truth table or a dataset) is missing.", ifelse(enter, "\n\n", ""))))
+ cat(enter)
+ stop(simpleError(paste0("The input (a truth table or a dataset) is missing.", enter, enter)))
}
else {
if (is.matrix(input)) {
if (is.null(colnames(input))) {
- if (enter) cat("\n")
- stop(simpleError(paste0("The data should have column names.", ifelse(enter, "\n\n", ""))))
+ cat(enter)
+ stop(simpleError(paste0("The data should have column names.", enter, enter)))
}
if (any(duplicated(rownames(input)))) {
rownames(input) <- seq(nrow(input))
@@ -84,15 +84,15 @@
}
}
if(!(is.data.frame(input) | methods::is(input, "tt"))) {
- if (enter) cat("\n")
- stop(simpleError(paste0("The input should be a truth table or a dataset.", ifelse(enter, "\n\n", ""))))
+ cat(enter)
+ stop(simpleError(paste0("The input should be a truth table or a dataset.", enter, enter)))
}
}
print.truth.table <- details & !methods::is(input, "tt")
if (identical(include, "")) {
if (!identical(dir.exp, "")) {
- if (enter) cat("\n")
- stop(simpleError(paste0("Directional expectations were specified, without including the remainders.", ifelse(enter, "\n\n", ""))))
+ cat(enter)
+ stop(simpleError(paste0("Directional expectations were specified, without including the remainders.", enter, enter)))
}
}
if (is.character(explain) & !identical(explain, "1")) {
@@ -116,8 +116,8 @@
}
else {
if (identical(outcome, "")) {
- if (enter) cat("\n")
- stop(simpleError(paste0("Consider creating a truth table first, or formally specify the argument \"outcome\".", ifelse(enter, "\n\n", ""))))
+ cat(enter)
+ stop(simpleError(paste0("Consider creating a truth table first, or formally specify the argument \"outcome\".", enter, enter)))
}
if (any(c(pi.cons, sol.cons) > 0) & incl.cut[1] == 1) {
incl.cut[1] <- min(c(pi.cons, sol.cons))
@@ -135,8 +135,8 @@
outcome <- substring(outcome, 2)
}
if (!is.element(toupper(curlyBrackets(outcome, outside = TRUE)), colnames(input))) {
- if (enter) cat("\n")
- stop(simpleError(paste0("Inexisting outcome name.", ifelse(enter, "\n\n", ""))))
+ cat(enter)
+ stop(simpleError(paste0("Inexisting outcome name.", enter, enter)))
}
outcome.name <- ifelse (tilde1st(outcome), substring(outcome, 2), outcome)
if (grepl("\\{|\\}", outcome)) {
@@ -202,8 +202,8 @@
neg.matrix <- matrix(as.numeric(neg.matrix), ncol = length(noflevels)) + 1
rownames(neg.matrix) <- drop((neg.matrix - 1) %*% mbase) + 1
if (sum(subset.pos) == 0) {
- if (enter) cat("\n")
- stop(simpleError(paste0("None of the values in OUT is explained. Please check the truth table.", ifelse(enter, "\n\n", ""))))
+ cat(enter)
+ stop(simpleError(paste0("None of the values in OUT is explained. Please check the truth table.", enter, enter)))
}
inputt <- as.matrix(tt$tt[subset.tt, seq(length(noflevels)), drop = FALSE])
rownames(inputt) <- drop(inputt %*% mbase) + 1
@@ -250,19 +250,19 @@
}
}
output$negatives <- sort(drop((neg.matrix - 1) %*% mbase) + 1)
- pos.matrix <- pos.matrix[!tomit, , drop=FALSE]
- inputt <- inputt[!tomitinputt, , drop=FALSE]
+ pos.matrix <- pos.matrix[!tomit, , drop = FALSE]
+ inputt <- inputt[!tomitinputt, , drop = FALSE]
inputcases <- inputcases[!tomitinputt]
rownms <- rownames(inputt)
if (nrow(pos.matrix) == 0) {
- if (enter) cat("\n")
- stop(simpleError(paste0("Nothing to explain. Please check the truth table.", ifelse(enter, "\n\n", ""))))
+ cat(enter)
+ stop(simpleError(paste0("Nothing to explain. Please check the truth table.", enter, enter)))
}
incl.rem <- is.element("?", include)
- if (nrow(neg.matrix) == 0 & incl.rem & method == "QMC") {
- if (enter) cat("\n")
- stop(simpleError(paste0("All truth table configurations have been included, all conditions are minimized.\n",
- "Please check the truth table.", ifelse(enter, "\n\n", ""))))
+ if (nrow(neg.matrix) == 0 & incl.rem) {
+ cat(enter)
+ stop(simpleError(paste0("All truth table configurations are used, all conditions are minimized.\n",
+ " Please check the truth table.", enter, enter)))
}
expressions <- pos.matrix
recdata[, conditions] <- as.data.frame(lapply(recdata[, conditions, drop = FALSE], function(x) {
@@ -389,7 +389,7 @@
listIC$pims <- NULL
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]
+ mtrx <- p.sol$mtrx[p.sol$all.PIs, , drop = FALSE]
SA <- TRUE
if (is.element("SA", names(other.args))) {
SA <- other.args$SA
@@ -401,95 +401,110 @@
}
mbaseexpr <- rev(c(1, cumprod(rev(noflevels[is.element(conds, colnames(p.sol$reduced$expressions))] + 1))))[-1]
output$SA <- lapply(p.sol$solution.list[[1]], function(x) {
- p.expressions <- p.sol$reduced$expressions[x, , drop=FALSE]
+ p.expressions <- p.sol$reduced$expressions[x, , drop = FALSE]
temp <- apply(p.expressions, 1, function(pr) {
- indices <- rev(which(!pr))
- SA <- NULL
+ indices <- rev(which(pr == 0))
+ tempr <- NULL
for (k in indices) {
- if (is.null(SA)) {
- SA <- drop(mbaseexpr %*% pr) + sum(mbaseexpr[!pr])
- tempSA <- SA
+ if (is.null(tempr)) {
+ tempr <- drop(mbaseexpr %*% pr) + sum(mbaseexpr[pr == 0])
+ temp2 <- tempr
}
for (lev in seq(noflevels[k] - 1)) {
- tempSA <- c(tempSA, SA + mbaseexpr[k]*lev)
+ temp2 <- c(temp2, tempr + mbaseexpr[k]*lev)
}
- SA <- tempSA
+ tempr <- temp2
}
- return(SA)
+ return(tempr)
})
- if (all(is.null(temp))) {
- return(NULL)
- }
- else {
- temp <- sort(unique(as.vector(unlist(temp))))
- temp <- temp[!is.element(temp, drop(inputt %*% mbaseplus))]
- if (length(temp) > 0) {
- SA <- getRow(temp + 1, noflevels + 1) - 1
- colnames(SA) <- colnames(inputt)
- rownames(SA) <- drop(SA %*% mbase) + 1
- return(SA)
- }
- else {
- return(NULL)
- }
- }
+ if (all(is.null(temp))) return(NULL)
+ temp <- sort(unique(as.vector(unlist(temp))))
+ temp <- temp[!is.element(temp, drop(inputt %*% mbaseplus))]
+ if (length(temp) == 0) return(NULL)
+ SAx <- getRow(temp + 1, noflevels + 1) - 1
+ colnames(SAx) <- colnames(inputt)
+ rownames(SAx) <- drop(SAx %*% mbase) + 1
+ return(SAx)
})
prettyNums <- formatC(seq(length(p.sol$solution.list[[1]])), digits = nchar(length(p.sol$solution.list[[1]])) - 1, flag = 0)
- names(output$SA) <- paste("M", prettyNums, sep="")
+ names(output$SA) <- paste("M", prettyNums, sep = "")
if (!identical(dir.exp, "") & !identical(include, "") & !identical(c.sol$solution.list, NA)) {
i.sol <- vector("list", length(c.sol$solution.list[[1]])*length(p.sol$solution.list[[1]]))
index <- 1
for (c.s in seq(length(c.sol$solution.list[[1]]))) {
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/qca -r 56
More information about the Qca-commits
mailing list