[Qca-commits] r53 - in pkg: . R inst/gui/www/js inst/staticdocs man src
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Aug 8 23:33:39 CEST 2018
Author: dusadrian
Date: 2018-08-08 23:33:39 +0200 (Wed, 08 Aug 2018)
New Revision: 53
Removed:
pkg/src/findSubsets.c
Modified:
pkg/DESCRIPTION
pkg/R/combinations.R
pkg/R/createMatrix.R
pkg/R/dimnames.R
pkg/R/findSubsets.R
pkg/R/findmin.R
pkg/R/getRow.R
pkg/R/minimize.R
pkg/R/removeRedundants.R
pkg/R/solveChart.R
pkg/R/superSubset.R
pkg/R/truthTable.R
pkg/inst/gui/www/js/utils.js
pkg/inst/staticdocs/QCA.package.html
pkg/man/QCA.package.Rd
pkg/src/QCA.c
pkg/src/registerDynamicSymbol.c
pkg/src/truthTable.c
Log:
change to allow building binaries on R-Forge
Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2018-08-08 13:53:18 UTC (rev 52)
+++ pkg/DESCRIPTION 2018-08-08 21:33:39 UTC (rev 53)
@@ -1,6 +1,6 @@
Package: QCA
Version: 3.3-1
-Date: 2018-07-22
+Date: 2018-08-09
Title: Qualitative Comparative Analysis
Authors at R: c(person("Adrian", "Dusa", role = c("aut", "cre", "cph"),
email = "dusa.adrian at unibuc.ro"),
@@ -28,7 +28,7 @@
minimal causal combination that explains a given phenomenon.
License: GPL (>= 2)
NeedsCompilation: yes
-Packaged: 2018-07-22 10:02:51 UTC; dusadrian
+Packaged: 2018-08-08 21:29:18 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/combinations.R
===================================================================
--- pkg/R/combinations.R 2018-08-08 13:53:18 UTC (rev 52)
+++ pkg/R/combinations.R 2018-08-08 21:33:39 UTC (rev 53)
@@ -44,7 +44,7 @@
k <- as.integer(k)
zero <- as.integer(zero)
if (inC) {
- .Call("combinations", list(n = n, k = k, aloe = aloe, zero = zero), PACKAGE = "QCA")
+ .Call("C_combinations", list(n = n, k = k, aloe = aloe, zero = zero), PACKAGE = "QCA")
}
else {
aloe <- as.integer(aloe)
Modified: pkg/R/createMatrix.R
===================================================================
--- pkg/R/createMatrix.R 2018-08-08 13:53:18 UTC (rev 52)
+++ pkg/R/createMatrix.R 2018-08-08 21:33:39 UTC (rev 53)
@@ -83,7 +83,7 @@
}
}
}
- return(.Call("createMatrix", tosend, PACKAGE = "QCA"))
+ return(.Call("C_createMatrix", tosend, PACKAGE = "QCA"))
pwr <- unique(noflevels)
if (length(pwr) == 1) {
create <- function(idx) {
Modified: pkg/R/dimnames.R
===================================================================
--- pkg/R/dimnames.R 2018-08-08 13:53:18 UTC (rev 52)
+++ pkg/R/dimnames.R 2018-08-08 21:33:39 UTC (rev 53)
@@ -24,11 +24,11 @@
# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
`setColnames` <- function(matrix, colnames) {
- invisible(.Call("setColnames", matrix, colnames))
+ invisible(.Call("C_setColnames", matrix, colnames))
}
`setRownames` <- function(matrix, rownames) {
- invisible(.Call("setRownames", matrix, rownames))
+ invisible(.Call("C_setRownames", matrix, rownames))
}
`setDimnames` <- function(matrix, nameslist) {
- invisible(.Call("setDimnames", matrix, nameslist))
+ invisible(.Call("C_setDimnames", matrix, nameslist))
}
Modified: pkg/R/findSubsets.R
===================================================================
--- pkg/R/findSubsets.R 2018-08-08 13:53:18 UTC (rev 52)
+++ pkg/R/findSubsets.R 2018-08-08 21:33:39 UTC (rev 53)
@@ -34,7 +34,7 @@
}
stop <- ifelse(missing(stop), prod(noflevels), stop)
result <- lapply(input, function(x) {
- .Call("findSubsets", x, noflevels - 1, rev(c(1, cumprod(rev(noflevels))))[-1], stop, PACKAGE="QCA")
+ .Call("C_findSubsets", x, noflevels - 1, rev(c(1, cumprod(rev(noflevels))))[-1], stop, PACKAGE = "QCA")
})
return(sort(unique(unlist(result))))
}
Modified: pkg/R/findmin.R
===================================================================
--- pkg/R/findmin.R 2018-08-08 13:53:18 UTC (rev 52)
+++ pkg/R/findmin.R 2018-08-08 21:33:39 UTC (rev 53)
@@ -31,5 +31,5 @@
stop(simpleError("The input should be a logical matrix. See function makeChart()\n\n"))
}
}
- return(.Call("findmin", t(matrix(as.logical(chart), nrow = nrow(chart))), PACKAGE = "QCA"))
+ return(.Call("C_findmin", t(matrix(as.logical(chart), nrow = nrow(chart))), PACKAGE = "QCA"))
}
Modified: pkg/R/getRow.R
===================================================================
--- pkg/R/getRow.R 2018-08-08 13:53:18 UTC (rev 52)
+++ pkg/R/getRow.R 2018-08-08 21:33:39 UTC (rev 53)
@@ -34,5 +34,5 @@
}
if (!zerobased) {row.no <- row.no - 1}
mbase <- c(rev(cumprod(rev(noflevels))), 1)[-1]
- return(.Call("getRow", list(row.no, noflevels, mbase), PACKAGE = "QCA"))
+ return(.Call("C_getRow", list(row.no, noflevels, mbase), PACKAGE = "QCA"))
}
Modified: pkg/R/minimize.R
===================================================================
--- pkg/R/minimize.R 2018-08-08 13:53:18 UTC (rev 52)
+++ pkg/R/minimize.R 2018-08-08 21:33:39 UTC (rev 53)
@@ -297,12 +297,12 @@
incl.rem <- TRUE
method <- "CCubes"
}
- expressions <- .Call("QMC", expressions, noflevels, PACKAGE = "QCA")
+ expressions <- .Call("C_QMC", expressions, noflevels, PACKAGE = "QCA")
c.sol <- 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, ...=...)
if (incl.rem) {
pos.matrix <- inputt
if (method == "QMC") {
- expressions <- .Call("QMC", createMatrix(noflevels)[-output$negatives, , drop = FALSE] + 1, noflevels, PACKAGE = "QCA")
+ expressions <- .Call("C_QMC", createMatrix(noflevels)[-output$negatives, , drop = FALSE] + 1, noflevels, PACKAGE = "QCA")
setColnames(expressions, colnames(inputt))
}
else if (method == "eQMC") {
@@ -312,7 +312,7 @@
else {
expressions <- sort.int(findSupersets(pos.matrix, noflevels + 1))
}
- expressions <- .Call("removeRedundants", expressions, noflevels, mbaseplus, PACKAGE = "QCA")
+ expressions <- .Call("C_removeRedundants", expressions, noflevels, mbaseplus, PACKAGE = "QCA")
expressions <- sortExpressions(getRow(expressions, noflevels + 1))
setColnames(expressions, colnames(inputt))
}
@@ -327,7 +327,7 @@
if (sol.cons > 0 & all.sol & sol.depth == 0) {
sol.depth <- 5
}
- expressions <- .Call("ccubes", list(
+ expressions <- .Call("C_ccubes", list(
tt = cbind(rbind(pos.matrix, neg.matrix) - 1, rep(c(1, 0), c(nrow(pos.matrix), nrow(neg.matrix)))),
pi.cons = pi.cons, depth = as.integer(c(pi.depth, sol.depth)),
min.pin = min.pin, row.dom = row.dom, all.sol = all.sol, sol.cons = sol.cons,
@@ -522,7 +522,7 @@
}
}
pos.matrix.i.sol <- pos.matrix.i.sol[!tomit, , drop=FALSE]
- expressions <- .Call("QMC", pos.matrix.i.sol, noflevels, colnames(pos.matrix.i.sol))
+ expressions <- .Call("C_QMC", pos.matrix.i.sol, noflevels, PACKAGE = "QCA")
i.sol.index <- 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, ...=...)
i.sol.index$expressions <- i.sol.index$expressions[rowSums(i.sol.index$mtrx) > 0, , drop=FALSE]
if (nrow(i.sol[[index]]$EC) > 0) {
Modified: pkg/R/removeRedundants.R
===================================================================
--- pkg/R/removeRedundants.R 2018-08-08 13:53:18 UTC (rev 52)
+++ pkg/R/removeRedundants.R 2018-08-08 21:33:39 UTC (rev 53)
@@ -26,5 +26,5 @@
`removeRedundants` <-
function(implicants, noflevels) {
mbase <- rev(c(1, cumprod(rev(noflevels))))[-1]
- .Call("removeRedundants", implicants, noflevels - 1, mbase, package = "QCA")
+ .Call("C_removeRedundants", implicants, noflevels - 1, mbase, PACKAGE = "QCA")
}
Modified: pkg/R/solveChart.R
===================================================================
--- pkg/R/solveChart.R 2018-08-08 13:53:18 UTC (rev 52)
+++ pkg/R/solveChart.R 2018-08-08 21:33:39 UTC (rev 53)
@@ -49,7 +49,7 @@
}
if (all(dim(chart) > 1)) {
if (is.null(depth)) depth <- 0L
- output <- .Call("solveChart", t(matrix(as.logical(chart), nrow = nrow(chart))), all.sol, as.integer(depth), PACKAGE = "QCA")
+ output <- .Call("C_solveChart", t(matrix(as.logical(chart), nrow = nrow(chart))), all.sol, as.integer(depth), PACKAGE = "QCA")
output[output == 0] <- NA
}
else {
Modified: pkg/R/superSubset.R
===================================================================
--- pkg/R/superSubset.R 2018-08-08 13:53:18 UTC (rev 52)
+++ pkg/R/superSubset.R 2018-08-08 21:33:39 UTC (rev 53)
@@ -39,14 +39,18 @@
if (cov.cut > 0) {
cov.cut <- cov.cut - .Machine$double.eps ^ 0.5
}
+ if (identical(outcome, "")) {
+ cat("\n")
+ stop(simpleError("The outcome was not specified.\n\n"))
+ }
outcome <- toupper(outcome)
if (tilde1st(outcome)) {
neg.out <- TRUE
outcome <- substring(outcome, 2)
}
- if (! toupper(curlyBrackets(outcome, outside=TRUE)) %in% toupper(colnames(data))) {
+ if (!is.element(toupper(curlyBrackets(outcome, outside=TRUE)), toupper(colnames(data)))) {
cat("\n")
- stop(simpleError("Inexisting outcome name.\n\n"))
+ stop(simpleError("The outcome name does not exist in the data.\n\n"))
}
if (grepl("\\{|\\}", outcome)) {
outcome.value <- curlyBrackets(outcome)
@@ -102,7 +106,7 @@
if (is.null(depth)) {
depth <- nofconditions
}
- CMatrix <- .Call("superSubset",
+ CMatrix <- .Call("C_superSubset",
as.matrix(data[, conditions]),
noflevels,
as.numeric(fc),
Modified: pkg/R/truthTable.R
===================================================================
--- pkg/R/truthTable.R 2018-08-08 13:53:18 UTC (rev 52)
+++ pkg/R/truthTable.R 2018-08-08 21:33:39 UTC (rev 53)
@@ -146,7 +146,7 @@
tt <- condata[uniq, , drop = FALSE]
rownstt <- sort(line.data)[uniq]
rownames(tt) <- rownstt
- ipc <- .Call("truthTable", as.matrix(data[, conditions]), data[, outcome], as.matrix(tt), as.numeric(fuzzy.cc), PACKAGE = "QCA")
+ ipc <- .Call("C_truthTable", as.matrix(data[, conditions]), data[, outcome], as.matrix(tt), as.numeric(fuzzy.cc), PACKAGE = "QCA")
colnames(ipc) <- rownstt
minmat <- ipc[seq(4, nrow(ipc)), , drop = FALSE]
ipc <- ipc[1:3, , drop = FALSE]
Modified: pkg/inst/gui/www/js/utils.js
===================================================================
--- pkg/inst/gui/www/js/utils.js 2018-08-08 13:53:18 UTC (rev 52)
+++ pkg/inst/gui/www/js/utils.js 2018-08-08 21:33:39 UTC (rev 53)
@@ -354,9 +354,13 @@
return !/^(NaN|-?Infinity)$/.test(+n);
}
}
-function isNumeric(obj) {
- if (obj.length == 0) {
+function isNumeric(obj) {
+ if (missing(obj)) {
return false;
+ } else if (obj === null) {
+ return false;
+ } else if (obj.length == 0) {
+ return false;
}
else {
if (obj instanceof Array) {
@@ -1055,6 +1059,13 @@
}
return out;
}
+function decToBin(x) {
+ if (isNumeric(x)) {
+ return((_$=($,_="")=>$?_$($>>1,($&1)+_):_)(x));
+ } else {
+ return("");
+ }
+}
function getScrollBarWidth() {
var inner = document.createElement('p');
inner.style.width = "100%";
Modified: pkg/inst/staticdocs/QCA.package.html
===================================================================
--- pkg/inst/staticdocs/QCA.package.html 2018-08-08 13:53:18 UTC (rev 52)
+++ pkg/inst/staticdocs/QCA.package.html 2018-08-08 21:33:39 UTC (rev 53)
@@ -121,7 +121,7 @@
</tr><tr><td> 3.3-1 </td>
</tr><tr><td>
Date: </td>
-</tr><tr><td> 2018-07-22 </td>
+</tr><tr><td> 2018-08-09 </td>
</tr><tr><td>
License: </td>
</tr><tr><td> GPL (>= 2)</td>
Modified: pkg/man/QCA.package.Rd
===================================================================
--- pkg/man/QCA.package.Rd 2018-08-08 13:53:18 UTC (rev 52)
+++ pkg/man/QCA.package.Rd 2018-08-08 21:33:39 UTC (rev 53)
@@ -56,7 +56,7 @@
Package: \tab QCA\cr
Type: \tab Package\cr
Version: \tab 3.3-1\cr
- Date: \tab 2018-07-22\cr
+ Date: \tab 2018-08-09\cr
License: \tab GPL (>= 2)\cr
}
}
Modified: pkg/src/QCA.c
===================================================================
--- pkg/src/QCA.c 2018-08-08 13:53:18 UTC (rev 52)
+++ pkg/src/QCA.c 2018-08-08 21:33:39 UTC (rev 53)
@@ -31,7 +31,7 @@
# include <Rinternals.h>
# include <Rmath.h>
# include <R_ext/Rdynload.h>
-SEXP setDimnames(SEXP tt, SEXP dimnames) {
+SEXP C_setDimnames(SEXP tt, SEXP dimnames) {
setAttrib(tt, R_DimNamesSymbol, dimnames);
return(R_NilValue);
}
@@ -44,7 +44,7 @@
static R_INLINE Rboolean hasColnames(SEXP matrix) {
return hasDimnames(matrix) ? !Rf_isNull(VECTOR_ELT(getAttrib(matrix, R_DimNamesSymbol), 1)) : FALSE;
}
-SEXP setColnames(SEXP matrix, SEXP colnames) {
+SEXP C_setColnames(SEXP matrix, SEXP colnames) {
SEXP dimnames = PROTECT(allocVector(VECSXP, 2));
SET_VECTOR_ELT(dimnames, 1, colnames);
if (hasRownames(matrix)) {
@@ -54,7 +54,7 @@
UNPROTECT(1);
return(R_NilValue);
}
-SEXP setRownames(SEXP matrix, SEXP rownames) {
+SEXP C_setRownames(SEXP matrix, SEXP rownames) {
SEXP dimnames = PROTECT(allocVector(VECSXP, 2));
SET_VECTOR_ELT(dimnames, 0, rownames);
if (hasColnames(matrix)) {
@@ -680,7 +680,7 @@
UNPROTECT(1);
return(sumxy / sumx);
}
-SEXP solveChart(SEXP pichart, SEXP allsol, SEXP vdepth) {
+SEXP C_solveChart(SEXP pichart, SEXP allsol, SEXP vdepth) {
int *p_indmat, *p_temp1, *p_temp2, *p_mintpis, *p_cols;
SEXP usage, indmat, temp1, temp2, mintpis, cols;
int *p_pichart = LOGICAL(pichart);
@@ -1070,7 +1070,7 @@
}
}
}
-SEXP ccubes(SEXP list) {
+SEXP C_ccubes(SEXP list) {
int checkmin;
SEXP posmat, negmat, pichart, temp, indx, ck, tempcpy, result, pic;
int *p_posmat, *p_negmat, *p_pichart, *p_temp, *p_indx, *p_ck, *p_tempcpy, *p_result, *p_pic;
@@ -1479,7 +1479,7 @@
}
else {
INTEGER(VECTOR_ELT(list, posdepth))[0] = INTEGER(VECTOR_ELT(list, posdepth))[1];
- SET_VECTOR_ELT(out, 2, solveChart(pic, VECTOR_ELT(list, posallsol), VECTOR_ELT(list, posdepth)));
+ SET_VECTOR_ELT(out, 2, C_solveChart(pic, VECTOR_ELT(list, posallsol), VECTOR_ELT(list, posdepth)));
}
}
SET_VECTOR_ELT(out, 1, pic = transpose(pic, posrows, foundPI));
@@ -1495,13 +1495,13 @@
return(result);
}
}
-SEXP findmin(SEXP pichart) {
+SEXP C_findmin(SEXP pichart) {
SEXP out = PROTECT(allocVector(INTSXP, 1));
INTEGER(out)[0] = getmin(pichart, ncols(pichart));
UNPROTECT(1);
return(out);
}
-SEXP getRow(SEXP input) {
+SEXP C_getRow(SEXP input) {
PROTECT(input);
SEXP rowno, noflevels, mbase, matrix;
SEXP usage = PROTECT(allocVector(VECSXP, 4));
@@ -1523,7 +1523,7 @@
UNPROTECT(2);
return(matrix);
}
-SEXP createMatrix(SEXP input) {
+SEXP C_createMatrix(SEXP input) {
PROTECT(input);
SEXP matrix, noflevels, arrange, maxprod;
SEXP usage = PROTECT(allocVector(VECSXP, 4));
@@ -1556,7 +1556,7 @@
UNPROTECT(2);
return(matrix);
}
-SEXP superSubset(SEXP x, SEXP noflevels, SEXP fuz, SEXP vo,
+SEXP C_superSubset(SEXP x, SEXP noflevels, SEXP fuz, SEXP vo,
SEXP nec, SEXP inclcut, SEXP covcut, SEXP depth) {
SEXP usage = PROTECT(allocVector(VECSXP, 19));
SET_VECTOR_ELT(usage, 0, x = coerceVector(x, REALSXP));
@@ -1987,7 +1987,7 @@
UNPROTECT(2);
return(result);
}
-SEXP QMC(SEXP tt, SEXP noflevels) {
+SEXP C_QMC(SEXP tt, SEXP noflevels) {
SEXP pimat, tempmat, minimized, copymat, order, cl;
int *p_tt, *p_noflevels, *p_pimat, *p_tempmat, *p_minimized, *p_copymat, *p_order, *p_cl;
SEXP usage = PROTECT(allocVector(VECSXP, 10));
@@ -2166,7 +2166,7 @@
UNPROTECT(1);
return(copymat);
}
-SEXP removeRedundants(SEXP rowno, SEXP noflevels, SEXP mbase) {
+SEXP C_removeRedundants(SEXP rowno, SEXP noflevels, SEXP mbase) {
int *pointer_next, *pointer_final, *pointer_temp1, *pointer_temp2, *pointer_rowno, *pointer_noflevels, *pointer_mbase;
int previous, lmbase, ltemp2, lrowno, lmbasei, i, j, k, rn, finalength, lungime, flag2, flag1, templung;
SEXP next, final, temp1, temp2;
@@ -2265,7 +2265,7 @@
return(final);
}
}
-SEXP combinations (SEXP list) {
+SEXP C_combinations(SEXP list) {
int nconds, k, aloe, zero;
nconds = INTEGER(VECTOR_ELT(list, 0))[0];
k = INTEGER(VECTOR_ELT(list, 1))[0];
@@ -2310,3 +2310,75 @@
UNPROTECT(1);
return(out);
}
+SEXP C_findSubsets(SEXP rowno, SEXP noflevels, SEXP mbase, SEXP max) {
+ int *prowno, *pnoflevels, *pmbase, *pmax, lmbase, lmbasei, i, j, k, lungime, flag, templung, *ptemp1, *ptemp2;
+ SEXP temp1, temp2;
+ SEXP usage = PROTECT(allocVector(VECSXP, 6));
+ SET_VECTOR_ELT(usage, 0, rowno = coerceVector(rowno, INTSXP));
+ SET_VECTOR_ELT(usage, 1, noflevels = coerceVector(noflevels, INTSXP));
+ SET_VECTOR_ELT(usage, 2, mbase = coerceVector(mbase, INTSXP));
+ prowno = INTEGER(rowno);
+ pnoflevels = INTEGER(noflevels);
+ pmbase = INTEGER(mbase);
+ if (max == R_NilValue) {
+ SET_VECTOR_ELT(usage, 3, max = allocVector(INTSXP, 1));
+ pmax = INTEGER(max);
+ pmax[0] = prowno[length(rowno) - 1];
+ }
+ else {
+ SET_VECTOR_ELT(usage, 3, max = coerceVector(max, INTSXP));
+ pmax = INTEGER(max);
+ }
+ SET_VECTOR_ELT(usage, 4, temp1 = allocVector(INTSXP, 1));
+ ptemp1 = INTEGER(temp1);
+ ptemp1[0] = prowno[0];
+ flag = 0;
+ lmbase = length(mbase);
+ templung = 1;
+ for (i = 0; i < lmbase; i++) {
+ lmbasei = lmbase - i - 1;
+ if (div(div(prowno[0] - 1, pmbase[lmbasei]).quot, pnoflevels[lmbasei] + 1).rem == 0) {
+ flag = 1;
+ lungime = templung * (pnoflevels[lmbasei] + 1);
+ SET_VECTOR_ELT(usage, 5, temp2 = allocVector(INTSXP, lungime));
+ ptemp2 = INTEGER(temp2);
+ for (j = 0; j < length(temp1); j++) {
+ ptemp2[j] = ptemp1[j];
+ for (k = 0; k < pnoflevels[lmbasei]; k++) {
+ ptemp2[j + length(temp1)*(k + 1)] = ptemp1[j] + (k + 1)*pmbase[lmbasei];
+ }
+ }
+ if (i < length(mbase)) {
+ SET_VECTOR_ELT(usage, 4, temp1 = allocVector(INTSXP, lungime));
+ ptemp1 = INTEGER(temp1);
+ for (j = 0; j < lungime; j++) {
+ ptemp1[j] = ptemp2[j];
+ }
+ templung = lungime;
+ }
+ }
+ }
+ if (flag == 1) {
+ templung = 0;
+ for (i = 0; i < lungime; i++) {
+ if (ptemp2[i] < (pmax[0] + 1)) {
+ templung += 1;
+ }
+ }
+ SET_VECTOR_ELT(usage, 4, temp1 = allocVector(INTSXP, templung - 1));
+ ptemp1 = INTEGER(temp1);
+ j = 0;
+ for (i = 1; i < lungime; i++) {
+ if (ptemp2[i] < pmax[0] + 1) {
+ ptemp1[j] = ptemp2[i];
+ j += 1;
+ }
+ }
+ }
+ else {
+ UNPROTECT(1);
+ return(R_NilValue);
+ }
+ UNPROTECT(1);
+ return(temp1);
+}
Deleted: pkg/src/findSubsets.c
===================================================================
--- pkg/src/findSubsets.c 2018-08-08 13:53:18 UTC (rev 52)
+++ pkg/src/findSubsets.c 2018-08-08 21:33:39 UTC (rev 53)
@@ -1,103 +0,0 @@
-/*
-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.
-*/
-
-# include <R.h>
-# include <Rinternals.h>
-# include <R_ext/Rdynload.h>
-# include <stdlib.h>
-SEXP findSubsets(SEXP rowno, SEXP noflevels, SEXP mbase, SEXP max) {
- int *prowno, *pnoflevels, *pmbase, *pmax, lmbase, lmbasei, i, j, k, lungime, flag, templung, *ptemp1, *ptemp2;
- SEXP temp1, temp2;
- SEXP usage = PROTECT(allocVector(VECSXP, 6));
- SET_VECTOR_ELT(usage, 0, rowno = coerceVector(rowno, INTSXP));
- SET_VECTOR_ELT(usage, 1, noflevels = coerceVector(noflevels, INTSXP));
- SET_VECTOR_ELT(usage, 2, mbase = coerceVector(mbase, INTSXP));
- prowno = INTEGER(rowno);
- pnoflevels = INTEGER(noflevels);
- pmbase = INTEGER(mbase);
- if (max == R_NilValue) {
- SET_VECTOR_ELT(usage, 3, max = allocVector(INTSXP, 1));
- pmax = INTEGER(max);
- pmax[0] = prowno[length(rowno) - 1];
- }
- else {
- SET_VECTOR_ELT(usage, 3, max = coerceVector(max, INTSXP));
- pmax = INTEGER(max);
- }
- SET_VECTOR_ELT(usage, 4, temp1 = allocVector(INTSXP, 1));
- ptemp1 = INTEGER(temp1);
- ptemp1[0] = prowno[0];
- flag = 0;
- lmbase = length(mbase);
- templung = 1;
- for (i = 0; i < lmbase; i++) {
- lmbasei = lmbase - i - 1;
- if (div(div(prowno[0] - 1, pmbase[lmbasei]).quot, pnoflevels[lmbasei] + 1).rem == 0) {
- flag = 1;
- lungime = templung * (pnoflevels[lmbasei] + 1);
- SET_VECTOR_ELT(usage, 5, temp2 = allocVector(INTSXP, lungime));
- ptemp2 = INTEGER(temp2);
- for (j = 0; j < length(temp1); j++) {
- ptemp2[j] = ptemp1[j];
- for (k = 0; k < pnoflevels[lmbasei]; k++) {
- ptemp2[j + length(temp1)*(k + 1)] = ptemp1[j] + (k + 1)*pmbase[lmbasei];
- }
- }
- if (i < length(mbase)) {
- SET_VECTOR_ELT(usage, 4, temp1 = allocVector(INTSXP, lungime));
- ptemp1 = INTEGER(temp1);
- for (j = 0; j < lungime; j++) {
- ptemp1[j] = ptemp2[j];
- }
- templung = lungime;
- }
- }
- }
- if (flag == 1) {
- templung = 0;
- for (i = 0; i < lungime; i++) {
- if (ptemp2[i] < (pmax[0] + 1)) {
- templung += 1;
- }
- }
- SET_VECTOR_ELT(usage, 4, temp1 = allocVector(INTSXP, templung - 1));
- ptemp1 = INTEGER(temp1);
- j = 0;
- for (i = 1; i < lungime; i++) {
- if (ptemp2[i] < pmax[0] + 1) {
- ptemp1[j] = ptemp2[i];
- j += 1;
- }
- }
- }
- else {
- UNPROTECT(1);
- return(R_NilValue);
- }
- UNPROTECT(1);
- return(temp1);
-}
Modified: pkg/src/registerDynamicSymbol.c
===================================================================
--- pkg/src/registerDynamicSymbol.c 2018-08-08 13:53:18 UTC (rev 52)
+++ pkg/src/registerDynamicSymbol.c 2018-08-08 21:33:39 UTC (rev 53)
@@ -29,39 +29,7 @@
#include <Rinternals.h>
#include <stdlib.h>
#include <R_ext/Rdynload.h>
-extern SEXP ccubes(SEXP);
-extern SEXP combinations(SEXP);
-extern SEXP createMatrix(SEXP);
-extern SEXP findmin(SEXP);
-extern SEXP findSubsets(SEXP, SEXP, SEXP, SEXP);
-extern SEXP getRow(SEXP);
-extern SEXP QMC(SEXP, SEXP);
-extern SEXP removeRedundants(SEXP, SEXP, SEXP);
-extern SEXP setColnames(SEXP, SEXP);
-extern SEXP setDimnames(SEXP, SEXP);
-extern SEXP setRownames(SEXP, SEXP);
-extern SEXP solveChart(SEXP, SEXP, SEXP);
-extern SEXP superSubset(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP);
-extern SEXP truthTable(SEXP, SEXP, SEXP, SEXP);
-static const R_CallMethodDef CallEntries[] = {
- {"ccubes", (DL_FUNC) &ccubes, 1},
- {"combinations", (DL_FUNC) &combinations, 1},
- {"createMatrix", (DL_FUNC) &createMatrix, 1},
- {"findmin", (DL_FUNC) &findmin, 1},
- {"findSubsets", (DL_FUNC) &findSubsets, 4},
- {"getRow", (DL_FUNC) &getRow, 1},
- {"QMC", (DL_FUNC) &QMC, 2},
- {"removeRedundants", (DL_FUNC) &removeRedundants, 3},
- {"setColnames", (DL_FUNC) &setColnames, 2},
- {"setDimnames", (DL_FUNC) &setDimnames, 2},
- {"setRownames", (DL_FUNC) &setRownames, 2},
- {"solveChart", (DL_FUNC) &solveChart, 3},
- {"superSubset", (DL_FUNC) &superSubset, 8},
- {"truthTable", (DL_FUNC) &truthTable, 4},
- {NULL, NULL, 0}
-};
-void R_init_QCA(DllInfo *dll)
-{
- R_registerRoutines(dll, NULL, CallEntries, NULL, NULL);
- R_useDynamicSymbols(dll, FALSE);
+void R_init_QCA(DllInfo* info) {
+ R_registerRoutines(info, NULL, NULL, NULL, NULL);
+ R_useDynamicSymbols(info, TRUE);
}
Modified: pkg/src/truthTable.c
===================================================================
--- pkg/src/truthTable.c 2018-08-08 13:53:18 UTC (rev 52)
+++ pkg/src/truthTable.c 2018-08-08 21:33:39 UTC (rev 53)
@@ -28,7 +28,7 @@
# include <R.h>
# include <Rinternals.h>
# include <R_ext/Rdynload.h>
-SEXP truthTable(SEXP x, SEXP vo, SEXP tt, SEXP fuz) {
+SEXP C_truthTable(SEXP x, SEXP vo, SEXP tt, SEXP fuz) {
int i, j, k, index;
double *p_x, *p_inclpri, *p_vo, min, so, sumx, sumpmin, prisum, temp1, temp2;
int xrows, xcols, ttrows, ncut, *p_tt, *p_fuz;
More information about the Qca-commits
mailing list