[Qca-commits] r47 - in pkg: . R inst man src
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Jul 20 10:10:24 CEST 2018
Author: dusadrian
Date: 2018-07-20 10:10:23 +0200 (Fri, 20 Jul 2018)
New Revision: 47
Modified:
pkg/DESCRIPTION
pkg/NAMESPACE
pkg/R/allExpressions.R
pkg/R/calibrate.R
pkg/R/createMatrix.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/onAttach.R
pkg/R/pof.R
pkg/R/prettyString.R
pkg/R/prettyTable.R
pkg/R/retention.R
pkg/R/rowDominance.R
pkg/R/solveChart.R
pkg/R/sortMatrix.R
pkg/R/sortVector.R
pkg/R/superSubset.R
pkg/R/truthTable.R
pkg/R/verifyQCA.R
pkg/R/writePrimeimp.R
pkg/R/writeSolution.R
pkg/inst/CITATION
pkg/inst/ChangeLog
pkg/inst/TODO
pkg/man/QCA-internal.Rd
pkg/man/QCA.package.Rd
pkg/man/calibrate.Rd
pkg/man/factorize.Rd
pkg/man/findTh.Rd
pkg/man/pof.Rd
pkg/man/retention.Rd
pkg/man/truthTable.Rd
pkg/src/findSubsets.c
pkg/src/truthTable.c
Log:
version 3.3
Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2014-12-17 19:40:55 UTC (rev 46)
+++ pkg/DESCRIPTION 2018-07-20 08:10:23 UTC (rev 47)
@@ -1,13 +1,41 @@
Package: QCA
-Version: 1.1-4
-Date: 2014-11-24
-Title: QCA: A Package for Qualitative Comparative Analysis
-Authors at R: c(person("Adrian", "Dusa", role = c("aut", "cre"),
- email = "dusa.adrian at unibuc.ro"),
+Version: 3.3
+Date: 2018-07-14
+Title: Qualitative Comparative Analysis
+Authors at R: c(person("Adrian", "Dusa", role = c("aut", "cre", "cph"),
+ email = "dusa.adrian at unibuc.ro"),
+ person(family = "jQuery Foundation", role = "cph",
+ comment = "jQuery library and jQuery UI library"),
+ person(family = "jQuery contributors", role = c("ctb", "cph"),
+ comment = "jQuery library; authors listed in inst/gui/www/shared/jquery-AUTHORS.txt"),
+ person("Vasil", "Dinkov", role = c("ctb", "cph"),
+ comment = "jquery.smartmenus.js library"),
+ person("Dmitry", "Baranovskiy", role = c("ctb", "cph"),
+ comment = "raphael.js library"),
+ person("Emmanuel", "Quentin", role = c("ctb", "cph"),
+ comment = "raphael.inline_text_editing.js library"),
+ person("Jimmy", "Breck-McKye", role = c("ctb", "cph"),
+ comment = "raphael-paragraph.js library"),
person("Alrik", "Thiem", role = "aut",
- email = "alrik.thiem at unige.ch"))
+ comment = "from version 1.0-0 up to version 1.1-3"))
Depends: R (>= 3.0.0)
-Imports: lpSolve, utils
-Suggests: VennDiagram
-Description: This package provides functions for performing Qualitative Comparative Analysis (csQCA, tQCA, mvQCA and fsQCA).
+Imports: venn (>= 1.2), shiny, methods, fastdigest
+Description: An extensive set of functions to perform Qualitative Comparative Analysis:
+ crisp sets ('csQCA'), temporal ('tQCA'), multi-value ('mvQCA')
+ and fuzzy sets ('fsQCA'), using a GUI - graphical user interface.
+ 'QCA' is a methodology that bridges the qualitative and quantitative divide
+ in social science research. It uses a Boolean algorithm that results in a
+ minimal causal combination that explains a given phenomenon.
License: GPL (>= 2)
+NeedsCompilation: yes
+Packaged: 2018-07-14 04:11:31 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
+ inst/gui/www/shared/jquery-AUTHORS.txt),
+ Vasil Dinkov [ctb, cph] (jquery.smartmenus.js library),
+ Dmitry Baranovskiy [ctb, cph] (raphael.js library),
+ Emmanuel Quentin [ctb, cph] (raphael.inline_text_editing.js library),
+ Jimmy Breck-McKye [ctb, cph] (raphael-paragraph.js library),
+ Alrik Thiem [aut] (from version 1.0-0 up to version 1.1-3)
+Maintainer: Adrian Dusa <dusa.adrian at unibuc.ro>
Modified: pkg/NAMESPACE
===================================================================
--- pkg/NAMESPACE 2014-12-17 19:40:55 UTC (rev 46)
+++ pkg/NAMESPACE 2018-07-20 08:10:23 UTC (rev 47)
@@ -1,56 +1,125 @@
-useDynLib(QCA)
+import(shiny)
+import(venn)
+import(fastdigest)
+importFrom("utils", "packageDescription", "remove.packages", "capture.output")
+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")
+
+useDynLib(QCA, .registration = TRUE)
+
export(.onAttach,
allExpressions,
- base3rows,
+ agteb,
+ alteb,
+ as.panel,
+ asNumeric,
calibrate,
- createChart,
+ causalChain,
+ combinations,
+ compute,
createMatrix,
- createString,
- demoChart,
deMorgan,
- deMorganLoop,
eqmcc,
- eqmccLoop,
+ export,
factorize,
+ findmin,
+ findRows,
findSubsets,
findSupersets,
findTh,
fuzzyand,
fuzzyor,
+ getInfo,
getRow,
- getSolution,
- is.deMorgan,
- is.pof,
- is.qca,
- is.tt,
- is.sS,
+ getNoflevels,
+ intersection,
+ makeChart,
+ minimize,
+ minimizeLoop,
+ modelFit,
+ negate,
pof,
- prettyString,
+ pofind,
prettyTable,
- print.aE,
- print.deMorgan,
- print.fctr,
- print.pof,
- print.qca,
- print.mqca,
- print.pic,
- print.sS,
- print.tt,
+ recode,
+ rebuild,
+ removeRedundants,
retention,
- rowDominance,
+ runGUI,
+ setRownames,
+ setColnames,
+ setDimnames,
solveChart,
- sortMatrix,
- sortVector,
+ sop,
superSubset,
+ translate,
truthTable,
+ uninstall,
+ validateNames,
verify.data,
verify.dir.exp,
- verify.expl,
+ verify.minimize,
verify.inf.test,
verify.qca,
verify.mqca,
+ verify.multivalue,
verify.tt,
+ Xplot,
+ XYplot,
+
+ possibleNumeric,
+
+ dashes,
+ hastilde,
+ tilde1st,
+ notilde,
+ trimstr,
+ nec,
+ suf,
+ splitstr,
+ getName,
+ getBigList,
+ splitMainComponents,
+ splitBrackets,
+ removeSingleStars,
+ splitPluses,
+ splitStars,
+ splitTildas,
+ solveBrackets,
+ simplifyList,
+ negateValues,
+ removeDuplicates,
+ getNonChars,
+ splitProducts,
+ insideBrackets,
+ outsideBrackets,
+ curlyBrackets,
+ roundBrackets,
+
+ getSolution,
+ prettyString,
+ rowDominance,
+ sortMatrix,
+ sortVector,
writePrimeimp,
- writeSolution)
-import(lpSolve)
-importFrom("utils", "packageDescription")
+ writeSolution
+)
+
+S3method(print, "aE")
+S3method(print, "chain")
+S3method(print, "deMorgan")
+S3method(print, "factorize")
+S3method(print, "fuzzy")
+S3method(print, "intersection")
+S3method(print, "modelFit")
+S3method(print, "mqca")
+S3method(print, "panel")
+S3method(print, "pic")
+S3method(print, "pof")
+S3method(print, "qca")
+S3method(print, "sS")
+S3method(print, "translate")
+S3method(print, "tt")
+
Modified: pkg/R/allExpressions.R
===================================================================
--- pkg/R/allExpressions.R 2014-12-17 19:40:55 UTC (rev 46)
+++ pkg/R/allExpressions.R 2018-07-20 08:10:23 UTC (rev 47)
@@ -1,11 +1,32 @@
+# 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.
+
`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"))
+function(noflevels, arrange = FALSE, depth = NULL, raw = FALSE, ...) {
+ result <- createMatrix(noflevels + 1, arrange = arrange, depth = depth, ... = ...) - 1
+ attr(result, "raw") <- raw
+ class(result) <- c("matrix", "aE")
+ return(result)
}
-
Modified: pkg/R/calibrate.R
===================================================================
--- pkg/R/calibrate.R 2014-12-17 19:40:55 UTC (rev 46)
+++ pkg/R/calibrate.R 2018-07-20 08:10:23 UTC (rev 47)
@@ -1,29 +1,85 @@
+# 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.
+
`calibrate` <-
-function (x, type="crisp", thresholds = NA, include = TRUE, logistic = FALSE,
- idm = 0.95, ecdf = FALSE, p = 1, q = 1) {
- if (!is.numeric(x)) {
+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)) {
+ above <- other.args$q
+ }
+ if ("p" %in% names(other.args)) {
+ below <- other.args$p
+ }
+ if (possibleNumeric(x)) {
+ x <- asNumeric(x)
+ }
+ else {
cat("\n")
- stop("x is not numeric.\n\n", call. = FALSE)
+ stop(simpleError("x is not numeric.\n\n"))
}
-
if (!(type %in% c("crisp", "fuzzy"))) {
cat("\n")
- stop("Unknown calibration type.\n\n", call. = FALSE)
+ stop(simpleError("Unknown calibration type.\n\n"))
}
-
- if (all(is.na(thresholds))) {
+ if (!(method %in% c("direct", "indirect", "TFR"))) {
cat("\n")
- stop("Threshold value(s) not specified.\n\n", call. = FALSE)
+ stop(simpleError("Unknown calibration method.\n\n"))
}
-
+ if (method != "TFR") {
+ if(all(is.na(thresholds))) {
+ cat("\n")
+ stop(simpleError("Threshold value(s) not specified.\n\n"))
+ }
+ if (is.character(thresholds) & length(thresholds) == 1) {
+ thresholds <- splitstr(thresholds)
+ }
+ if (possibleNumeric(thresholds)) {
+ nmsths <- NULL
+ if (!is.null(names(thresholds))) {
+ nmsths <- names(thresholds)
+ }
+ thresholds <- asNumeric(thresholds)
+ names(thresholds) <- nmsths
+ }
+ else {
+ cat("\n")
+ stop(simpleError("Thresholds must be numeric.\n\n"))
+ }
+ }
if (type == "crisp") {
- xrange <- range(x, na.rm=TRUE)
- if (any(as.numeric(unclass(cut(thresholds, breaks=c(-Inf, xrange, Inf)))) != 2)) {
+ if (any(thresholds < min(x) | thresholds > max(x))) {
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
+ stop(simpleError("Threshold value(s) outside the range of x.\n\n"))
+ }
+ if (!is.null(names(thresholds))) {
+ cat("\n")
+ stop(simpleError("Named thresholds require fuzzy type calibration.\n\n"))
+ }
+ thresholds <- sort(thresholds)
+ return(findInterval(x, thresholds))
}
else if (type == "fuzzy") {
check.equal <- function(x, y) {
@@ -31,196 +87,218 @@
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]
+ lth <- length(thresholds)
+ nth <- names(thresholds)
+ if (method == "direct") {
+ if (lth != 3 & lth != 6) {
+ cat("\n")
+ stop(simpleError("For fuzzy direct calibration, there should be either 3 or 6 thresholds\".\n\n"))
+ }
+ if (idm <= 0.5 | idm >= 1) {
+ cat("\n")
+ stop(simpleError("The inclusion degree of membership has to be bigger than 0.5 and less than 1.\n\n"))
+ }
+ if (lth == 3) {
+ if (!is.null(names(thresholds))) {
+ if (length(unique(nth)) == sum(nth %in% c("e", "c", "i"))) {
+ thresholds <- thresholds[match(c("e", "c", "i"), nth)]
+ }
}
-
- y <- (x < thCR) + 1
- # y is the index of the position in the vector {-1, 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)
+ thresholds <- as.vector(thresholds)
+ 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
+ fs <- 1/(1 + exp(-((x - thCR) * (c(1, -1)[y]*log(idm/(1 - idm))/(c(thIN, thEX)[y] - thCR)))))
+ if (thresholds[1] > thresholds[3]) {
+ fs <- 1 - fs
+ }
}
else {
- return(result)
+ if (any(table(c(thEX, thCR, thIN)) > 1)) {
+ cat("\n")
+ warning(simpleWarning("Some thresholds equal, that should not be equal.\n\n"))
+ }
+ if (above <= 0 | below <= 0) {
+ cat("\n")
+ stop(simpleError("Arguments \"above\" and \"below\" should be positive.\n\n"))
+ }
+ 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))^below)/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))^above)/2
+ if (ecdf) {
+ fs[i] <- 1 - ((1 - Fn(x[i]))/(1 - Fn(thCR)))/2
+ }
+ }
+ else {
+ fs[i] <- 1
+ }
+ }
+ else {
+ 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))^above)/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))^below)/2
+ if (ecdf) {
+ fs[i] <- ((1 - Fn(x[i]))/(1 - Fn(thCR)))/2
+ }
+ }
+ else {
+ fs[i] <- 0
+ }
+ }
+ }
}
}
- else {
- if (any(table(c(thEX, thCR, thIN)) > 1)) {
+ else {
+ if (!is.null(nth)) {
+ if (length(unique(nth)) == sum(nth %in% c("e1", "c1", "i1", "i2", "c2", "e2"))) {
+ thresholds <- thresholds[match(c("e1", "c1", "i1", "i2", "c2", "e2"), nth)]
+ }
+ }
+ thresholds <- as.vector(thresholds)
+ 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")
- warning("Some thresholds equal, that should not be equal.\n\n", call. = FALSE)
+ stop(simpleError("First crossover threshold not between first exclusion and inclusion thresholds.\n\n"))
}
-
+ if (thCR2 < min(thEX2, thIN2) | thCR2 > max(thEX2, thIN2)) {
+ cat("\n")
+ stop(simpleError("Second crossover threshold not between second exclusion and inclusion thresholds.\n\n"))
+ }
+ somequal <- FALSE
+ if (any(table(c(thEX1, thCR1, thIN1)) > 1) | any(table(c(thIN2, thCR2, thEX2)) > 1) | thCR1 == thCR2) {
+ somequal <- TRUE
+ }
increasing <- TRUE
-
- if (thIN < thCR & thCR < thEX) {
+ if (thIN1 < thCR1 & thCR1 < thEX1 & thEX1 <= thEX2 & thEX2 < thCR2 & thCR2 < thIN2) {
increasing <- FALSE
- }
-
- if (ecdf) {
- ecdfx <- x[-which(x < min(thresholds))]
- ecdfx <- ecdfx[-which(ecdfx > max(thresholds))]
- Fn <- ecdf(ecdfx)
}
-
- fs <- rep(NA, length(x))
+ if (increasing) {
+ if (thEX1 == thEX2) {
+ somequal <- TRUE
+ }
+ }
+ else {
+ if (thIN1 == thIN2) {
+ somequal <- TRUE
+ }
+ }
+ if (somequal) {
+ cat("\n")
+ stop(simpleError("Some thresholds equal, that should not be equal.\n\n"))
+ }
+ if (above <= 0 | below <= 0) {
+ cat("\n")
+ stop(simpleError("Arguments \"above\" and \"below\" should be positive.\n\n"))
+ }
+ fs <- rep(NA, length(x))
for (i in seq(length(x))) {
if (increasing) {
- if (x[i] < thEX | check.equal(x[i], thEX)) {
+ if (x[i] < thEX1 | check.equal(x[i], thEX1)) {
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] < thCR1 | check.equal(x[i], thCR1)) {
+ fs[i] <- (((thEX1 - x[i])/(thEX1 - thCR1))^below)/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 if (x[i] < thIN1) {
+ fs[i] <- 1 - (((thIN1 - x[i])/(thIN1 - thCR1))^above)/2
}
- else {
+ 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))^above)/2
+ }
+ else if (x[i] < thEX2 | check.equal(x[i], thEX2)) {
+ fs[i] <- (((thEX2 - x[i])/(thEX2 - thCR2))^below)/2
+ }
+ else {
+ fs[i] <- 0
+ }
}
else {
- # return(list(Fn, thIN, thCR, thEX))
- if (x[i] < thIN | check.equal(x[i], thIN)) {
+ if (x[i] < thIN1 | check.equal(x[i], thIN1)) {
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] < thCR1 | check.equal(x[i], thCR1)) {
+ fs[i] <- 1 - (((thIN1 - x[i])/(thIN1 - thCR1))^above)/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 if (x[i] < thEX1) {
+ fs[i] <- (((thEX1 - x[i])/(thEX1 - thCR1))^below)/2
}
- else {
+ 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))^below)/2
+ }
+ else if (x[i] < thIN2 | check.equal(x[i], thIN2)) {
+ fs[i] <- 1 - (((thIN2 - x[i])/(thIN2 - thCR2))^above)/2
+ }
+ else {
+ fs[i] <- 1
+ }
}
}
}
+ fs[fs < 0.0001] <- 0
+ fs[fs > 0.9999] <- 1
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)
+ else if (method == "indirect") {
+ thresholds <- sort(thresholds)
+ values <- round(seq(0, 1, by = 1 / length(thresholds)), 3)
+ y <- rep(0, length(x))
+ for (i in seq(length(thresholds))) {
+ y[x > thresholds[i]] = values[i + 1]
}
-
- 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
- }
- }
- }
+ fracpol <- glm(y ~ log(x) + I(x^(1/2)) + I(x^1) + I(x^2), family = quasibinomial(logit))
+ fs <- round(unname(predict(fracpol, type = "response")), 6)
+ fs[fs < 0.0001] <- 0
+ fs[fs > 0.9999] <- 1
return(fs)
- }
+ }
+ else if (method == "TFR") {
+ E <- ecdf(x)
+ return(pmax(0, (E(x) - E(1)) / (1 - E(1))))
+ }
}
}
Modified: pkg/R/createMatrix.R
===================================================================
--- pkg/R/createMatrix.R 2014-12-17 19:40:55 UTC (rev 46)
+++ pkg/R/createMatrix.R 2018-07-20 08:10:23 UTC (rev 47)
@@ -1,27 +1,106 @@
-`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)
-}
-
+# 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.
+
+`createMatrix` <-
+function(noflevels, ...) {
+ other.args <- list(...)
+ RAM <- 2
+ if ("RAM" %in% names(other.args)) {
+ if (length(other.args$RAM) == 1) {
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/qca -r 47
More information about the Qca-commits
mailing list