[Qca-commits] r70 - in pkg: R data inst/gui/www inst/staticdocs man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Oct 30 20:25:25 CET 2020
Author: dusadrian
Date: 2020-10-30 20:25:25 +0100 (Fri, 30 Oct 2020)
New Revision: 70
Removed:
pkg/R/Electron.R
pkg/R/GUIcall.R
pkg/R/combinations.R
pkg/R/compute.R
pkg/R/export.R
pkg/R/factorize.R
pkg/R/getInfo.R
pkg/R/getLevels.R
pkg/R/getNoflevels.R
pkg/R/intersection.R
pkg/R/negate.R
pkg/R/numeric.R
pkg/R/prettyString.R
pkg/R/prettyTable.R
pkg/R/recode.R
pkg/R/simplify.R
pkg/R/sop.R
pkg/R/sortExpressions.R
pkg/R/translate.R
pkg/R/uninstall.R
pkg/R/validateNames.R
pkg/R/writePrimeimp.R
pkg/data/CVF.tab.gz
pkg/data/CVR.tab.gz
pkg/data/Emme.tab.gz
pkg/data/HC.tab.gz
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/www/shared/
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/Xplot-1.svgz
pkg/inst/staticdocs/Xplot-2.svgz
pkg/inst/staticdocs/Xplot-3.svgz
pkg/inst/staticdocs/Xplot-4.svgz
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/minimize-1.svgz
pkg/inst/staticdocs/minimize-2.svgz
pkg/inst/staticdocs/subsetsAndSupersets-2.svgz
pkg/inst/staticdocs/truthTable-20.svgz
pkg/inst/staticdocs/truthTable-22.svgz
pkg/man/SOPexpression.Rd
pkg/man/export.Rd
pkg/man/factorize.Rd
pkg/man/intersection.Rd
pkg/man/negate.Rd
pkg/man/recode.Rd
Log:
version 3.10.1 deleting files
Deleted: pkg/R/Electron.R
===================================================================
--- pkg/R/Electron.R 2020-10-30 19:06:13 UTC (rev 69)
+++ pkg/R/Electron.R 2020-10-30 19:25:25 UTC (rev 70)
@@ -1,297 +0,0 @@
-# Copyright (c) 2019, Adrian Dusa
-# All rights reserved.
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, in whole or in part, are permitted provided that the
-# following conditions are met:
-# * Redistributions of source code must retain the above copyright
-# notice, this list of conditions and the following disclaimer.
-# * Redistributions in binary form must reproduce the above copyright
-# notice, this list of conditions and the following disclaimer in the
-# documentation and/or other materials provided with the distribution.
-# * The names of its contributors may NOT be used to endorse or promote products
-# derived from this software without specific prior written permission.
-#
-# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-# DISCLAIMED. IN NO EVENT SHALL ADRIAN DUSA BE LIABLE FOR ANY
-# DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
-# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
-# LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
-# ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-`GUIcall` <- function(commandlist) {
- QCA_env <- as.environment("package:QCA")
- if (is.element("invisibleEnvironment", ls(envir = QCA_env))) {
- ev <- QCA_env$invisibleEnvironment
- }
- else {
- ev <- new.env()
- ev$firstHistory <- TRUE
- ev$hashes <- list()
- ev$visiblecols <- 8
- ev$visiblerows <- 17
- if (.Call("C_unlock", QCA_env, PACKAGE = "QCA")) {
- QCA_env$invisibleEnvironment <- ev
- }
- else {
- cat("\n")
- stop(simpleError("Cannot unlock QCA environment.\n\n"))
- }
- }
- nms <- names(commandlist)
- result <- c()
- `hashobjs` <- function(...) {
- return(lapply(globalenv(), function(x) fastdigest::fastdigest(x)))
- }
- `jsonify` <- function(x) {
- nms <- names(x)
- result <- ""
- for (i in seq(length(x))) {
- xi <- x[[i]]
- if (inherits(xi, "list")) {
- if (length(xi) > 0) {
- nmsi <- names(xi)
- if (is.null(nmsi)) {
- result <- paste(result, "'", nms[i], "'", ": [", Recall(xi), "]", sep = "")
- }
- else {
- if (is.null(xi)) {
- result <- paste(result, "'", nms[i], "'", ": undefined", sep = "")
- }
- else {
- result <- paste(result, "'", nms[i], "'", ": {", Recall(xi), "}", sep = "")
- }
- }
- }
- else {
- result <- paste(result, "'", nms[i], "'", ": {}", sep = "")
- }
- }
- else {
- collapse <- ", "
- prefix <- ""
- if (is.character(xi)) {
- collapse <- "`, `"
- prefix <- "`"
- }
- if (is.logical(x[[i]])) x[[i]] <- QCA::recode(x[[i]], "TRUE = true; FALSE = false")
- result <- paste(result,
- ifelse (is.null(nms[i]),
- sprintf(ifelse(length(x[[i]]) > 1, " [ %s%s%s ]", "%s%s%s"), prefix, paste(x[[i]], collapse = collapse), prefix),
- sprintf(ifelse(length(x[[i]]) > 1, "'%s': [ %s%s%s ]", "'%s': %s%s%s"), nms[i], prefix, paste(x[[i]], collapse = collapse), prefix)
- )
- )
- }
- if (i < length(x)) {
- result <- paste(result, ",", sep = "")
- }
- }
- return(result)
- }
- `scrollobj` <- function(...) {
- x <- list(...)
- scrollvh <- lapply(x$scrollvh, function(x) unlist(x) + 1)
- ev$visiblerows <- x$visiblerows + 1
- ev$visiblecols <- x$visiblecols + 1
- if (!x$alldata) {
- scrollvh <- scrollvh[x$dataset]
- }
- tosend <- vector(mode = "list", length = length(scrollvh))
- names(tosend) <- names(scrollvh)
- for (n in names(scrollvh)) {
- data <- get(n, ev)
- nrowd <- nrow(data)
- ncold <- ncol(data)
- dscrollvh <- scrollvh[[n]]
- srow <- min(dscrollvh[1], nrowd - min(nrowd, x$visiblerows) + 1)
- scol <- min(dscrollvh[2], ncold - min(ncold, x$visiblecols) + 1)
- erow <- min(srow + x$visiblerows, nrowd)
- ecol <- min(scol + x$visiblecols, ncold)
- tosend[[n]] <- list(
- theData = unname(as.list(data[seq(srow, erow), seq(scol, ecol), drop = FALSE])),
- dataCoords = paste(srow, scol, erow, ecol, ncold, sep="_"),
- scrollvh = c(srow, scol) - 1
- )
- }
- return(jsonify(list(scrollData = tosend)))
- }
- `infobjs` <- function(objs, scrollvh) {
- funargs <- lapply(match.call(), deparse)
- type <- funargs$objs
- if (!identical(type, "added") & !identical(type, "modified")) {
- type <- "infobjs"
- }
- visiblerows <- ev$visiblerows
- visiblecols <- ev$visiblecols
- misscroll <- missing(scrollvh)
- toreturn <- list()
- objtype <- unlist(lapply(mget(objs, globalenv()), function(x) {
- if (is.data.frame(x)) {
- return(1)
- }
- else if (is(x, "tt")) {
- return(2)
- }
- else if (is(x, "qca")) {
- return(3)
- }
- return(0)
- }))
- if (any(objtype > 0)) {
- if (any(objtype == 1)) {
- toreturn$data <- lapply(names(objtype[objtype == 1]), function(n) {
- x <- globalenv()[[n]]
- dscrollvh <- c(1, 1)
- if (!misscroll) {
- if (is.element(n, names(scrollvh))) {
- dscrollvh <- scrollvh[[n]]
- }
- }
- nrowd <- nrow(x)
- ncold <- ncol(x)
- srow <- min(dscrollvh[1], nrowd - min(nrowd, visiblerows) + 1)
- scol <- min(dscrollvh[2], ncold - min(ncold, visiblecols) + 1)
- erow <- min(srow + visiblerows - 1, nrowd)
- ecol <- min(scol + visiblecols - 1, ncold)
- return(list(
- nrows = nrowd,
- ncols = ncold,
- rownames = rownames(x),
- colnames = colnames(x),
- numerics = as.vector(unlist(lapply(x, QCA::possibleNumeric))),
- calibrated = as.vector(unlist(lapply(x, function(x) {
- all(na.omit(x) >= 0 & na.omit(x) <= 1)
- }))),
- binary = as.vector(unlist(lapply(x, function(x) all(is.element(x, 0:1))))),
- scrollvh = c(srow, scol) - 1,
- theData = unname(as.list(x[seq(srow, erow), seq(scol, ecol), drop = FALSE])),
- dataCoords = paste(srow, scol, erow, ecol, ncol(x), sep = "_")
- ))
- })
- names(toreturn$data) <- names(objtype[objtype == 1])
- }
- if (any(objtype == 2)) {
- toreturn$tt <- lapply(mget(names(objtype[objtype == 2]), globalenv()), function(x) {
- components <- c("indexes", "noflevels", "cases", "options", "colnames", "numerics")
- x$indexes <- x$indexes - 1
- x$options$conditions <- toupper(x$options$conditions)
- cnds <- x$options$conditions
- if (x$options$use.letters) {
- cnds <- LETTERS[seq(length(cnds))]
- }
- x$options$outcome <- list(notilde(x$options$outcome))
- if (length(x$options$incl.cut) == 1) {
- x$options$incl.cut <- list(x$options$incl.cut)
- }
- if (length(cnds) <= 7) {
- x$id <- apply(x$tt[, cnds], 1, function(x) {
- ifelse(any(x == 1), paste(which(x == 1), collapse=""), "0")
- })
- components <- c(components, "id", "tt")
- }
- x$colnames <- colnames(x$initial.data)
- x$numerics <- as.vector(unlist(lapply(x$initial.data, QCA::possibleNumeric)))
- return(x[components])
- })
- }
- if (any(objtype == 3)) {
- toreturn$qmc <- lapply(mget(names(objtype[objtype == 3]), .GlobalEnv), function(x) {
- components <- c("indexes", "noflevels", "cases", "options")
- x <- x$tt
- x$options$conditions <- toupper(x$options$conditions)
- cnds <- x$options$conditions
- if (x$options$use.letters) {
- cnds <- LETTERS[seq(length(cnds))]
- }
- if (length(cnds) <= 7) {
- x$id <- apply(x$tt[, cnds], 1, function(x) {
- ifelse(any(x == 1), paste(which(x == 1), collapse=""), "0")
- })
- components <- c(components, "id", "tt")
- }
- x$indexes <- x$indexes - 1
- return(x[components])
- })
- }
- toreturn <- list(toreturn)
- names(toreturn) <- type
- return(jsonify(toreturn))
- }
- }
- `Changes` <- function(...) {
- changes <- gsub("`", "'", readLines(system.file("ChangeLog", package = "QCA")))
- return(jsonify(list(changes = changes)))
- }
- `packages` <- function(x) {
- attached <- data()$results[, -2]
- packages <- unique(attached[, "Package"])
- if (!identical(sort(packages), sort(x))) {
- attached <- lapply(packages, function(x) {
- x <- attached[attached[, "Package"] == x, 2:3, drop = FALSE]
- x <- x[x[, 2] != "Internal Functions", , drop = FALSE]
- if (nrow(x) == 0) return(list())
- titles <- as.list(x[, 2])
- names(titles) <- x[, 1]
- return(titles)
- })
- names(attached) <- packages
- return(jsonify(list(packages = attached)))
- }
- }
- `xyplot` <- function(...) {
- arglist <- list(...)
- if (is.element("dataset", names(arglist))) {
- xyplot_before <- fastdigest::fastdigest(get(arglist$dataset, globalenv())[, c(arglist$x, arglist$y), drop = FALSE])
- }
- }
- `calibration` <- function(...) {
- arglist <- list(...)
- if (is.element("dataset", names(arglist))) {
- hashcalib <- fastdigest::fastdigest(get(arglist$dataset, globalenv())[, arglist$x, drop = FALSE])
- if (arglist$thsetter) {
- recalibrate <- TRUE
- }
- }
- }
- `thinfo` <- function(...) {
- }
- `scrollvh` <- function(...) {
- }
- `editorSize` <- function(visiblerows, visiblecols) {
- ev$visiblerows <- visiblerows
- ev$visiblecols <- visiblecols
- }
- for (n in nms) {
- if (is.element(n, c("source", "options", "library"))) {
- do.call(n, commandlist[[n]])
- }
- else {
- result <- c(result, do.call(n, commandlist[[n]]))
- }
- }
- hashes <- hashobjs()
- added <- setdiff(names(hashes), names(ev$hashes))
- deleted <- setdiff(names(ev$hashes), names(hashes))
- common <- intersect(names(hashes), names(ev$hashes))
- modified <- names(ev$hashes)[!is.element(ev$hashes[common], hashes[common])]
- ev$hashes <- hashes
- if (length(added) > 0) result <- c(result, infobjs(added))
- if (length(modified) > 0) result <- c(result, infobjs(modified))
- if (length(deleted) > 0) result <- c(result, jsonify(list(deleted = deleted)))
- utils::savehistory(file = "temphistory")
- history <- readLines("temphistory")
- if (ev$firstHistory) {
- ev$firstHistory <- FALSE
- history[length(history) - 1] <- "library(QCA)"
- }
- writeLines(history[seq(length(history) - 1)], con = "temphistory")
- loadhistory(file = "temphistory")
- unlink(".temphistory")
- if (length(result) > 0) {
- cat("{", paste(result, collapse = ", "), "}")
- }
-}
Deleted: pkg/R/GUIcall.R
===================================================================
--- pkg/R/GUIcall.R 2020-10-30 19:06:13 UTC (rev 69)
+++ pkg/R/GUIcall.R 2020-10-30 19:25:25 UTC (rev 70)
@@ -1,57 +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.
-
-`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(... = ...)
- )
-}
Deleted: pkg/R/combinations.R
===================================================================
--- pkg/R/combinations.R 2020-10-30 19:06:13 UTC (rev 69)
+++ pkg/R/combinations.R 2020-10-30 19:25:25 UTC (rev 70)
@@ -1,89 +0,0 @@
-# Copyright (c) 2019, 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.
-
-combinations <- function (n, k, aloe = 0, zero = FALSE, inC = FALSE) {
- if (!is.numeric(k)) {
- cat("\n")
- stop(simpleError("Argument k should be numeric.\n\n"))
- }
- if (length(k) != 1L) {
- cat("\n")
- stop(simpleError("Argument k should be a scalar of length 1.\n\n"))
- }
- if (k < 0) {
- cat("\n")
- stop(simpleError("Argument k should be positive.\n\n"))
- }
- if (n < k) {
- cat("\n")
- stop(simpleError("Argument n should be greater than or equal to k.\n\n"))
- }
- n <- as.integer(n)
- k <- as.integer(k)
- zero <- as.integer(zero)
- if (inC) {
- .Call("C_combinations", list(n = n, k = k, aloe = aloe, zero = zero), PACKAGE = "QCA")
- }
- else {
- aloe <- as.integer(aloe)
- e <- 0L
- ncols <- as.integer(choose(n, k))
- h <- k - ncols == 1
- out <- vector(mode = "list", length = ncols)
- comb <- seq.int(k) - zero
- comb[k] <- comb[k] - 1L
- last <- n == k
- i <- 1
- while (comb[1] != n - k + 1 || last) {
- last <- FALSE
- if (e < n - h) {
- h <- 1L
- e <- comb[k] + zero
- comb[k] <- comb[k] + 1L
- if (comb[k] < aloe) {
- comb[k] <- aloe
- e <- aloe - 1
- }
- }
- else {
- e <- comb[k - h] + zero
- h <- h + 1L
- under <- logical(h)
- for (j in seq(h)) {
- under[j] <- (e + j - zero < aloe)
- comb[k - h + j] <- e + j - zero
- }
- if (all(under)) {
- comb[k] <- aloe
- e <- aloe - 1
- h <- 1L
- }
- }
- out[[i]] <- comb
- i <- i + 1
- }
- return(do.call("cbind", out[!unlist(lapply(out, is.null))]))
- }
-}
Deleted: pkg/R/compute.R
===================================================================
--- pkg/R/compute.R 2020-10-30 19:06:13 UTC (rev 69)
+++ pkg/R/compute.R 2020-10-30 19:25:25 UTC (rev 70)
@@ -1,107 +0,0 @@
-# Copyright (c) 2019, 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.
-
-`compute` <-
-function(expression = "", data = NULL, separate = FALSE) {
- expression <- gsub("[[:space:]]", "", expression)
- enchar <- nchar(expression)
- if (identical(substring(expression, 1, 2), "~(") & identical(substring(expression, enchar, enchar), ")")) {
- expression <- paste("1-", substring(expression, 3, enchar - 1), sep = "")
- }
- negated <- identical(unname(substring(expression, 1, 2)), "1-")
- expression <- gsub("1-", "", expression)
- if (is.null(data)) {
- syscalls <- parse(text = paste(unlist(lapply(sys.calls(), deparse)), collapse = "\n"))
- if (any(withdata <- grepl("with\\(", syscalls))) {
- withdata <- which(withdata)
- withdata <- withdata[length(withdata)]
- data <- get(unlist(strsplit(gsub("with\\(", "", syscalls[withdata]), split = ","))[1], envir = length(syscalls) - withdata)
- }
- else {
- colnms <- colnames(validateNames(notilde(expression), sort(toupper(eval.parent(parse(text = "ls()", n = 1))))))
- data <- vector(mode = "list", length = length(colnms))
- for (i in seq(length(data))) {
- data[[i]] <- eval.parent(parse(text = sprintf("get(\"%s\")", colnms[i]), n = 1))
- }
- if (length(unique(unlist(lapply(data, length)))) > 1) {
- cat("\n")
- stop(simpleError("Objects should be vectors of the same length.\n\n"))
- }
- names(data) <- colnms
- data <- as.data.frame(data)
- }
- }
- ppm <- translate(expression, data = data)
- pp <- attr(ppm, "retlist")
- retain <- apply(ppm, 2, function(x) any(x >= 0))
- pp <- lapply(pp, function(x) x[retain])
- ppm <- ppm[, retain, drop = FALSE]
- data <- data[, retain, drop = FALSE]
- colnames(data) <- toupper(colnames(data))
- infodata <- getInfo(cbind(data, YYYYY_YYYYY = 1), conditions = colnames(data))
- if (any(infodata$hastime)) {
- data <- infodata$data[, colnames(data), drop = FALSE]
- }
- verify.qca(data)
- tempList <- vector("list", length(pp))
- for (i in seq(length(pp))) {
- x <- which(ppm[i, ] >= 0)
- val <- pp[[i]][x]
- temp <- data[, colnames(ppm)[x], drop = FALSE]
- for (j in seq(length(val))) {
- if (!is.numeric(temp[, j]) & possibleNumeric(temp[, j])) {
- temp[, j] <- asNumeric(temp[, j])
- }
- if (any(abs(temp[, j] - round(temp[, j])) >= .Machine$double.eps^0.5)) {
- if (length(val[[j]]) > 1) {
- cat("\n")
- stop(simpleError("Multiple values specified for fuzzy data.\n\n"))
- }
- if (val[[j]] == 0) {
- temp[, j] <- 1 - temp[, j]
- }
- }
- else {
- temp[, j] <- as.numeric(is.element(temp[, j], val[[j]]))
- }
- }
- if (ncol(temp) > 1) {
- temp <- fuzzyand(temp)
- }
- tempList[[i]] <- temp
- }
- res <- as.data.frame(matrix(unlist(tempList), ncol = length(tempList)))
- colnames(res) <- rownames(ppm)
- if (ncol(res) > 1) {
- if (!separate) {
- res <- as.vector(fuzzyor(res))
- }
- }
- else {
- res <- as.vector(res[, 1])
- }
- if (negated) res <- 1 - res
- return(res)
-}
Deleted: pkg/R/export.R
===================================================================
--- pkg/R/export.R 2020-10-30 19:06:13 UTC (rev 69)
+++ pkg/R/export.R 2020-10-30 19:25:25 UTC (rev 70)
@@ -1,63 +0,0 @@
-# Copyright (c) 2019, 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.
-
-`export` <-
-function(x, file = "", ...) {
- export.args <- list(...)
- Call <- as.list(match.call(expand.dots = TRUE))[-1]
- caseid <- "cases"
- if (any(names(export.args) == "caseid")) {
- caseid <- export.args[["caseid"]]
- Call[["caseid"]] <- NULL
- }
- if (!missing(x)) {
- if (is.data.frame(x) | is.matrix(x)) {
- if (any(rownames(x) != seq(nrow(x)))) {
- if (all(colnames(x) != caseid)) {
- x <- cbind("cases" = rownames(x), x)
- names(x)[1] <- caseid
- }
- }
- }
- }
- Call[["x"]] <- x
- if (any(names(export.args) == "row.names")) {
- warning("The argument \"row.names\" is set to FALSE by default.", domain = NA)
- }
- if (any(names(export.args) == "sep")) {
- if (export.args[["sep"]] == "tab") {
- export.args[["sep"]] <- "\t"
- }
- Call[["sep"]] <- export.args[["sep"]]
- }
- else {
- Call[["sep"]] <- ","
- }
- if (any(names(export.args) == "col.names")) {
- Call[["col.names"]] <- export.args[["col.names"]]
- }
- Call[["row.names"]] <- FALSE
- do.call("write.table", Call)
-}
Deleted: pkg/R/factorize.R
===================================================================
--- pkg/R/factorize.R 2020-10-30 19:06:13 UTC (rev 69)
+++ pkg/R/factorize.R 2020-10-30 19:25:25 UTC (rev 70)
@@ -1,257 +0,0 @@
-# Copyright (c) 2019, 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.
-
-`factorize` <-
-function(input, snames = "", noflevels = NULL, pos = FALSE, use.tilde = FALSE, ...) {
- other.args <- list(...)
- if (any(names(other.args) == "tilde")) {
- use.tilde <- other.args$tilde
- }
- pasteit <- function(mat, comrows, cols, comvals) {
- if (!missing(cols)) {
- temp <- mat[comrows, -cols, drop = FALSE]
- if (mv) {
- cf <- paste(colnames(mat)[cols], "{", comvals, "}", sep = "")
- rowsf <- lapply(seq(nrow(temp)), function(x) {
- fname <- colnames(temp)
- x <- temp[x, ]
- return(paste(fname, "{", x, "}", sep = "")[x >= 0])
- })
- }
- else if (use.tilde) {
- cf <- paste(ifelse(comvals == 0, "~", ""), colnames(mat)[cols], sep = "")
- rowsf <- lapply(seq(nrow(temp)), function(x) {
- x <- temp[x, ]
- return(paste(ifelse(x == 0, "~", ""), names(x), sep = "")[x >= 0])
- })
- }
- else {
- for (i in seq(length(cols))) {
- if (comvals[i] == 0) {
- colnames(mat)[cols[i]] <- tolower(colnames(mat)[cols[i]])
- }
- }
- cf <- colnames(mat)[cols]
- rowsf <- lapply(seq(nrow(temp)), function(x) {
- x <- temp[x, ]
- nms <- names(x)
- nms[x == 0] <- tolower(nms[x == 0])
- return(nms[x >= 0])
- })
- }
- trowsf <- table(unlist(rowsf))
- if (any(trowsf == length(rowsf))) {
- c2 <- names(trowsf)[trowsf == length(rowsf)]
- cf <- c(cf, c2[c2 != ""])
- rowsf <- lapply(rowsf, setdiff, c2)
- }
- rowsf1 <- rowsf[rowsf != ""]
- rowsf[rowsf != ""] <- rowsf1[order(match(toupper(gsub("[^A-Za-z]", "", rowsf1)), snames))]
- rowsf <- sapply(rowsf, paste, collapse = collapse)
- rowsf <- unique(setdiff(rowsf, ""))
- if (all(nchar(unique(rowsf)) == 1)) {
- tblchar <- table(toupper(rowsf))
- if (any(tblchar > 1)) {
- for (ch in names(tblchar)[tblchar > 1]) {
- rowsf <- rowsf[-which(toupper(rowsf) == ch)]
- }
- }
- }
- rowsf <- paste(rowsf, collapse = " + ")
- cf <- paste(cf[order(match(toupper(gsub("[^A-Za-z]", "", cf)), snames))], collapse = collapse)
- pasted <- paste(cf, rowsf, sep="@")
- }
- else {
- if (mv) {
- pasted <- paste(sapply(seq(nrow(mat)), function(x) {
- x <- mat[x, ]
- paste(paste(names(x), "{", x, "}", sep = "")[x >= 0], collapse = collapse)
- }), collapse = " + ")
- }
- else if (use.tilde) {
- pasted <- paste(sapply(seq(nrow(mat)), function(x) {
- colns <- colnames(mat)
- colns[mat[x, ] == 0] <- paste("~", colns[mat[x, ] == 0], sep="")
- paste(colns[mat[x, ] >= 0], collapse = collapse)
- }), collapse = " + ")
- }
- else {
- pasted <- paste(sapply(seq(nrow(mat)), function(x) {
- colns <- colnames(mat)
- colns[mat[x, ] == 0] <- tolower(colns[mat[x, ] == 0])
- paste(colns[mat[x, ] >= 0], collapse = collapse)
- }), collapse = " + ")
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/qca -r 70
More information about the Qca-commits
mailing list