[Qca-commits] r67 - in pkg: . R inst inst/staticdocs man src
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Jan 28 15:02:40 CET 2019
Author: dusadrian
Date: 2019-01-28 15:02:39 +0100 (Mon, 28 Jan 2019)
New Revision: 67
Modified:
pkg/DESCRIPTION
pkg/R/fuzzyand.R
pkg/R/fuzzyor.R
pkg/R/getSolution.R
pkg/R/minimize.R
pkg/R/numeric.R
pkg/R/print.R
pkg/R/solveChart.R
pkg/R/translate.R
pkg/R/truthTable.R
pkg/inst/ChangeLog
pkg/inst/staticdocs/QCA.package.html
pkg/man/QCA.package.Rd
pkg/man/minimize.Rd
pkg/man/pof.Rd
pkg/man/truthTable.Rd
pkg/src/QCA.c
Log:
pri.cut does OUT = 0 instead of remainders
Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2019-01-20 15:01:41 UTC (rev 66)
+++ pkg/DESCRIPTION 2019-01-28 14:02:39 UTC (rev 67)
@@ -1,6 +1,6 @@
Package: QCA
Version: 3.4-1
-Date: 2019-01-20
+Date: 2019-01-28
Title: Qualitative Comparative Analysis
Authors at R: c(person("Adrian", "Dusa", role = c("aut", "cre", "cph"),
email = "dusa.adrian at unibuc.ro"),
@@ -28,7 +28,7 @@
minimal causal combination that explains a given phenomenon.
License: GPL (>= 2)
NeedsCompilation: yes
-Packaged: 2019-01-20 14:59:02 UTC; dusadrian
+Packaged: 2019-01-28 13:53:26 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/R/fuzzyand.R
===================================================================
--- pkg/R/fuzzyand.R 2019-01-20 15:01:41 UTC (rev 66)
+++ pkg/R/fuzzyand.R 2019-01-28 14:02:39 UTC (rev 67)
@@ -52,17 +52,9 @@
}
for (i in seq(length(funargs))) {
tc <- tryCatch(eval.parent(parse(text = funargs[i])), error = function(e) e, warning = function(w) w)
- tc <- capture.output(dim(tc))[1]
- if (identical(substring(gsub("[[:space:]]", "", tc), 1, 9), "function(")) {
- tc <- simpleError("simpleError")
- }
- if (grepl("simpleError", tc)) {
+ if (is.function(tc) | inherits(tc, "error")) {
tc <- tryCatch(eval.parent(parse(text = toupper(funargs[i]))), error = function(e) e, warning = function(w) w)
- tc <- capture.output(dim(tc))[1]
- if (identical(substring(gsub("[[:space:]]", "", tc), 1, 9), "function(")) {
- tc <- simpleError("simpleError")
- }
- if (grepl("simpleError", tc)) {
+ if (is.function(tc) | inherits(tc, "error")) {
cat("\n")
stop(simpleError(sprintf("Object '%s' not found.\n\n", funargs[i])))
}
Modified: pkg/R/fuzzyor.R
===================================================================
--- pkg/R/fuzzyor.R 2019-01-20 15:01:41 UTC (rev 66)
+++ pkg/R/fuzzyor.R 2019-01-28 14:02:39 UTC (rev 67)
@@ -52,17 +52,9 @@
}
for (i in seq(length(funargs))) {
tc <- tryCatch(eval.parent(parse(text = funargs[i])), error = function(e) e, warning = function(w) w)
- tc <- capture.output(dim(tc))[1]
- if (identical(substring(gsub("[[:space:]]", "", tc), 1, 9), "function(")) {
- tc <- simpleError("simpleError")
- }
- if (grepl("simpleError", tc)) {
+ if (is.function(tc) | inherits(tc, "error")) {
tc <- tryCatch(eval.parent(parse(text = toupper(funargs[i]))), error = function(e) e, warning = function(w) w)
- tc <- capture.output(dim(tc))[1]
- if (identical(substring(gsub("[[:space:]]", "", tc), 1, 9), "function(")) {
- tc <- simpleError("simpleError")
- }
- if (grepl("simpleError", tc)) {
+ if (is.function(tc) | inherits(tc, "error")) {
cat("\n")
stop(simpleError(sprintf("Object '%s' not found.\n\n", funargs[i])))
}
Modified: pkg/R/getSolution.R
===================================================================
--- pkg/R/getSolution.R 2019-01-20 15:01:41 UTC (rev 66)
+++ pkg/R/getSolution.R 2019-01-28 14:02:39 UTC (rev 67)
@@ -32,6 +32,9 @@
if (is.list(expressions)) {
mtrx <- expressions[[2]]
sol.matrix <- expressions[[3]]
+ if (ncol(sol.matrix) == 1 & is.double(sol.matrix)) {
+ warning(simpleWarning("The PI chart is too complex, only the first minimal solution returned.\n\n"))
+ }
if (is.null(sol.matrix)) {
if (enter) cat("\n")
stop(simpleError(paste("There are no solutions, given these constraints.", ifelse(enter, "\n\n", ""))))
Modified: pkg/R/minimize.R
===================================================================
--- pkg/R/minimize.R 2019-01-20 15:01:41 UTC (rev 66)
+++ pkg/R/minimize.R 2019-01-28 14:02:39 UTC (rev 67)
@@ -316,10 +316,6 @@
min.pin = min.pin, row.dom = row.dom, all.sol = all.sol, sol.cons = sol.cons,
sol.cov = sol.cov, data = extended.data, fs = tt$fs),
PACKAGE = "QCA")
- if (is.null(expressions)) {
- cat(enter)
- stop(simpleError(paste0("The PI chart is too complex for an exact solution.", enter, enter)))
- }
}
p.sol <- getSolution(expressions=expressions, mv=mv, use.tilde=use.tilde, collapse=collapse, inputt=inputt, row.dom=row.dom, initial=rownms, all.sol=all.sol, indata=indata, excl.matrix=excl.matrix, ...=...)
}
Modified: pkg/R/numeric.R
===================================================================
--- pkg/R/numeric.R 2019-01-20 15:01:41 UTC (rev 66)
+++ pkg/R/numeric.R 2019-01-28 14:02:39 UTC (rev 67)
@@ -31,9 +31,12 @@
function(x) {
return(suppressWarnings(as.numeric(as.character(x))))
}
+`aeqb` <- function(a, b) {
+ abs(a - b) <= .Machine$double.eps^0.5
+}
`agteb` <- function(a, b) {
- all(a > b | abs(a - b) <= .Machine$double.eps^0.5)
+ a > b | aeqb(a, b)
}
`alteb` <- function(a, b) {
- all(a < b | abs(a - b) <= .Machine$double.eps^0.5)
+ a < b | aeqb(a, b)
}
Modified: pkg/R/print.R
===================================================================
--- pkg/R/print.R 2019-01-20 15:01:41 UTC (rev 66)
+++ pkg/R/print.R 2019-01-28 14:02:39 UTC (rev 67)
@@ -262,10 +262,10 @@
sufnec <- logical(length(x$i.sol))
for (i in seq(length(x$i.sol))) {
if (is.element("overall", names(x$i.sol[[i]]$IC))) {
- sufnec[i] <- agteb(x$i.sol[[i]]$IC$overall$sol.incl.cov[3], sol.cov)
+ sufnec[i] <- all(agteb(x$i.sol[[i]]$IC$overall$sol.incl.cov[3], sol.cov))
}
else {
- sufnec[i] <- agteb(x$i.sol[[i]]$IC$sol.incl.cov[3], sol.cov)
+ sufnec[i] <- all(agteb(x$i.sol[[i]]$IC$sol.incl.cov[3], sol.cov))
}
}
sufnec.char <- rep("", length(sufnec))
@@ -314,7 +314,7 @@
cat("Number of multiple-covered cases:", mult.cov, "\n\n")
}
if (length(x$solution) == 1) {
- sufnec <- agteb(x$IC$sol.incl.cov[3], sol.cov)
+ sufnec <- all(agteb(x$IC$sol.incl.cov[3], sol.cov))
sufnec <- paste(ifelse(sufnec, "<", ""), "=>", sep="")
cat(sprintf("M1: %s\n", prettyString(x$solution[[1]], line.length - 4, 4, "+", sufnec, outcome)))
}
@@ -322,7 +322,7 @@
prettyNums <- formatC(seq(length(x$solution)), digits = nchar(length(x$solution)) - 1, flag = 0)
sufnec <- logical(length(x$solution))
for (i in seq(length(x$solution))) {
- sufnec[i] <- agteb(x$IC$individual[[i]]$sol.incl.cov[3], sol.cov)
+ sufnec[i] <- all(agteb(x$IC$individual[[i]]$sol.incl.cov[3], sol.cov))
}
sufnec.char <- rep("", length(sufnec))
for (i in seq(length(x$solution))) {
@@ -870,10 +870,10 @@
sufnec <- logical(length(x$i.sol))
for (i in seq(length(x$i.sol))) {
if (is.element("overall", names(x$i.sol[[i]]$IC))) {
- sufnec[i] <- agteb(x$i.sol[[i]]$IC$overall$sol.incl.cov[c(1, 3)], c(sol.cons, sol.cov))
+ sufnec[i] <- all(agteb(x$i.sol[[i]]$IC$overall$sol.incl.cov[c(1, 3)], c(sol.cons, sol.cov)))
}
else {
- sufnec[i] <- agteb(x$i.sol[[i]]$IC$sol.incl.cov[c(1, 3)], c(sol.cons, sol.cov))
+ sufnec[i] <- all(agteb(x$i.sol[[i]]$IC$sol.incl.cov[c(1, 3)], c(sol.cons, sol.cov)))
}
}
if (any(sufnec)) {
@@ -894,7 +894,7 @@
else {
sufnec <- logical(length(x$solution))
if (length(x$solution) == 1) {
- sufnec <- agteb(x$IC$sol.incl.cov[c(1, 3)], c(sol.cons, sol.cov))
+ sufnec <- all(agteb(x$IC$sol.incl.cov[c(1, 3)], c(sol.cons, sol.cov)))
if (sufnec) {
cat(paste("M1: ", prettyString(x$solution[[1]], line.length - 4, 4, "+", "<=>", outcome), "\n", sep=""))
toreturn <- TRUE
@@ -902,7 +902,7 @@
}
else {
for (i in seq(length(x$solution))) {
- sufnec[i] <- agteb(x$IC$individual[[i]]$sol.incl.cov[c(1, 3)], c(sol.cons, sol.cov))
+ sufnec[i] <- all(agteb(x$IC$individual[[i]]$sol.incl.cov[c(1, 3)], c(sol.cons, sol.cov)))
}
if (any(sufnec)) {
prettyNums <- formatC(seq(length(x$solution)), digits = nchar(length(x$solution)) - 1, flag = 0)
Modified: pkg/R/solveChart.R
===================================================================
--- pkg/R/solveChart.R 2019-01-20 15:01:41 UTC (rev 66)
+++ pkg/R/solveChart.R 2019-01-28 14:02:39 UTC (rev 67)
@@ -48,13 +48,12 @@
cat("\n")
stop(simpleError("The PI chart cannot be solved.\n\n"))
}
- else if (foundm < 0) {
- cat("\n")
- stop(simpleError("The PI chart is too complex for an exact solution.\n\n"))
- }
if (all(dim(chart) > 1)) {
if (is.null(depth)) depth <- 0L
output <- .Call("C_solveChart", t(matrix(as.logical(chart), nrow = nrow(chart))), all.sol, as.integer(depth), PACKAGE = "QCA")
+ if (ncol(output) == 1 & is.double(output)) {
+ warning(simpleWarning("The PI chart is too complex, only the first minimal solution returned.\n\n"))
+ }
output[output == 0] <- NA
}
else {
Modified: pkg/R/translate.R
===================================================================
--- pkg/R/translate.R 2019-01-20 15:01:41 UTC (rev 66)
+++ pkg/R/translate.R 2019-01-28 14:02:39 UTC (rev 67)
@@ -84,6 +84,12 @@
else {
noflevels <- splitstr(noflevels)
}
+ expression <- gsub("[[:space:]]", "", expression)
+ if (identical("1-", substring(expression, 1, 2))) {
+ explist <- list(expression = gsub("1-", "", expression), snames = snames)
+ if (!missing(noflevels)) explist$noflevels <- noflevels
+ expression <- do.call("negate", explist)
+ }
if (any(grepl(",", gsub(",[0-9]", "", expression)))) {
expression <- splitstr(expression)
}
Modified: pkg/R/truthTable.R
===================================================================
--- pkg/R/truthTable.R 2019-01-20 15:01:41 UTC (rev 66)
+++ pkg/R/truthTable.R 2019-01-28 14:02:39 UTC (rev 67)
@@ -152,14 +152,14 @@
ipc <- ipc[1:3, , drop = FALSE]
rownames(minmat) <- rownames(data)
rownames(ipc) <- c("n", "incl", "PRI")
- exclude <- ipc[1, ] < n.cut | ipc[3, ] < pri.cut
+ exclude <- ipc[1, ] < n.cut
if (sum(!exclude) == 0) {
cat("\n")
stop(simpleError(paste0("There are no configurations, using these cutoff values.", ifelse(enter, "\n\n", ""))))
}
tt$OUT <- "?"
- tt$OUT[!exclude] <- as.numeric(ipc[2, !exclude] >= (ic1 - .Machine$double.eps ^ 0.5))
- tt$OUT[ipc[2, !exclude] <= (ic1 - .Machine$double.eps ^ 0.5) & ipc[2, !exclude] >= (ic0 - .Machine$double.eps ^ 0.5)] <- "C"
+ tt$OUT[!exclude] <- 1 * (agteb(ipc[2, !exclude], ic1) & agteb(ipc[3, !exclude], pri.cut))
+ tt$OUT[ipc[2, !exclude] < ic1 & agteb(ipc[2, !exclude], ic0)] <- "C"
tt <- cbind(tt, t(ipc))
cases <- sapply(rownstt, function(x) {
paste(rownames(data)[line.data == x], collapse = ",")
@@ -172,8 +172,8 @@
cases <- cases[!exclude]
DCC <- DCC[!exclude]
excluded <- tt[exclude, , drop = FALSE]
- excluded$OUT <- as.numeric(ipc[2, exclude] >= (ic1 - .Machine$double.eps ^ 0.5))
- excluded$OUT[ipc[2, exclude] < ic1 & ipc[2, exclude] >= (ic0 - .Machine$double.eps ^ 0.5)] <- "C"
+ excluded$OUT <- 1 * (agteb(ipc[2, exclude], ic1) & agteb(ipc[3, exclude], pri.cut))
+ excluded$OUT[ipc[2, exclude] < ic1 & agteb(ipc[2, exclude], ic0)] <- "C"
if (length(conditions) < 8) {
ttc <- as.data.frame(matrix(nrow = prod(noflevels), ncol = ncol(tt)))
colnames(ttc) <- colnames(tt)
Modified: pkg/inst/ChangeLog
===================================================================
--- pkg/inst/ChangeLog 2019-01-20 15:01:41 UTC (rev 66)
+++ pkg/inst/ChangeLog 2019-01-28 14:02:39 UTC (rev 67)
@@ -1,3 +1,15 @@
+Version 3.5
+ o New: first implementation of conjunctural directional expectations
+ (thanks to Carsten Schneider for insisting)
+ o Improved: function simplify() now able to solve even further
+ simplifications, using a method advanced by Quine
+ o Improved: to avoid infinite running times for very complex PI charts,
+ only the first exact solution is returned, with a warning message
+ (thanks to Konan Seny Kan for the example)
+ o Changed: function pof() no longer evaluates matrices of implicants
+ and line numbers from the implicants matrix, this was never used and
+ became obsolete after introducing DNF expressions.
+
Version 3.4
o New: function findRows() gains a three dots argument "..." to allow
passing a combination of cutoff values to function truthTable() for
Modified: pkg/inst/staticdocs/QCA.package.html
===================================================================
--- pkg/inst/staticdocs/QCA.package.html 2019-01-20 15:01:41 UTC (rev 66)
+++ pkg/inst/staticdocs/QCA.package.html 2019-01-28 14:02:39 UTC (rev 67)
@@ -121,7 +121,7 @@
</tr><tr><td> 3.4-1 </td>
</tr><tr><td>
Date: </td>
-</tr><tr><td> 2019-01-20 </td>
+</tr><tr><td> 2019-01-28 </td>
</tr><tr><td>
License: </td>
</tr><tr><td> GPL (>= 2)</td>
Modified: pkg/man/QCA.package.Rd
===================================================================
--- pkg/man/QCA.package.Rd 2019-01-20 15:01:41 UTC (rev 66)
+++ pkg/man/QCA.package.Rd 2019-01-28 14:02:39 UTC (rev 67)
@@ -56,7 +56,7 @@
Package: \tab QCA\cr
Type: \tab Package\cr
Version: \tab 3.4-1\cr
- Date: \tab 2019-01-20\cr
+ Date: \tab 2019-01-28\cr
License: \tab GPL (>= 2)\cr
}
}
Modified: pkg/man/minimize.Rd
===================================================================
--- pkg/man/minimize.Rd 2019-01-20 15:01:41 UTC (rev 66)
+++ pkg/man/minimize.Rd 2019-01-28 14:02:39 UTC (rev 67)
@@ -85,9 +85,9 @@
causal combinations.
The argument \bold{\code{dir.exp}} is used to specify directional expectations, as
-described by Ragin (2003). They can be specified using SOP expressions, which opens
-up the possibility to experiment with conjunctural directional expectations. Don't care
-conditions are simply left unspecified.
+described by Ragin (2003). They can be specified using DNF (disjunctive normal form)
+expressions, which opens up the possibility to experiment with conjunctural
+directional expectations. Don't care conditions are simply left unspecified.
Activating the \bold{\code{details}} argument has the effect of printing parameters
of fit for each prime implicant and each overall solution, the essential prime
Modified: pkg/man/pof.Rd
===================================================================
--- pkg/man/pof.Rd 2019-01-20 15:01:41 UTC (rev 66)
+++ pkg/man/pof.Rd 2019-01-28 14:02:39 UTC (rev 67)
@@ -19,11 +19,11 @@
}
\arguments{
- \item{setms}{A data frame of (calibrated) set memberships, or a matrix of implicants,
- or a vector of row numbers from the implicant matrix, or a character expression}
- \item{data}{The calibrated data frame, in case the \bold{\code{outcome}} is a name.}
+ \item{setms}{A data frame or a single vector of (calibrated) set memberships, or an
+ expression written in disjunctive normal form.}
\item{outcome}{The name of the outcome column from a calibrated data frame, or
the actual numerical column from the data frame, representing the outcome.}
+ \item{data}{A calibrated data frame.}
\item{conditions}{A single string containing the conditions' (columns) names
separated by commas, or a character vector of conditions' names.}
\item{relation}{The set relation to \bold{\code{outcome}}, either \bold{\code{"necessity"}}
@@ -59,17 +59,17 @@
- any other, custom created combinations of set memberships.
When specified as a matrix, \bold{\code{setms}} contains the crisp causal combinations
-similar to those found in the truth table. If some of the causal conditions have
-been minimized, they can be replaced by the numerical value \bold{\code{-1}} (see
-examples section). The number of columns in the matrix should be equal to the number
-of causal conditions in the original \bold{\code{data}}.
+similar to those found in the truth table. The number of columns in the matrix should be
+equal to the number of causal conditions in the original \bold{\code{data}}. If some of
+them are minimized, they can be replaced by the numerical value \bold{\code{-1}} (see
+examples section).
More generally, \bold{\code{setms}} can be a numerical vector of line numbers from the
implicant matrix (see function \bold{\code{\link{createMatrix}()}}), which are automatically
transformed into their corresponding set membership scores.
-The argument \bold{\code{setms}} can also be a string expression,
-written in sum of products (SOP) form.
+The argument \bold{\code{setms}} can also be a string expression, written in disjunctive
+normal form (DNF, also known as SOP - sum or products).
For all situation when \bold{\code{setms}} is something else than a data frame, it
requires the original \bold{\code{data}} to generate the set memberships.
Modified: pkg/man/truthTable.Rd
===================================================================
--- pkg/man/truthTable.Rd 2019-01-20 15:01:41 UTC (rev 66)
+++ pkg/man/truthTable.Rd 2019-01-28 14:02:39 UTC (rev 67)
@@ -26,7 +26,7 @@
\item{n.cut}{The minimum number of cases under which a truth table row is
declared as a remainder.}
\item{pri.cut}{The minimal score for the \bold{\code{PRI}} - proportional reduction in
- inconsistency, under which a truth table row is declared as a remainder.}
+ inconsistency, under which a truth table row is declared as negative.}
\item{complete}{Logical, print complete truth table.}
\item{use.letters}{Logical, use letters instead of causal conditions' names.}
\item{show.cases}{Logical, print case names.}
@@ -82,7 +82,7 @@
to negate outcomes using lower case letters, a situation where it really does
matter how the outcome and/or conditions are specified.
-The argument \bold{\code{incl.cut}} replaces the (deprecated, but still backwards
+The argument \bold{\code{incl.cut}} replaces both (deprecated, but still backwards
compatible) former arguments \bold{\code{incl.cut1}} and \bold{\code{incl.cut0}}.
Most of the analyses use the inclusion cutoff for the presence of the output
(code \bold{\code{"1"}}). When users need both inclusion cutoffs (see below),
@@ -102,18 +102,20 @@
equal to \bold{\code{ic1}}, but otherwise \bold{\code{ic0}} should always be lower
than \bold{\code{ic1}}.
-Using these two cutoffs, the observed combinations are coded with:
+Using these two cutoffs, as well as \bold{\code{pri.cut}} the observed combinations are
+coded with:
\tabular{rl}{
-\bold{\code{"1"}} \tab if they have an inclusion score above \bold{\code{ic1}}\cr \cr
+\bold{\code{"1"}} \tab if they have an inclusion score of at least \bold{\code{ic1}}\cr
+ \tab and a PRI score of at least \bold{\code{pri.cut}}\cr \cr
\bold{\code{"C"}} \tab if they have an inclusion score below \bold{\code{ic1}} and
- above \bold{\code{ic0}} (contradiction)\cr \cr
-\bold{\code{"0"}} \tab if they have an inclusion score below \bold{\code{ic0}}\cr
+ at least \bold{\code{ic0}} (contradiction)\cr \cr
+\bold{\code{"0"}} \tab if they have an inclusion score below \bold{\code{ic0}} or \cr
+ \tab a PRI score below \bold{\code{pri.cut}}
}
The argument \bold{\code{n.cut}} specifies the frequency threshold under which a truth
-table row is coded as a remainder, irrespective of its inclusion score. The sample
-happens with the \bold{\code{pri.cut}}, that establishes a minimal cutoff for the PRI.
+table row is coded as a remainder, irrespective of its inclusion score.
When argument \bold{\code{show.cases}} is set to \bold{\code{TRUE}}, the case names will be
printed at their corresponding row in the truth table. The resulting object always contains
Modified: pkg/src/QCA.c
===================================================================
--- pkg/src/QCA.c 2019-01-20 15:01:41 UTC (rev 66)
+++ pkg/src/QCA.c 2019-01-28 14:02:39 UTC (rev 67)
@@ -407,6 +407,7 @@
}
int c = 0;
while (c < picols && *keep_searching) {
+ sortcol[c] = c;
colsums[c] = 0;
for (int r = 0; r < pirows; r++) {
colsums[c] += p_pichart[c * pirows + r];
@@ -416,7 +417,6 @@
if (!p_cols[c]) {
--(*survcols);
}
- sortcol[c] = c;
if (colsums[c] == pirows) {
*keep_searching = FALSE;
*survcols = 0;
@@ -439,7 +439,7 @@
if (p_cols[sortcol[c1]]) {
for (int c2 = c1 + 1; c2 < picols; c2++) {
if (p_cols[sortcol[c2]]) {
- if (colsums[sortcol[c1]] > colsums[sortcol[c2]]) {
+ if (colsums[sortcol[c1]] >= colsums[sortcol[c2]]) {
Rboolean itcovers = TRUE;
int r = 0;
while (r < pirows && itcovers) {
@@ -559,7 +559,7 @@
UNPROTECT(1);
return(out);
}
-static R_INLINE Rboolean allcovered(int p_basemat[], int pirows, int foundPI) {
+static R_INLINE Rboolean allCovered(int p_basemat[], int pirows, int foundPI) {
Rboolean allrows = TRUE;
int r = 0;
while (r < pirows && allrows) {
@@ -598,7 +598,7 @@
UNPROTECT(1);
return(obj);
}
-static R_INLINE Rboolean all_different(int mat[], int rows, int endrow, int col, int c) {
+static R_INLINE Rboolean allDifferent(int mat[], int rows, int endrow, int col, int c) {
Rboolean same = FALSE;
int r = 0;
while (r < endrow && !same) {
@@ -628,7 +628,7 @@
int survcpos[foundPI];
int totcols = foundPI;
Rboolean keep_searching = TRUE;
- if (allcovered(p_basemat, pirows, foundPI)) {
+ if (allCovered(p_basemat, pirows, foundPI)) {
int survrows = pirows;
int survcols = foundPI;
Rboolean identical = FALSE;
@@ -672,7 +672,7 @@
int c = 0;
while (c < survcols && keep_searching) {
sums[c] = 0;
- if (all_different(p_estimat, survrows, newminrows, tc, c)) {
+ if (allDifferent(p_estimat, survrows, newminrows, tc, c)) {
for (int r = 0; r < survrows; r++) {
sums[c] += 1 * (p_coverage[tc * survrows + r] || p_basemat[c * survrows + r]);
}
@@ -695,17 +695,11 @@
}
newcheck++;
if (newcheck == estimcheck) {
- estimcheck *= 2;
- if ((survrows * estimcheck) < pow(2, 25)) {
+ estimcheck *= 2;
SET_VECTOR_ELT(usage, 3, temp = resize(temp, survrows * estimcheck));
p_temp = INTEGER(temp);
SET_VECTOR_ELT(usage, 3, tempcov = resize(tempcov, survrows * estimcheck));
p_tempcov = LOGICAL(tempcov);
- }
- else {
- keep_searching = FALSE;
- newminrows = -2;
- }
}
}
}
@@ -733,12 +727,7 @@
}
}
int totsol;
- if (newminrows >= 0) {
totsol = mincols + newminrows;
- }
- else {
- totsol = -1;
- }
UNPROTECT(1);
return(totsol);
}
@@ -801,6 +790,25 @@
}
solfound = 1;
}
+ int nck = choose(picols, k);
+ if (nck == NA_INTEGER) {
+ solfound = 1;
+ SET_VECTOR_ELT(usage, 2, temp2 = allocMatrix(REALSXP, k, 1));
+ double *p_tempreal = REAL(temp2);
+ for (int i = 0; i < k; i++) {
+ p_tempreal[i] = sol[i] + 1;
+ }
+ int tempcopy;
+ for (int r1 = 0; r1 < k; r1++) {
+ for (int r2 = r1 + 1; r2 < k; r2++) {
+ if (p_tempreal[r1] > p_tempreal[r2]) {
+ tempcopy = p_tempreal[r2];
+ p_tempreal[r2] = p_tempreal[r1];
+ p_tempreal[r1] = tempcopy;
+ }
+ }
+ }
+ }
if (solfound == 0) {
if (LOGICAL(allsol)[0]) {
SET_VECTOR_ELT(usage, 0, indmat = allocMatrix(INTSXP, picols, pirows));
@@ -1214,7 +1222,7 @@
mbase[c] = mbase[c - 1] * noflevels[tempk[c - 1]];
}
}
-static R_INLINE void get_decimals(int posrows, int negrows, int k, int decpos[], int decneg[], int p_posmat[], int p_negmat[], int tempk[], int mbase[]) {
+static R_INLINE void getDecimals(int posrows, int negrows, int k, int decpos[], int decneg[], int p_posmat[], int p_negmat[], int tempk[], int mbase[]) {
for (int r = 0; r < posrows; r++) {
decpos[r] = 0;
for (int c = 0; c < k; c++) {
@@ -1228,7 +1236,7 @@
}
}
}
-static R_INLINE void get_uniques(int posrows, int *found, int decpos[], Rboolean possiblePI[], int possiblePIrows[]) {
+static R_INLINE void getUniques(int posrows, int *found, int decpos[], Rboolean possiblePI[], int possiblePIrows[]) {
for (int r = 1; r < posrows; r++) {
int prev = 0;
Rboolean unique = TRUE;
@@ -1291,7 +1299,7 @@
get_noflevels(noflevels, p_tt, nconds, ttrows);
int foundPI = 0;
int prevfoundPI = 0;
- int estimpi = 10;
+ int estimpi = 10000;
SET_VECTOR_ELT(usage, 3, pichart = allocMatrix(LGLSXP, posrows, estimpi));
p_pichart = LOGICAL(pichart);
memset(p_pichart, FALSE, posrows * estimpi * sizeof(int));
@@ -1345,13 +1353,13 @@
increment(k, &e, &h, nconds + last, tempk, 0);
last = FALSE;
fill_mbase(mbase, tempk, noflevels, k);
- get_decimals(posrows, neresizes, k, decpos, decneg, p_posmat, p_negmat, tempk, mbase);
+ getDecimals(posrows, neresizes, k, decpos, decneg, p_posmat, p_negmat, tempk, mbase);
int possiblePIrows[posrows];
possiblePIrows[0] = 0;
Rboolean possiblePI[posrows];
possiblePI[0] = TRUE;
int found = 1;
- get_uniques(posrows, &found, decpos, possiblePI, possiblePIrows);
+ getUniques(posrows, &found, decpos, possiblePI, possiblePIrows);
int compare = found;
if (picons > 0) {
int val[k];
@@ -1462,120 +1470,114 @@
}
k += 1;
}
- if (checkmin >= 0) {
- SEXP dimnames, ttcolnms, colnms;
- SET_VECTOR_ELT(usage, 6, dimnames = allocVector(VECSXP, 2));
- if (hasColnames(tt)) {
- SET_VECTOR_ELT(usage, 7, ttcolnms = VECTOR_ELT(getAttrib(tt, R_DimNamesSymbol), 1));
- SET_VECTOR_ELT(usage, 8, colnms = allocVector(STRSXP, nconds));
- for (int i = 0; i < nconds; i++) {
- SET_STRING_ELT(colnms, i, STRING_ELT(ttcolnms, i));
- }
- SET_VECTOR_ELT(dimnames, 1, colnms);
+ SEXP dimnames, ttcolnms, colnms;
+ SET_VECTOR_ELT(usage, 6, dimnames = allocVector(VECSXP, 2));
+ if (hasColnames(tt)) {
+ SET_VECTOR_ELT(usage, 7, ttcolnms = VECTOR_ELT(getAttrib(tt, R_DimNamesSymbol), 1));
+ SET_VECTOR_ELT(usage, 8, colnms = allocVector(STRSXP, nconds));
+ for (int i = 0; i < nconds; i++) {
+ SET_STRING_ELT(colnms, i, STRING_ELT(ttcolnms, i));
}
- int posallsol = getpos(list, "all.sol");
- if (posallsol >= 0) {
- int posrowdom = getpos(list, "row.dom");
- Rboolean rowdom = (posrowdom >= 0) ? (LOGICAL(VECTOR_ELT(list, posrowdom))[0]) : FALSE;
- SEXP out = PROTECT(allocVector(VECSXP, 3));
- SEXP cols;
- SET_VECTOR_ELT(usage, 7, cols = allocVector(LGLSXP, foundPI));
- int *p_cols = INTEGER(cols);
- memset(p_cols, TRUE, foundPI * sizeof(int));
- if (rowdom) {
- int survcols = foundPI;
- rowDominance(p_pichart, posrows, &survcols, p_cols, p_ck);
- if (survcols < foundPI) {
- int s = 0;
- for (int c = 0; c < foundPI; c++) {
- if (p_cols[c]) {
- for (int r = 0; r < nconds; r++) {
- p_temp[s * nconds + r] = p_temp[c * nconds + r];
- }
- s++;
+ SET_VECTOR_ELT(dimnames, 1, colnms);
+ }
+ int posallsol = getpos(list, "all.sol");
+ if (posallsol >= 0) {
+ int posrowdom = getpos(list, "row.dom");
+ Rboolean rowdom = (posrowdom >= 0) ? (LOGICAL(VECTOR_ELT(list, posrowdom))[0]) : FALSE;
+ SEXP out = PROTECT(allocVector(VECSXP, 3));
+ SEXP cols;
+ SET_VECTOR_ELT(usage, 7, cols = allocVector(LGLSXP, foundPI));
+ int *p_cols = INTEGER(cols);
+ memset(p_cols, TRUE, foundPI * sizeof(int));
+ if (rowdom) {
+ int survcols = foundPI;
+ rowDominance(p_pichart, posrows, &survcols, p_cols, p_ck);
+ if (survcols < foundPI) {
+ int s = 0;
+ for (int c = 0; c < foundPI; c++) {
+ if (p_cols[c]) {
+ for (int r = 0; r < nconds; r++) {
+ p_temp[s * nconds + r] = p_temp[c * nconds + r];
}
+ s++;
}
- foundPI = survcols;
}
+ foundPI = survcols;
}
- SET_VECTOR_ELT(usage, 8, tempcpy = allocVector(INTSXP, foundPI));
- p_tempcpy = INTEGER(tempcpy);
- sortmat(p_temp, p_tempcpy, p_ck, nconds, foundPI);
- SET_VECTOR_ELT(out, 0, result = allocMatrix(INTSXP, foundPI, nconds));
- p_result = INTEGER(result);
- SET_VECTOR_ELT(out, 1, pic = allocMatrix(LGLSXP, posrows, foundPI));
- p_pic = LOGICAL(pic);
- for (int c = 0; c < foundPI; c++) {
- for (int r = 0; r < posrows; r++) {
- p_pic[c * posrows + r] = p_pichart[p_tempcpy[c] * posrows + r];
- }
- for (int r = 0; r < nconds; r++) {
- p_result[foundPI * r + c] = p_temp[p_tempcpy[c] * nconds + r];
- }
+ }
+ SET_VECTOR_ELT(usage, 8, tempcpy = allocVector(INTSXP, foundPI));
+ p_tempcpy = INTEGER(tempcpy);
+ sortmat(p_temp, p_tempcpy, p_ck, nconds, foundPI);
+ SET_VECTOR_ELT(out, 0, result = allocMatrix(INTSXP, foundPI, nconds));
+ p_result = INTEGER(result);
+ SET_VECTOR_ELT(out, 1, pic = allocMatrix(LGLSXP, posrows, foundPI));
+ p_pic = LOGICAL(pic);
+ for (int c = 0; c < foundPI; c++) {
+ for (int r = 0; r < posrows; r++) {
+ p_pic[c * posrows + r] = p_pichart[p_tempcpy[c] * posrows + r];
}
- if (hasColnames(tt)) {
- setAttrib(result, R_DimNamesSymbol, dimnames);
+ for (int r = 0; r < nconds; r++) {
+ p_result[foundPI * r + c] = p_temp[p_tempcpy[c] * nconds + r];
}
- int posolcons = getpos(list, "sol.cons");
- int posolcov = getpos(list, "sol.cov");
- if (REAL(VECTOR_ELT(list, posolcons))[0] > 0) {
- SEXP temptemp;
- SET_VECTOR_ELT(usage, 1, temptemp = duplicate(ck));
- int *p_temptemp = INTEGER(temptemp);
- SET_VECTOR_ELT(usage, 6, ck = allocVector(INTSXP, foundPI));
- p_ck = INTEGER(ck);
- for (int c = 0; c < foundPI; c++) {
- p_ck[c] = p_temptemp[p_tempcpy[c]];
- }
- SET_VECTOR_ELT(usage, 1, temptemp = duplicate(indx));
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/qca -r 67
More information about the Qca-commits
mailing list