[Qca-commits] r48 - in pkg: R data inst inst/gui inst/gui/www inst/gui/www/css inst/gui/www/css/images inst/gui/www/js inst/gui/www/shared inst/gui/www/shared/Raphael inst/gui/www/shared/Raphael.InlineTextEditing-master inst/gui/www/shared/jqueryui inst/gui/www/shared/jqueryui/1.12.1 inst/gui/www/shared/jqueryui/1.12.1/images inst/gui/www/shared/raphael-paragraph inst/gui/www/shared/shiny_0.12.2 inst/gui/www/shared/smartmenus-1.0.0-beta1 inst/gui/www/shared/smartmenus-1.0.0-beta1/css inst/gui/www/shared/smartmenus-1.0.0-beta1/css/sm-mint inst/staticdocs inst/staticdocs/css inst/staticdocs/img inst/staticdocs/js man src
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Jul 20 10:26:25 CEST 2018
Author: dusadrian
Date: 2018-07-20 10:26:24 +0200 (Fri, 20 Jul 2018)
New Revision: 48
Added:
pkg/R/GUIcall.R
pkg/R/XYplot.R
pkg/R/Xplot.R
pkg/R/causalChain.R
pkg/R/combinations.R
pkg/R/compute.R
pkg/R/dimnames.R
pkg/R/export.R
pkg/R/findRows.R
pkg/R/findmin.R
pkg/R/getInfo.R
pkg/R/getNoflevels.R
pkg/R/intersection.R
pkg/R/makeChart.R
pkg/R/minimize.R
pkg/R/modelFit.R
pkg/R/negate.R
pkg/R/numeric.R
pkg/R/panel.R
pkg/R/pofind.R
pkg/R/print.R
pkg/R/recode.R
pkg/R/removeRedundants.R
pkg/R/runGUI.R
pkg/R/sop.R
pkg/R/string.R
pkg/R/translate.R
pkg/R/uninstall.R
pkg/R/validateNames.R
pkg/data/CVF.tab.gz
pkg/data/CVR.tab.gz
pkg/data/Emme.tab.gz
pkg/data/HC.tab.gz
pkg/data/HarKem.RData
pkg/data/Krook.tab.gz
pkg/data/LC.tab.gz
pkg/data/LF.tab.gz
pkg/data/LM.tab.gz
pkg/data/LR.tab.gz
pkg/data/NF.tab.gz
pkg/data/RS.tab.gz
pkg/data/RagStr.tab.gz
pkg/data/Rokkan.tab.gz
pkg/data/d.AS.tab.gz
pkg/data/d.BWB.tab.gz
pkg/data/d.Bas.tab.gz
pkg/data/d.CS.tab.gz
pkg/data/d.CZH.tab.gz
pkg/data/d.Emm.tab.gz
pkg/data/d.HMN.tab.gz
pkg/data/d.Kil.tab.gz
pkg/data/d.Kro.tab.gz
pkg/data/d.RS.tab.gz
pkg/data/d.SA.tab.gz
pkg/data/d.SS.tab.gz
pkg/data/d.biodiversity.tab.gz
pkg/data/d.education.tab.gz
pkg/data/d.graduate.tab.gz
pkg/data/d.health.tab.gz
pkg/data/d.homeless.tab.gz
pkg/data/d.jobsecurity.tab.gz
pkg/data/d.napoleon.tab.gz
pkg/data/d.represent.tab.gz
pkg/data/d.socialsecurity.tab.gz
pkg/data/d.stakeholder.tab.gz
pkg/data/d.transport.tab.gz
pkg/data/d.urban.tab.gz
pkg/inst/gui/
pkg/inst/gui/server.R
pkg/inst/gui/www/
pkg/inst/gui/www/css/
pkg/inst/gui/www/css/images/
pkg/inst/gui/www/css/images/close.png
pkg/inst/gui/www/css/images/closeApple.png
pkg/inst/gui/www/css/images/closex.png
pkg/inst/gui/www/css/qcagui.css
pkg/inst/gui/www/index.html
pkg/inst/gui/www/js/
pkg/inst/gui/www/js/maincode.js
pkg/inst/gui/www/js/utils.js
pkg/inst/gui/www/shared/
pkg/inst/gui/www/shared/Raphael.InlineTextEditing-master/
pkg/inst/gui/www/shared/Raphael.InlineTextEditing-master/LICENSE
pkg/inst/gui/www/shared/Raphael.InlineTextEditing-master/README.md
pkg/inst/gui/www/shared/Raphael.InlineTextEditing-master/raphael.inline_text_editing.js
pkg/inst/gui/www/shared/Raphael/
pkg/inst/gui/www/shared/Raphael/license.txt
pkg/inst/gui/www/shared/Raphael/raphael-2.2.0-min.js
pkg/inst/gui/www/shared/jquery-3.3.1.min.js
pkg/inst/gui/www/shared/jquery-AUTHORS.txt
pkg/inst/gui/www/shared/jquery.raphael.spinner.js
pkg/inst/gui/www/shared/jqueryui/
pkg/inst/gui/www/shared/jqueryui/1.12.1/
pkg/inst/gui/www/shared/jqueryui/1.12.1/AUTHORS.txt
pkg/inst/gui/www/shared/jqueryui/1.12.1/LICENSE.txt
pkg/inst/gui/www/shared/jqueryui/1.12.1/images/
pkg/inst/gui/www/shared/jqueryui/1.12.1/images/animated-overlay.gif
pkg/inst/gui/www/shared/jqueryui/1.12.1/images/ui-bg_flat_0_aaaaaa_40x100.png
pkg/inst/gui/www/shared/jqueryui/1.12.1/images/ui-bg_flat_75_ffffff_40x100.png
pkg/inst/gui/www/shared/jqueryui/1.12.1/images/ui-bg_glass_55_fbf9ee_1x400.png
pkg/inst/gui/www/shared/jqueryui/1.12.1/images/ui-bg_glass_65_ffffff_1x400.png
pkg/inst/gui/www/shared/jqueryui/1.12.1/images/ui-bg_glass_75_dadada_1x400.png
pkg/inst/gui/www/shared/jqueryui/1.12.1/images/ui-bg_glass_75_e6e6e6_1x400.png
pkg/inst/gui/www/shared/jqueryui/1.12.1/images/ui-bg_glass_95_fef1ec_1x400.png
pkg/inst/gui/www/shared/jqueryui/1.12.1/images/ui-bg_highlight-soft_75_cccccc_1x100.png
pkg/inst/gui/www/shared/jqueryui/1.12.1/images/ui-icons_222222_256x240.png
pkg/inst/gui/www/shared/jqueryui/1.12.1/images/ui-icons_2e83ff_256x240.png
pkg/inst/gui/www/shared/jqueryui/1.12.1/images/ui-icons_444444_256x240.png
pkg/inst/gui/www/shared/jqueryui/1.12.1/images/ui-icons_454545_256x240.png
pkg/inst/gui/www/shared/jqueryui/1.12.1/images/ui-icons_888888_256x240.png
pkg/inst/gui/www/shared/jqueryui/1.12.1/images/ui-icons_cd0a0a_256x240.png
pkg/inst/gui/www/shared/jqueryui/1.12.1/jquery-ui.css
pkg/inst/gui/www/shared/jqueryui/1.12.1/jquery-ui.min.js
pkg/inst/gui/www/shared/raphael-paragraph/
pkg/inst/gui/www/shared/raphael-paragraph/LICENSE
pkg/inst/gui/www/shared/raphael-paragraph/raphael-paragraph.js
pkg/inst/gui/www/shared/shiny_0.12.2/
pkg/inst/gui/www/shared/shiny_0.12.2/shiny.css
pkg/inst/gui/www/shared/shiny_0.12.2/shiny.js
pkg/inst/gui/www/shared/smartmenus-1.0.0-beta1/
pkg/inst/gui/www/shared/smartmenus-1.0.0-beta1/LICENSE-MIT
pkg/inst/gui/www/shared/smartmenus-1.0.0-beta1/README.md
pkg/inst/gui/www/shared/smartmenus-1.0.0-beta1/css/
pkg/inst/gui/www/shared/smartmenus-1.0.0-beta1/css/sm-core-css.css
pkg/inst/gui/www/shared/smartmenus-1.0.0-beta1/css/sm-mint/
pkg/inst/gui/www/shared/smartmenus-1.0.0-beta1/css/sm-mint/sm-mint.css
pkg/inst/gui/www/shared/smartmenus-1.0.0-beta1/jquery.smartmenus.js
pkg/inst/staticdocs/
pkg/inst/staticdocs/CV.html
pkg/inst/staticdocs/LegacyDatasets.html
pkg/inst/staticdocs/Lipset.html
pkg/inst/staticdocs/QCA.package.html
pkg/inst/staticdocs/RS.html
pkg/inst/staticdocs/SOPexpression.html
pkg/inst/staticdocs/XYplot-10.svgz
pkg/inst/staticdocs/XYplot-11.svgz
pkg/inst/staticdocs/XYplot-12.svgz
pkg/inst/staticdocs/XYplot-13.svgz
pkg/inst/staticdocs/XYplot-14.svgz
pkg/inst/staticdocs/XYplot-15.svgz
pkg/inst/staticdocs/XYplot-3.svgz
pkg/inst/staticdocs/XYplot-5.svgz
pkg/inst/staticdocs/XYplot-6.svgz
pkg/inst/staticdocs/XYplot-7.svgz
pkg/inst/staticdocs/XYplot-8.svgz
pkg/inst/staticdocs/XYplot-9.svgz
pkg/inst/staticdocs/XYplot.html
pkg/inst/staticdocs/Xplot-1.svgz
pkg/inst/staticdocs/Xplot-2.svgz
pkg/inst/staticdocs/Xplot-3.svgz
pkg/inst/staticdocs/Xplot-4.svgz
pkg/inst/staticdocs/Xplot.html
pkg/inst/staticdocs/calibrate-10.svgz
pkg/inst/staticdocs/calibrate-12.svgz
pkg/inst/staticdocs/calibrate-14.svgz
pkg/inst/staticdocs/calibrate-16.svgz
pkg/inst/staticdocs/calibrate-18.svgz
pkg/inst/staticdocs/calibrate-20.svgz
pkg/inst/staticdocs/calibrate-21.svgz
pkg/inst/staticdocs/calibrate-22.svgz
pkg/inst/staticdocs/calibrate-26.svgz
pkg/inst/staticdocs/calibrate-3.svgz
pkg/inst/staticdocs/calibrate-30.svgz
pkg/inst/staticdocs/calibrate-31.svgz
pkg/inst/staticdocs/calibrate-6.svgz
pkg/inst/staticdocs/calibrate-8.svgz
pkg/inst/staticdocs/calibrate.html
pkg/inst/staticdocs/causalChain.html
pkg/inst/staticdocs/chartFunctions.html
pkg/inst/staticdocs/css/
pkg/inst/staticdocs/css/bootstrap-responsive.css
pkg/inst/staticdocs/css/bootstrap-responsive.min.css
pkg/inst/staticdocs/css/bootstrap.css
pkg/inst/staticdocs/css/bootstrap.min.css
pkg/inst/staticdocs/css/highlight.css
pkg/inst/staticdocs/css/staticdocs.css
pkg/inst/staticdocs/export.html
pkg/inst/staticdocs/factorize.html
pkg/inst/staticdocs/findRows.html
pkg/inst/staticdocs/findTh.html
pkg/inst/staticdocs/fuzzyops.html
pkg/inst/staticdocs/img/
pkg/inst/staticdocs/img/glyphicons-halflings-white.png
pkg/inst/staticdocs/img/glyphicons-halflings.png
pkg/inst/staticdocs/implicantMatrixFunctions.html
pkg/inst/staticdocs/index.html
pkg/inst/staticdocs/intersection.html
pkg/inst/staticdocs/js/
pkg/inst/staticdocs/js/bootstrap.js
pkg/inst/staticdocs/js/bootstrap.min.js
pkg/inst/staticdocs/minimize-1.svgz
pkg/inst/staticdocs/minimize-2.svgz
pkg/inst/staticdocs/minimize.html
pkg/inst/staticdocs/modelFit.html
pkg/inst/staticdocs/negate.html
pkg/inst/staticdocs/pof.html
pkg/inst/staticdocs/recode.html
pkg/inst/staticdocs/retention.html
pkg/inst/staticdocs/runGUI.html
pkg/inst/staticdocs/subsetsAndSupersets-2.svgz
pkg/inst/staticdocs/subsetsAndSupersets.html
pkg/inst/staticdocs/truthTable-20.svgz
pkg/inst/staticdocs/truthTable-22.svgz
pkg/inst/staticdocs/truthTable.html
pkg/man/CV.Rd
pkg/man/HC.Rd
pkg/man/LegacyDatasets.Rd
pkg/man/Lipset.Rd
pkg/man/NF.Rd
pkg/man/RS.Rd
pkg/man/SOPexpression.Rd
pkg/man/XYplot.Rd
pkg/man/Xplot.Rd
pkg/man/causalChain.Rd
pkg/man/chartFunctions.Rd
pkg/man/export.Rd
pkg/man/findRows.Rd
pkg/man/fuzzyops.Rd
pkg/man/implicantMatrixFunctions.Rd
pkg/man/intersection.Rd
pkg/man/minimize.Rd
pkg/man/modelFit.Rd
pkg/man/negate.Rd
pkg/man/recode.Rd
pkg/man/runGUI.Rd
pkg/man/subsetsAndSupersets.Rd
pkg/src/QCA.c
pkg/src/registerDynamicSymbol.c
Log:
version 3.3
Added: pkg/R/GUIcall.R
===================================================================
--- pkg/R/GUIcall.R (rev 0)
+++ pkg/R/GUIcall.R 2018-07-20 08:26:24 UTC (rev 48)
@@ -0,0 +1,57 @@
+# 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(type = "", ...) {
+ jsonify <- function(x) {
+ nms <- names(x)
+ result <- 'result = { '
+ for (i in seq(length(x))) {
+ if (is.vector(x[[i]])) {
+ collapse <- ', '
+ prefix <- ''
+ if (is.character(x[[i]])) {
+ collapse <- '", "'
+ prefix <- '"'
+ }
+ result <- paste(result,
+ sprintf('"%s": [ %s%s%s ]', nms[i], prefix, paste(x[[i]], collapse = collapse), prefix)
+ )
+ }
+ else if (is.list(x[[i]])) {
+ }
+ if (i < length(x)) {
+ result <- paste(result, ',')
+ }
+ }
+ result <- paste(result, '};')
+ cat(result)
+ }
+ test <- function(...) {
+ jsonify(list(...))
+ }
+ switch(type,
+ test = test(... = ...)
+ )
+}
Added: pkg/R/XYplot.R
===================================================================
--- pkg/R/XYplot.R (rev 0)
+++ pkg/R/XYplot.R 2018-07-20 08:26:24 UTC (rev 48)
@@ -0,0 +1,476 @@
+# 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.
+
+`XYplot` <- function(x, y, data, relation = "sufficiency", mguides = TRUE,
+ jitter = FALSE, clabels = NULL, enhance = FALSE, model = FALSE, ...) {
+ other.args <- list(...)
+ funargs <- unlist(lapply(match.call(), deparse)[-1])
+ if (missing(x)) {
+ cat("\n")
+ stop(simpleError("Argument x is mandatory.\n\n"))
+ }
+ via.web <- FALSE
+ if (length(testarg <- which(names(other.args) == "via.web")) > 0) {
+ via.web <- other.args$via.web
+ other.args <- other.args[-testarg]
+ }
+ negated <- logical(2)
+ xname <- yname <- ""
+ minus <- rawToChar(as.raw(c(226, 128, 147)))
+ testit <- capture.output(tryCatch(eval(x), error = function(e) e))
+ if (length(testit) == 1 & is.character(testit)) {
+ if (grepl("Error", testit)) {
+ x <- as.vector(funargs["x"])
+ }
+ }
+ if (is.vector(x) & is.character(x) & any(grepl("\\$solution", funargs["x"]))) {
+ x <- list(x)
+ }
+ if (is.character(x)) {
+ if (x == tolower(x) & x != toupper(x)) {
+ if (eval.parent(parse(text = sprintf("is.element(\"%s\", ls())", toupper(x))), n = 1)) {
+ conds <- toupper(x)
+ x <- 1 - eval.parent(parse(text = sprintf("get(\"%s\")", toupper(x))), n = 1)
+ negated[1] <- TRUE
+ }
+ }
+ }
+ else {
+ testit <- capture.output(tryCatch(eval(x), error = function(e) e))
+ if (length(testit) == 1 & is.character(testit)) {
+ if (grepl("Error", testit)) {
+ x <- as.vector(deparse(funargs["x"]))
+ }
+ else if (hastilde(testit)) {
+ negated[1] <- TRUE
+ if (eval.parent(parse(text = sprintf("is.element(\"%s\", ls())", notilde(testit))), n = 1)) {
+ x <- 1 - eval.parent(parse(text = sprintf("get(\"%s\")", notilde(testit))), n = 1)
+ }
+ else {
+ x <- testit
+ }
+ }
+ }
+ }
+ if (is.list(x)) {
+ if (any(grepl("\\$solution", funargs["x"]))) {
+ model <- TRUE
+ obj <- get(unlist(strsplit(funargs["x"], split = "[$]"))[1])
+ data <- obj$tt$initial.data
+ y <- obj$tt$options$outcome
+ if (obj$tt$options$neg.out) {
+ y <- paste("~", y, sep = "")
+ }
+ x <- paste(unlist(x), collapse = " + ")
+ }
+ }
+ if (!is.data.frame(x) & !is.matrix(x) & !missing(y)) {
+ testit <- capture.output(tryCatch(eval(y), error = function(e) e))
+ if (length(testit) == 1 & is.character(testit)) {
+ if (grepl("Error", testit)) {
+ y <- as.vector(funargs["y"])
+ }
+ }
+ if (!is.character(y)) {
+ testit <- capture.output(tryCatch(eval(y), error = function(e) e))
+ if (length(testit) == 1 & is.character(testit)) {
+ if (grepl("Error", testit)) {
+ y <- deparse(funargs["y"])
+ }
+ else if (hastilde(testit)) {
+ negated[2] <- TRUE
+ if (eval.parent(parse(text = sprintf("is.element(\"%s\", ls())", notilde(testit))), n = 1)) {
+ y <- 1 - eval.parent(parse(text = sprintf("get(\"%s\")", notilde(testit))), n = 1)
+ }
+ else {
+ y <- testit
+ }
+ }
+ }
+ }
+ else {
+ if (y == tolower(y) & y != toupper(y)) {
+ if (eval.parent(parse(text = sprintf("is.element(\"%s\", ls())", toupper(y))), n = 1)) {
+ conds <- toupper(y)
+ y <- 1 - eval.parent(parse(text = sprintf("get(\"%s\")", toupper(y))), n = 1)
+ negated[2] <- TRUE
+ }
+ }
+ }
+ }
+ if (is.character(x)) {
+ if (length(x) == 1) {
+ x <- splitstr(x)
+ }
+ if (length(x) == 1) {
+ x <- unlist(strsplit(x, split = "=>"))
+ if (length(x) == 1) {
+ x <- unlist(strsplit(x, split = "<="))
+ if (length(x) > 1) {
+ relation <- "necessity"
+ y <- trimstr(x[2])
+ x <- trimstr(x[1])
+ }
+ }
+ else {
+ y <- trimstr(x[2])
+ x <- trimstr(x[1])
+ }
+ if (missing(y)) {
+ cat("\n")
+ stop(simpleError("The outcome's name is missing.\n\n"))
+ }
+ else if (!is.character(y)) {
+ cat("\n")
+ stop(simpleError("x and y should be both column names from the data.\n\n"))
+ }
+ }
+ else {
+ if (!missing(y)) {
+ if (is.data.frame(y)) {
+ data <- y
+ }
+ }
+ y <- x[2]
+ x <- x[1]
+ }
+ if (missing(data)) {
+ cat("\n")
+ stop(simpleError("Data is missing.\n\n"))
+ }
+ else {
+ verify.qca(data)
+ }
+ xname <- as.character(parse(text = x))
+ yname <- as.character(parse(text = y))
+ x <- gsub(minus, "-", gsub("[[:space:]]", "", x))
+ y <- gsub(minus, "-", gsub("[[:space:]]", "", y))
+ negated <- logical(2)
+ negated[1] <- identical(unname(substring(x, 1, 2)), "1-")
+ negated[2] <- identical(unname(substring(y, 1, 2)), "1-")
+ if (any(checks <- grepl("1-", c(x, y)) & !negated)) {
+ cat("\n")
+ stop(simpleError(paste("Incorrect expression in \"", paste(c(x, y)[checks], collapse = "\" and \""), "\".\n\n", sep = "")))
+ }
+ x <- compute(x, data = data)
+ y <- compute(y, data = data)
+ negated <- logical(2)
+ }
+ else if (is.data.frame(x) | is.matrix(x)) {
+ verify.qca(as.data.frame(x))
+ if (ncol(x) < 2) {
+ cat("\n")
+ stop(simpleError("At least two columns are needed.\n\n"))
+ }
+ xname <- colnames(x)[1]
+ yname <- colnames(x)[2]
+ y <- x[, 2]
+ x <- x[, 1]
+ }
+ else if (!missing(y)) {
+ if (length(x) > 1 & is.numeric(x)) {
+ oneminus <- identical(unname(substring(gsub("[[:space:]]", "", funargs[1]), 1, 2)), "1-")
+ if (any((hastilde(funargs[1]) & !tilde1st(funargs[1])) |
+ (grepl("1-", funargs[1]) & !oneminus)
+ )) {
+ cat("\n")
+ stop(simpleError(paste("Incorrect expression in \"", funargs[1], "\".\n\n", sep = "")))
+ }
+ negated[1] <- oneminus | tilde1st(funargs[1])
+ xname <- "X"
+ tc <- capture.output(tryCatch(getName(funargs[1]), error = function(e) e, warning = function(w) w))
+ if (!grepl("simpleError", tc)) {
+ xname <- notilde(getName(funargs[1]))
+ }
+ }
+ if (length(y) > 1 & is.numeric(y)) {
+ oneminus <- identical(unname(substring(gsub("[[:space:]]", "", funargs[2]), 1, 2)), "1-")
+ if (any((hastilde(funargs[2]) & !tilde1st(funargs[2])) |
+ (grepl("1-", funargs[2]) & !oneminus)
+ )) {
+ cat("\n")
+ stop(simpleError(paste("Incorrect expression in \"", funargs[2], "\".\n\n", sep = "")))
+ }
+ negated[2] <- oneminus | tilde1st(funargs[2])
+ yname <- "Y"
+ tc <- capture.output(tryCatch(getName(funargs[2]), error = function(e) e, warning = function(w) w))
+ if (!grepl("simpleError", tc)) {
+ yname <- notilde(getName(funargs[2]))
+ }
+ }
+ if (length(y) == 1 & is.character(y)) {
+ if (missing(data)) {
+ cat("\n")
+ stop(simpleError("Data is missing.\n\n"))
+ }
+ else {
+ verify.qca(data)
+ }
+ yname <- as.character(parse(text = y))
+ y <- gsub(minus, "-", gsub("[[:space:]]", "", y))
+ negated[2] <- identical(unname(substring(y, 1, 2)), "1-")
+ if (grepl("1-", y) & !negated[2]) {
+ cat("\n")
+ stop(simpleError(paste("Incorrect expression in \"", y, "\".\n\n", sep = "")))
+ }
+ y <- compute(y, data = data)
+ negated[2] <- FALSE
+ }
+ }
+ else {
+ cat("\n")
+ stop(simpleError("Either a dataframe with two columns or two vectors are needed.\n\n"))
+ }
+ if (any(x > 1) | any(y > 1)) {
+ cat("\n")
+ stop(simpleError("Values should be bound between 0 and 1.\n\n"))
+ }
+ xcopy <- x
+ ycopy <- y
+ jitfactor <- 0.01
+ jitamount <- 0.01
+ cexaxis <- 0.8
+ hadj <- 1.1
+ padj <- 0
+ linex <- 1.75
+ liney <- 2
+ linet <- 1.5
+ pch <- rep(21, length(x))
+ cexpoints <- rep(0.8, length(x))
+ bgpoints <- rep("#707070", length(x)) # "#ababab"
+ if (length(testarg <- which(names(other.args) == "pch")) > 0) {
+ pch <- other.args$pch
+ if (length(pch) == 1) {
+ pch <- rep(pch, length(x))
+ }
+ else {
+ if (length(pch) != length(x)) {
+ cat("\n")
+ stop(simpleError(sprintf("Length of argument \"pch\" different from the %s.\n\n", ifelse(missing(data), "length of \"x\"", "number of rows in the data"))))
+ }
+ }
+ other.args <- other.args[-testarg]
+ }
+ if (length(testarg <- which(names(other.args) == "cex")) > 0) {
+ cexpoints <- other.args$cex
+ if (length(cexpoints) == 1) {
+ cexpoints <- rep(cexpoints, length(x))
+ }
+ else {
+ if (length(cexpoints) != length(x)) {
+ cat("\n")
+ stop(simpleError(sprintf("Length of argument \"cex\" different from the %s.\n\n", ifelse(missing(data), "length of \"x\"", "number of rows in the data"))))
+ }
+ }
+ other.args <- other.args[-testarg]
+ }
+ bginput <- is.element("bg", names(other.args))
+ if (length(testarg <- which(names(other.args) == "bg")) > 0) {
+ bgpoints <- other.args$bg
+ if (length(bgpoints) == 1) {
+ bgpoints <- rep(bgpoints, length(x))
+ }
+ else {
+ if (length(bgpoints) != length(x)) {
+ cat("\n")
+ stop(simpleError(sprintf("Length of argument \"bg\" different from the %s.\n\n", ifelse(missing(data), "length of \"x\"", "number of rows in the data"))))
+ }
+ }
+ other.args <- other.args[-testarg]
+ }
+ if (length(testarg <- which(names(other.args) == "factor")) > 0) {
+ jitfactor <- other.args$factor
+ other.args <- other.args[-testarg]
+ }
+ if (length(testarg <- which(names(other.args) == "amount")) > 0) {
+ jitamount <- other.args$amount
+ other.args <- other.args[-testarg]
+ }
+ if (length(testarg <- which(names(other.args) == "hadj")) > 0) {
+ hadj <- other.args$hadj
+ other.args <- other.args[-testarg]
+ }
+ if (length(testarg <- which(names(other.args) == "padj")) > 0) {
+ padj <- other.args$padj
+ other.args <- other.args[-testarg]
+ }
+ if (length(testarg <- which(names(other.args) == "line")) > 0) {
+ linex <- other.args$line[1]
+ liney <- ifelse(is.na(other.args$line[2]), other.args$line[1], other.args$line[2])
+ linet <- ifelse(is.na(other.args$line[3]), other.args$line[1], other.args$line[3])
+ other.args <- other.args[-testarg]
+ }
+ if (!is.null(clabels)) {
+ if (is.numeric(clabels)) {
+ if (length(clabels) < length(x)) {
+ if (all(clabels <= length(x))) {
+ rownms <- rep("", length(x))
+ rownms[clabels] <- clabels
+ clabels <- rownms
+ }
+ else {
+ cat("\n")
+ stop(simpleError("Values in the argument \"clabels\" outside the rows of the data.\n\n"))
+ }
+ }
+ clabels <- as.character(clabels)
+ }
+ if (length(clabels) != length(x)) {
+ cat("\n")
+ stop(simpleError(sprintf("Length of argument \"clabels\" larger than %s.\n\n", ifelse(missing(data), "length of \"x\"", "number of rows in the data"))))
+ }
+ if (is.logical(clabels)) {
+ if (missing(data)) {
+ rownms <- seq(length(x))
+ }
+ else {
+ rownms <- rownames(data)
+ }
+ rownms[!clabels] <- ""
+ clabels <- rownms
+ }
+ }
+ cexlabels <- cexpoints
+ if (enhance) {
+ if (is.null(clabels)) {
+ caselabels <- rep("", length(x))
+ }
+ if (relation == "sufficiency") {
+ if (any(selection <- x >= 0.5 & y >= 0.5 & x <= y)) {
+ if (is.null(clabels) & !model) {
+ if (missing(data)) {
+ caselabels[selection] <- which(selection)
+ }
+ else {
+ caselabels[selection] <- rownames(data)[selection]
+ }
+ }
+ xs <- x[selection]
+ ys <- y[selection]
+ pch[which(selection)][which.min((ys - xs)/xs)] <- 3
+ }
+ if (any(selection <- x >= 0.5 & y >= 0.5 & x > y)) {
+ if (is.null(clabels) & !model) {
+ if (missing(data)) {
+ caselabels[selection] <- which(selection)
+ }
+ else {
+ caselabels[selection] <- rownames(data)[selection]
+ }
+ }
+ if (!bginput) {
+ bgpoints[selection] <- "#cccccc"
+ }
+ }
+ if (any(selection <- x >= 0.5 & y < 0.5)) {
+ xs <- x[selection]
+ ys <- y[selection]
+ pch[selection] <- 23
+ if (!bginput) {
+ bgpoints[which(selection)][which.min(1 - (ys - xs)/xs)] <- "#cccccc"
+ }
+ }
+ if (any(selection <- x < 0.5 & y < 0.5)) {
+ if (is.null(clabels) & model) {
+ caselabels[selection] <- rownames(data)[selection]
+ }
+ cexpoints[selection] <- 0.875 * cexpoints[selection]
+ pch[selection] <- 24
+ if (!bginput) {
+ bgpoints[selection] <- "#cccccc"
+ }
+ }
+ if (any(selection <- x < 0.5 & y >= 0.5)) {
+ if (is.null(clabels) & model) {
+ caselabels[selection] <- rownames(data)[selection]
+ }
+ pch[selection] <- 22
+ if (!bginput) {
+ bgpoints[selection] <- "#cccccc"
+ }
+ }
+ }
+ if (is.null(clabels)) {
+ clabels <- caselabels
+ }
+ }
+ if (jitter) {
+ x <- jitter(x, jitfactor, jitamount)
+ y <- jitter(y, jitfactor, jitamount)
+ }
+ toplot <- list(x = x, y = y)
+ xlabel <- paste0(ifelse(negated[1], "~", ""), xname)
+ ylabel <- paste0(ifelse(negated[2], "~", ""), yname)
+ if (model) xlabel <- "MODEL"
+ if (length(testarg <- which(names(other.args) == "xlab")) > 0) {
+ xlabel <- other.args$xlab
+ other.args <- other.args[-testarg]
+ }
+ if (length(testarg <- which(names(other.args) == "ylab")) > 0) {
+ ylabel <- other.args$ylab
+ other.args <- other.args[-testarg]
+ }
+ if (length(testarg <- which(names(other.args) == "cex.axis")) > 0) {
+ cexaxis <- other.args$cex.axis
+ other.args <- other.args[-testarg]
+ }
+ toplot$type <- "n"
+ toplot$xlim <- c(0, 1)
+ toplot$ylim <- c(0, 1)
+ toplot$xlab <- ""
+ toplot$ylab <- ""
+ toplot$axes <- FALSE
+ if (length(other.args) > 0) {
+ toplot <- c(toplot, other.args)
+ }
+ par(mar = c(3, 3.1, 2.5, 0.5), cex.axis = cexaxis, tck = -.015,
+ las = 1, xpd = FALSE, mgp = c(1.5, 0.5, 0))
+ suppressWarnings(do.call("plot", toplot))
+ box()
+ axis(1, xaxp = c(0, 1, 10), padj = padj)
+ axis(2, yaxp = c(0, 1, 10), hadj = hadj)
+ title(xlab = xlabel, cex.lab = cexaxis + 0.1, font.lab = 2, line = linex)
+
+ title(ylab = ylabel, cex.lab = cexaxis + 0.1, font.lab = 2, line = liney)
+ title(main = paste(ifelse(nec(relation), "Necessity", "Sufficiency"), "relation"),
+ cex.main = cexaxis/0.8, font.main = 2, line = linet)
+ if (mguides) {
+ abline(v = .5, lty = 2, col = "gray")
+ abline(h = .5, lty = 2, col = "gray")
+ }
+ abline(0, 1, col = "gray")
+ plotpoints <- list(x, y, pch = pch, cex = cexpoints, bg = bgpoints)
+ suppressWarnings(do.call("points", c(plotpoints, other.args)))
+ inclcov <- round(pof(setms = xcopy, outcome = ycopy, relation = relation)$incl.cov[1, 1:3], 3)
+ inclcov[is.na(inclcov)] <- 0
+ inclcov <- sprintf("%.3f", inclcov)
+ mtext(paste(c("Inclusion:", "Coverage:", ifelse(nec(relation), "Relevance:", "PRI:")),
+ inclcov[c(1, 3, 2)], collapse = " "), at = 0, adj = 0, cex = cexaxis)
+ cexl <- ifelse(any(names(other.args) == "cex"), other.args$cex, 1)
+ srtl <- ifelse(any(names(other.args) == "srt"), other.args$srt, 0)
+ if (!is.null(clabels)) {
+ text(x, y + 0.02, labels = clabels, srt = srtl, cex = cexlabels*cexl)
+ }
+}
Added: pkg/R/Xplot.R
===================================================================
--- pkg/R/Xplot.R (rev 0)
+++ pkg/R/Xplot.R 2018-07-20 08:26:24 UTC (rev 48)
@@ -0,0 +1,91 @@
+# 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.
+
+`Xplot` <- function(x, jitter = FALSE, at = NULL, ...) {
+ other.args <- list(...)
+ funargs <- unlist(lapply(match.call(), deparse)[-1])
+ xname <- getName(funargs[1])
+ linex <- 1.75
+ jitfactor <- 0.5
+ jitamount <- 0.5
+ cexpoints <- 1
+ cexaxis <- 0.8
+ pch <- 21
+ bgpoints <- NA
+ if (length(testarg <- which(names(other.args) == "line")) > 0) {
+ linex <- other.args$line
+ other.args <- other.args[-testarg]
+ }
+ if (length(testarg <- which(names(other.args) == "factor")) > 0) {
+ jitfactor <- other.args$factor
+ other.args <- other.args[-testarg]
+ }
+ if (length(testarg <- which(names(other.args) == "amount")) > 0) {
+ jitamount <- other.args$amount
+ other.args <- other.args[-testarg]
+ }
+ if (length(testarg <- which(names(other.args) == "cex")) > 0) {
+ cexpoints <- other.args$cex
+ other.args <- other.args[-testarg]
+ }
+ if (length(testarg <- which(names(other.args) == "cex.axis")) > 0) {
+ cexaxis <- other.args$cex.axis
+ other.args <- other.args[-testarg]
+ }
+ if (length(testarg <- which(names(other.args) == "pch")) > 0) {
+ pch <- other.args$pch
+ other.args <- other.args[-testarg]
+ }
+ if (length(testarg <- which(names(other.args) == "bg")) > 0) {
+ bgpoints <- other.args$bg
+ other.args <- other.args[-testarg]
+ }
+ if (length(testarg <- which(names(other.args) == "xlab")) > 0) {
+ xname <- other.args$xlab
+ other.args <- other.args[-testarg]
+ }
+ y <- rep(1, length(x))
+ if (jitter) {
+ y <- jitter(y, jitfactor, jitamount)
+ }
+ toplot <- list(as.name("plot"), x, y)
+ toplot$type <- "n"
+ if (!is.null(at)) {
+ toplot$xlim <- range(at)
+ }
+ toplot$ylim <- c(0, 2)
+ toplot$xlab <- ""
+ toplot$ylab <- ""
+ toplot$axes <- FALSE
+ if (length(other.args) > 0) {
+ toplot <- c(toplot, other.args)
+ }
+ par(mar = c(ifelse(xname == "", 2, 3), 0.3, 0, 0))
+ suppressWarnings(eval(as.call(toplot)))
+ axis(1, at = at, cex.axis = cexaxis)
+ title(xlab = xname, cex.lab = cexaxis + 0.1, font.lab = 2, line = linex)
+ plotpoints <- list(as.name("points"), x, y, pch = pch, cex = cexpoints, bg = bgpoints)
+ suppressWarnings(eval(as.call(c(plotpoints, other.args))))
+}
Added: pkg/R/causalChain.R
===================================================================
--- pkg/R/causalChain.R (rev 0)
+++ pkg/R/causalChain.R 2018-07-20 08:26:24 UTC (rev 48)
@@ -0,0 +1,168 @@
+# 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.
+
+`causalChain` <-
+function(data, ordering = NULL, strict = FALSE, ...) {
+ metacall <- match.call(expand.dots = TRUE)
+ allargs <- as.list(metacall)[-1]
+ allargs <- allargs[-which(is.element(c("data", "ordering", "strict"), names(allargs)))]
+ sol.cons <- 1
+ if (is.element("sol.cons", names(allargs))) {
+ sol.cons <- allargs$sol.cons
+ }
+ sol.cons <- ifelse(sol.cons > 0 & sol.cons < 1, sol.cons, 1)
+ pi.cons <- 1
+ if (is.element("pi.cons", names(allargs))) {
+ pi.cons <- allargs$pi.cons
+ }
+ if (any(c(pi.cons, sol.cons) < 1) & !is.element("incl.cut", names(allargs))) {
+ allargs$incl.cut <- 0.5
+ }
+ verify.qca(data)
+ noflevels <- getInfo(data, colnames(data), colnames(data)[1])
+ mv <- noflevels > 2
+ names(noflevels) <- names(mv) <- colnames(data)
+ if (class(ordering) == "character") {
+ ordering <- gsub("[[:space:]]", "", ordering)
+ if (length(ordering) == 1) {
+ ordering <- unlist(strsplit(ordering, split = "<"))
+ }
+ else {
+ if (any(grepl("<", ordering))) {
+ cat("\n")
+ stop(simpleError("Causal ordering character \"<\" requires a single string.\n\n"))
+ }
+ }
+ ordering <- lapply(ordering, splitstr)
+ }
+ if (length(allout <- unlist(ordering)) > 0) {
+ if (length(setdiff(toupper(allout), toupper(colnames(data)))) > 0) {
+ cat("\n")
+ stop(simpleError("Some elements in the \"ordering\" argument not found in the data.\n\n"))
+ }
+ }
+ allargs <- c(list(input = data), allargs)
+ checkpos <- function(x, arg) {
+ pos <- pmatch(names(allargs), arg)
+ return(pos[!is.na(pos)])
+ }
+ pos <- checkpos(allargs, "include")
+ if (length(pos) == 0) {
+ allargs$include <- "?"
+ }
+ pos <- checkpos(allargs, "all.sol")
+ if (length(pos) == 0) {
+ allargs$all.sol <- TRUE
+ }
+ pos <- checkpos(allargs, "SA")
+ if (length(pos) == 0) {
+ allargs$SA <- FALSE
+ }
+ minimizeit <- function(allargs) {
+ tc <- tryCatch(do.call("minimize", allargs), error = function(e) e)
+ if (inherits(tc, "error")) return(NA)
+ return(tc)
+ }
+ allargs$enter <- FALSE
+ minimize.list <- list()
+ if (length(ordering) > 0) {
+ if (any(table(unlist(ordering)) > 1)) {
+ cat("\n")
+ stop(simpleError("Same condition(s) in multiple ordering levels.\n\n"))
+ }
+ allcols <- colnames(data)
+ if (length(restcols <- setdiff(allcols, unlist(ordering))) > 0) {
+ ordering <- c(list(restcols), ordering)
+ }
+ for (i in seq(length(ordering))) {
+ nextcols <- ordering[[i]]
+ if (i == 1) {
+ if (!strict & length(nextcols) > 1) {
+ for (j in seq(length(nextcols))) {
+ allargs$input <- data[, nextcols, drop = FALSE]
+ if (mv[nextcols[j]]) {
+ uniqv <- sort(unique(data[, nextcols[j]]))
+ for (v in seq(noflevels[nextcols[j]] - 1)) {
+ if (is.element(v, uniqv)) {
+ allargs$outcome <- sprintf("%s{%s}", nextcols[j], v)
+ minimize.list[[allargs$outcome]] <- minimizeit(allargs)
+ }
+ }
+ }
+ else {
+ allargs$outcome <- nextcols[j]
+ minimize.list[[allargs$outcome]] <- minimizeit(allargs)
+ }
+ }
+ }
+ }
+ else {
+ restcols <- unlist(ordering[seq(i - 1)])
+ for (j in seq(length(nextcols))) {
+ if (strict) {
+ allcols <- c(restcols, nextcols[j])
+ }
+ else {
+ allcols <- c(restcols, nextcols)
+ }
+ allcols <- allcols[order(match(allcols, colnames(data)))]
+ allargs$input <- data[, allcols, drop = FALSE]
+ if (mv[nextcols[j]]) {
+ uniqv <- sort(unique(data[, nextcols[j]]))
+ for (v in seq(noflevels[nextcols[j]] - 1)) {
+ if (is.element(v, uniqv)) {
+ allargs$outcome <- sprintf("%s{%s}", nextcols[j], v)
+ minimize.list[[allargs$outcome]] <- minimizeit(allargs)
+ }
+ }
+ }
+ else {
+ allargs$outcome <- nextcols[j]
+ minimize.list[[allargs$outcome]] <- minimizeit(allargs)
+ }
+ }
+ }
+ }
+ }
+ else {
+ for (x in colnames(data)) {
+ if (mv[x]) {
+ uniqv <- sort(unique(data[, x]))
+ for (v in seq(noflevels[x] - 1)) {
+ if (is.element(v, uniqv)) {
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/qca -r 48
More information about the Qca-commits
mailing list