admisc/0000755000176200001440000000000015161417511011514 5ustar liggesusersadmisc/MD50000644000176200001440000001216015161417511012024 0ustar liggesusers59b17b2a2be4e819148cd7a07292cc63 *DESCRIPTION 52ba1f1119b9f47a77d9361d143582d0 *NAMESPACE f8fbd9c16f6aa09404a8622ddb7d4e28 *R/SOPexpression.R a5d6043de9a43a6c4d424fe9847ff8ff *R/admisc_internal.R 785305d03b515ecd613c16f0dfd8abce *R/admisc_package.R 777328ae31d8a3ea872eb8feb04aa522 *R/asNumeric.R ecdd319cb751fe3562fdb12a8a488012 *R/asSOP.R e2805004b5b3cb611b68a9eb5e297c91 *R/betweenQuotes.R 403fda33091e524418899bb0b2b3f563 *R/brackets.R cfc38238f435386f01044130e0805897 *R/change.R 0d18d701db18edd9fef3097e5727c37c *R/checkMV.R 3c8a859504514ac0f6aee5b572ea8d52 *R/checkSubset.R e57ba4ac33a83f60912fa27fe6c377f3 *R/checkValid.R 3942d10b728b3cf82c40f85719de4de7 *R/classify.R 75ae707e4cb1264fd436545307d5e50c *R/coerceMode.R 8fe7d515db47680cd0ad3316d06770cf *R/combnk.R e370f5be5e72b6cbb4724c5bcb571cc9 *R/compute.R 6d7375bc46dd5ecbcb7c3b087e43c556 *R/dimnames.R 5f83f827361a44a9de8d995838b0bfa7 *R/equality.R be964d9490bdff7de287379308a084db *R/expand.R 9b7c59eefb24f39c7d4368d69fc75c21 *R/export.R 79564b8f089e0bdcc913373ba8b81757 *R/factorize.R a89bae7409e44e83dd074e9994b54c5e *R/frelevel.R 5eb44c1147838e3a4b72cd709411708c *R/frev.R 4230f90d445fe807cea1bcb63910fe00 *R/getInfo.R 41d6a5f69e11a90eb378240bb2e30126 *R/getLevels.R 2f57f275f47e7a5857b43f32e5a4715b *R/getMatrix.R 736698a826b909b5a3dbc01cc7b1ddd5 *R/getName.R 3b50f7b4e64aadfc4272a18d50ab2730 *R/hclr.R dece34a6bb9efdcb071655da7cad6cfd *R/inside.R 90f882fef53690ea419181856b65c602 *R/intersection.R 81209f24b161bbb0c1663d9b7499e151 *R/invert.R 2f59dded27bfb23a53d49d52326107a6 *R/listRDA.R 7fb23932a97dbaf35167050d3aa2baa2 *R/mvSOP.R b6ccb3e48d8d45a46d9cc664460effb8 *R/numdec.R 016b98a7071273c1f2daa5530610a9a8 *R/objRDA.R 44006a2a71a9bf8b3fcd21358a4851fb *R/onLoad.R affbc0bde298d4aca328c5fa1264bd18 *R/overwrite.R acf4a11eb579eb5823e79ea6ad308499 *R/pad.R 27f7cb0b6914e9ad992ebcc54fe63e84 *R/permutations.R 88702bdc1f5ca5db5ddb85b828f1194e *R/possibleNumeric.R fc4e7ca88d4a2578d3198b333ad28b79 *R/prettyString.R 7d0365168f5c957f531d2261e9ae8a8b *R/prettyTable.R 98c7b4886d9a18c4ace9b94ad5d862a9 *R/print.R 7d8ca5df74a2b72da375b1bf3663e6ee *R/recode.R 7e5bfbcaca932b79c0d2eda81da83b99 *R/recreate.R 635988544cf40adde72927908d42a9c9 *R/reload.R 25b77b213f99dc46a3fbe81055ad784b *R/replaceText.R d0e1bd1a65160e76828a2314fde90d31 *R/scan.clipboard.R adfd55a929aad461c2da55a56eae0e40 *R/simplify.R 8c627fbdba88ff092b0d74ab87e4ccc3 *R/sopos.R e53abbb705ba141d396ddbb7721dddd2 *R/sortExpressions.R 4b28cdb60996fac13da08dbb33cc94ca *R/stopError.R f66f134f016ede2f9ce2b99b11ee6dca *R/string.R a4e904bcb41691d48de78355fca7a246 *R/tagged.R 2ed8a64e39de9e69c49e3d3654f04ccd *R/tilde.R d70b9629401606eac573ead140cbefa6 *R/translate.R 63a19bec9906f4b2a4b932a854111790 *R/tryCatchWEM.R bcabe0aad750eda6b74c20300fb96b6a *R/unicode.R 9bf9537d733e13ec946eb6c4cbe2d371 *R/uninstall.R ffe723b617340ec8b09874f599f04eb4 *R/unload.R 3cc58c47448e8ac568aef8f5dce75fe3 *R/update.R 288e5b932f7385565db9eba10731b942 *R/using.R 1bacda9b84d0700ad0f01f73f0adfc7a *R/validateNames.R a00b5977a5ab2ee4d0a754073c3b8c02 *R/verify.R a4247f4cc4b41e7fc2e726375955c603 *R/wholeNumeric.R 33a021c691a705b080bdcc7016c598e1 *R/write.clipboard.R 5dec10fa1722a45c225e11f7ad9636f1 *R/writePIs.R f51ba7c8bc94d8cf1fd072b85c6e53ab *build/partial.rdb 08d6f61452a13ca961ce6b08540fe95d *inst/ChangeLog 70889051302c91c7a84f11257eec19f2 *man/SOPexpression.Rd 4cddb074639a6c6ea19ac03e37d70f0b *man/admisc_internal.Rd f6e2c73d97f54c79a5f29de0dd558130 *man/admisc_package.Rd a0f01039778b0c656b6e04a516e25651 *man/betweenQuotes.Rd c745464ae7beee899be60b30f3b96c1d *man/brackets.Rd 3c16af201f59a6bb7fef0d59786e973c *man/change.Rd 07ba5973faf4d42177f4aff0662c86c4 *man/clipboard.Rd 466d079607379c39380ea6fc793889d6 *man/coerceMode.Rd ed9e68ec22ca87de11af42f916c3c75c *man/combnk.Rd 606ae0a734c2930ef1c5baed80cc72e6 *man/dimnames.Rd 2234ae67e0400fbe66061c74e38166af *man/equality.Rd a587ac995dbc900d9db5fea6ddd6db08 *man/export.Rd d4993d36a132ac5b633b549fbc090bd5 *man/factorize.Rd b9d15613a8008c6000c79015b30639e1 *man/frelevel.Rd 1e9097d275108f0ba76a03906d266cd1 *man/frev.Rd 6e5dd7dac4c10f79ae1e11f792bdd38d *man/getName.Rd fc463d6ba5e81e808579d979efa5555e *man/hclr.Rd d9bcb89e287d77fea55888613f21cc5e *man/inside.Rd 2ad78f2b5ad82972fbadbc5b743346e5 *man/intersection.Rd 8c2d2848e00f26ddbaf3abfcef776a95 *man/invert.Rd 1f2484aea05701536b0d0c4fb500a283 *man/numdec.Rd bd57a1d00be39a9647232b4c2a2e0219 *man/numerics.Rd a00ab2b59907271c1de9b6312ba16e00 *man/overwrite.Rd f138032d425cf562c8a2f095b391013e *man/permutations.Rd 14ac8f9d957a43d53c3f35edd9dab9a6 *man/rdaFunctions.Rd 83fabfee112f1d77e3cf887a95d97e7e *man/recode.Rd f15e3fd97fac5b92ea2a73549ddb10e1 *man/recreate.Rd 8173fa17c21acbbcec224bd8bdc9c7b9 *man/replaceText.Rd 2345fa136a73a13443e1901770085aaa *man/tilde.Rd 39cf6b4a7a9c9ddf79d86537734d6f55 *man/tryCatchWEM.Rd 52162cc6623d124c5a3c08c8a8a3a97b *man/using.Rd 95e3011e37d9dde0d75f3a3819b2acd3 *src/Makevars 7b7db75ba8510b42ea6826fb8d323a4a *src/Makevars.win fe89116bbe4d5d17c4815f7bab86e7c7 *src/admisc.c bddd9d89de5feaf66ccbb62e6a6a2af9 *src/admisc.h c5acd23a77d5cdb57861b64395d37c31 *src/registerDynamicSymbol.c 8b251e8791a8afe55b8d5e8758d3ad59 *src/utils.c c723bd927feb4a596caaeb9d0741b4e8 *src/utils.h admisc/R/0000755000176200001440000000000015161273642011722 5ustar liggesusersadmisc/R/using.R0000644000176200001440000003152415161273642013177 0ustar liggesusers# Copyright (c) 2019 - 2026, 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. #' Evaluate an expression in a data environment #' #' A function almost identical to the base function \code{with()}, but allowing #' to evaluate the expression in every subset of a split file. #' #' @name using #' @rdname using #' @aliases using.data.frame #' @rawRd #' \usage{ #' using(data, expr, split.by = NULL, ...) #' } #' #' \arguments{ #' \item{data}{A data frame.} #' \item{expr}{Expression to evaluate} #' \item{split.by}{A factor variable from the \code{data}, or a \code{declared}/\code{labelled} variable} #' \item{...}{Other internal arguments.} #' } #' #' \value{ #' A list of results, or a matrix if each separate result is a vector. #' } #' #' #' \author{ #' Adrian Dusa #' } #' #' \examples{ #' set.seed(123) #' DF <- data.frame( #' Area = factor(sample(c("Rural", "Urban"), 123, replace = TRUE)), #' Gender = factor(sample(c("Female", "Male"), 123, replace = TRUE)), #' Age = sample(18:90, 123, replace = TRUE), #' Children = sample(0:5, 123, replace = TRUE) #' ) #' #' #' # table of frequencies for Gender #' table(DF$Gender) #' #' # same with #' using(DF, table(Gender)) #' #' # same, but split by Area #' using(DF, table(Gender), split.by = Area) #' #' # calculate the mean age by gender #' using(DF, mean(Age), split.by = Gender) #' #' # same, but select cases from the urban area #' using(subset(DF, Area == "Urban"), mean(Age), split.by = Gender) #' #' # mean age by gender and area #' using(DF, mean(Age), split.by = Area & Gender) #' #' # same with #' using(DF, mean(Age), split.by = c(Area, Gender)) #' #' # average number of children by Area #' using(DF, mean(Children), split.by = Area) #' #' # frequency tables by Area #' using(DF, table(Children), split.by = Area) #' } #' #' \keyword{functions} NULL #' @export `using` <- function(data, expr, split.by = NULL, ...) { UseMethod("using") } #' @export `using.default` <- function(data, expr, ...) { if (missing(expr)) { args <- unlist(lapply(match.call(), deparse)[-1]) args <- args[setdiff(names(args), c("data", "expr"))] if (length(args) > 1) { stopError("Missing or ambiguous expression") } expr <- str2lang(paste(names(args), args[[1]], sep = "<-")) } visible <- TRUE result <- NULL test <- tryCatchWEM({ tmp <- withVisible( eval(substitute(expr), envir = data, enclos = parent.frame()) ) visible <- tmp$visible result <- tmp$value }) if (is.null(test$error)) { if (visible) { return(result) } return(invisible(result)) } stopError(test$error) } #' @export `using.matrix` <- function(data, expr, split.by = NULL, ...) { if (missing(expr)) { args <- unlist(lapply(match.call(), deparse)[-1]) args <- args[setdiff(names(args), c("data", "expr"))] if (length(args) > 1) { stopError("Missing or ambiguous expression") } expr <- str2lang(paste(names(args), args[[1]], sep = "<-")) } expr <- substitute(expr) return( using(as.data.frame(data), expr, split.by = split.by, ... = ...) ) } #' @export `using.data.frame` <- function(data, expr = expr, split.by = NULL, ...) { if (nrow(data) == 0) { stopError("There are no rows in the data.") } test <- substitute(split.by) split.by <- NULL if (!identical(as.character(test), "split.by")) { split.by <- test } sby <- all.vars(split.by) nsby <- all.names(split.by) if (missing(expr)) { args <- unlist(lapply(match.call(), deparse)[-1]) args <- args[setdiff(names(args), c("data", "expr", "split.by"))] if (length(args) > 1) { stopError("Missing or ambiguous expression") } expr <- str2lang(paste(names(args), args[[1]], sep = "<-")) } test <- substitute(expr) if (!identical(as.character(test), "expr")) { expr <- test } vexpr <- all.vars(expr) if (any(vexpr == ".")) { vexpr <- colnames(data) } else { vexpr <- vexpr[is.element(vexpr, colnames(data))] } if (length(sby) == 0) { visible <- TRUE result <- NULL test <- tryCatchWEM({ tmp <- withVisible( eval(expr, envir = data, enclos = parent.frame()) ) visible <- tmp$visible result <- tmp$value }) if (is.null(test$error)) { if (visible) { return(result) } return(invisible(result)) } stopError(gsub("object", "column", test$error)) } nms <- names(data) existing <- sapply(sby, function(x) { is.element(x, nms) || exists(x, envir = parent.frame(), inherits = TRUE) }) if (any(!existing)) { stopError("Split by variables do not exist in the data.") } sbylist <- lapply( lapply(sby, function(x) { eval(parse(text = x), envir = data, enclos = parent.frame()) }), function(x) { if (inherits(x, "declared") || inherits(x, "haven_labelled")) { labels <- attr(x, "labels", exact = TRUE) na_values <- attr(x, "na_values") na_range <- attr(x, "na_range") if (!is.null(na_range)) { if (length(na_range) > 2) { stopError("Split by variable has a missing range with more than two values.") } na_values <- sort(union( na_values, seq(na_range[1], na_range[2]) )) } if (inherits(x, "haven_labelled")) { x[is.element(x), na_values] <- NA } uniques <- sort( setdiff( c(undeclareit(x, drop = TRUE), labels), na_values ) ) names(uniques) <- uniques labels <- labels[is.element(labels, uniques)] names(uniques)[match(labels, uniques)] <- names(labels) attributes(x) <- NULL return(factor(x, levels = uniques, labels = names(uniques))) } return(as.factor(x)) } ) names(sbylist) <- sby test <- table(sapply(sbylist, length)) if (length(test) > 1 || nrow(data) != as.numeric(names(test))) { stopError("Split variables do not match the number of rows in the data.") } sl <- lapply(sbylist, function(x) levels(x)) names(sl) <- sby noflevels <- unlist(lapply(sl, length)) mbase <- c(rev(cumprod(rev(noflevels))), 1)[-1] orep <- cumprod( rev( c(rev(noflevels)[-1], 1) ) ) retmat <- sapply(seq_len(length(sl)), function(x) { rep.int( rep.int( seq_len(noflevels[x]), rep.int(mbase[x], noflevels[x]) ), orep[x] ) }) slexp <- retmat for (i in seq(length(sl))) { slexp[, i] <- sl[[i]][retmat[, i]] } data <- data[, vexpr, drop = FALSE] res <- vector(mode = "list", length = nrow(slexp)) visible <- TRUE for (r in seq(nrow(slexp))) { selection <- rep(TRUE, nrow(data)) for (c in seq(ncol(slexp))) { val <- slexp[r, c] x <- sbylist[[c]] attrx <- attributes(x) if (inherits(x, "declared") | inherits(x, "haven_labelled_spss")) { attributes(x) <- NULL na_index <- attrx[["na_index"]] if (!is.null(na_index)) { nms <- names(na_index) x[na_index] <- nms } labels <- attrx[["labels"]] if (!is.null(labels)) { havelabels <- is.element(x, labels) x[havelabels] <- names(labels)[match(x[havelabels], labels)] } } selection <- selection & (x == val) } if (sum(selection, na.rm = TRUE) > 0) { tmp <- withVisible( eval( expr = expr, envir = subset(data, selection), enclos = parent.frame() ) ) visible <- tmp$visible res[[r]] <- tmp$value } } empty <- sapply(res, is.null) res <- res[!empty] any_wtable <- any( sapply(res, function(x) class(x)[1] == "wtable" | class(x)[1] == "w_table") ) slexp <- slexp[!empty, ] if (all(sapply(res, is.atomic)) & !any_wtable) { classes <- unique(unlist(lapply(res, class))) classes <- setdiff(classes, c("integer", "double", "character", "numeric", "complex")) lengths <- sapply(res, length) result <- matrix(NA, nrow = length(res), ncol = max(lengths)) for (i in seq(length(res))) { if (!is.null(res[[i]])) { result[i, seq(length(res[[i]]))] <- res[[i]] } } result[] <- coerceMode(round(result, 3)) if (is.matrix(slexp)) { rownames(result) <- apply(slexp, 1, function(x) paste(x, collapse = ",")) } else { rownames(result) <- slexp } expr <- as.list(expr) if (max(lengths) == 1) { colnames(result) <- as.character(expr[[1]]) } else { if (as.character(expr[1]) == "c") { expr <- expr[-1] } cexpr <- sapply(expr, as.character) if (is.matrix(cexpr) && nrow(cexpr) == 2) { if (length(unique(cexpr[1, ])) == 1) { cexpr <- cexpr[2, ] } else if (length(unique(cexpr[2, ])) == 1) { cexpr <- cexpr[1, ] } } nms <- names(res[[which.max(lengths)]]) if (is.null(nms)) { if (max(lengths) == length(expr) && !is.element("table", expr)) { if (max(lengths) == length(cexpr)) { nms <- cexpr } else { nms <- sapply(expr, deparse) } } else { nms <- rep(" ", max(lengths)) } } if ( any(nms == "") && is.element("summary", cexpr) && sum(nms == "") == length(expr) - 1 ) { nms[nms == ""] <- setdiff(cexpr, "summary") } colnames(result) <- nms } res <- result class(res) <- c("admisc_fobject", "matrix") } else { attr(res, "split") <- slexp class(res) <- c("admisc_fobject", class(res)) } if (visible) { return(res) } return(invisible(res)) } #' @export `[.admisc_fobject` <- function(x, i, j, drop = FALSE, ...) { class(x) <- setdiff(class(x), "admisc_fobject") if (is.matrix(x)) { dims <- dimnames(x) if (!is.null(dims)) { if (!is.null(dims[[1]]) && !missing(i) && !is.null(i)) { dims[[1]] <- dims[[1]][i] } if (!is.null(dims[[2]]) && !missing(j) && !is.null(j)) { dims[[2]] <- dims[[2]][j] } } x <- NextMethod() x <- as.matrix(x) dimnames(x) <- dims } else { x <- NextMethod() } class(x) <- c("admisc_fobject", class(x)) return(x) } admisc/R/invert.R0000644000176200001440000002473515161273642013367 0ustar liggesusers# Copyright (c) 2019 - 2026, 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. #' Negate Boolean expressions #' #' Functions to negate a DNF/SOP expression, or to invert a SOP to a negated POS or #' a POS to a negated SOP. #' #' @name invert #' @rdname invert #' @aliases negate #' @aliases sopos #' @aliases deMorgan #' @rawRd #' \usage{ #' invert(input, snames = "", noflevels, simplify = TRUE, ...) #' #' sopos(input, snames = "", noflevels) #' } #' #' \arguments{ #' \item{input}{A string representing a SOP expression, or a minimization #' object of class \code{"QCA_min"}.} #' \item{snames}{A string containing the sets' names, separated by commas.} #' \item{noflevels}{Numerical vector containing the number of levels for each set.} #' \item{simplify}{Logical, allow users to choose between the raw negation or #' its simplest form.} #' \item{...}{Other arguments (mainly for backwards compatibility).} #' } #' #' \details{ #' #' In Boolean algebra, there are two transformation rules named after the British #' mathematician Augustus De Morgan. These rules state that: #' #' 1. The complement of the union of two sets is the intersection of their complements. #' #' 2. The complement of the intersection of two sets is the union of their complements. #' #' In "normal" language, these would be written as: #' #' 1. \code{not (A and B) = (not A) or (not B)} #' #' 2. \code{not (A or B) = (not A) and (not B)} #' #' Based on these two laws, any Boolean expression written in disjunctive normal #' form can be transformed into its negation. #' #' It is also possible to negate all models and solutions from the result of a #' Boolean minimization from function \bold{\code{\link[QCA]{minimize}()}} in #' package \bold{\code{QCA}}. The resulting object, of class \code{"qca"}, is #' automatically recognised by this function. #' #' In a SOP expression, the products should normally be split by using a star #' \bold{\code{*}} sign, otherwise the sets' names will be considered the individual #' letters in alphabetical order, unless they are specified via \bold{\code{snames}}. #' #' To negate multilevel expressions, the argument \bold{\code{noflevels}} is required. #' #' It is entirely possible to obtain multiple negations of a single expression, since #' the result of the negation is passed to function \bold{\code{\link{simplify}()}}. #' #' Function \bold{\code{sopos}()} simply transforms an expression from a sum of #' products (SOP) to a negated product of sums (POS), and the other way round. #' } #' #' \value{ #' A character vector when the input is a SOP expresison, or a named list for #' minimization input objects, each component containing all possible negations of #' the model(s). #' } #' #' \author{ #' Adrian Dusa #' } #' #' \references{ #' Ragin, Charles C. 1987. \emph{The Comparative Method: Moving beyond Qualitative #' and Quantitative Strategies}. Berkeley: University of California Press. #' } #' #' \seealso{\code{\link[QCA]{minimize}}, \code{\link{simplify}}} #' #' \examples{ #' #' # example from Ragin (1987, p.99) #' invert(AC + B~C, simplify = FALSE) #' #' # the simplified, logically equivalent negation #' invert(AC + B~C) #' #' # with different intersection operators #' invert(AB*EF + ~CD*EF) #' #' # invert to POS #' invert(a*b + ~c*d) #' #' \dontrun{ #' # using an object of class "qca" produced with minimize() #' # from package QCA #' library(QCA) #' cLC <- minimize(LC, outcome = SURV) #' #' invert(cLC) #' #' #' # parsimonious solution #' pLC <- minimize(LC, outcome = SURV, include = "?") #' #' invert(pLC) #' } #' } #' #' \keyword{functions} NULL #' @export `invert` <- function(input, snames = "", noflevels = NULL, simplify = TRUE, ...) { input <- recreate(substitute(input)) snames <- recreate(substitute(snames)) dots <- list(...) scollapse <- ifelse( is.element("scollapse", names(dots)), dots$scollapse, FALSE ) if (!is.null(noflevels)) { if (is.character(noflevels)) { noflevels <- splitstr(noflevels) if (possibleNumeric(noflevels)) { noflevels <- asNumeric(noflevels) } else { stopError("Invalid number of levels.") } } } isol <- NULL minimized <- methods::is(input, "QCA_min") if (minimized) { snames <- input$tt$options$conditions star <- any(nchar(snames) > 1) if (input$options$use.letters) { snames <- LETTERS[seq(length(snames))] star <- FALSE } noflevels <- input$tt$noflevels if (is.element("i.sol", names(input))) { elengths <- unlist(lapply(input$i.sol, function(x) length(x$solution))) isol <- paste(rep(names(input$i.sol), each = elengths), unlist(lapply(elengths, seq)), sep = "-") input <- unlist(lapply(input$i.sol, function(x) { lapply(x$solution, paste, collapse = " + ") })) } else { input <- unlist(lapply(input$solution, paste, collapse = " + ")) } if (!star) { input <- gsub("[*]", "", input) } } if (methods::is(input, "admisc_deMorgan")) { input <- unlist(input) } if (!is.character(input)) { stopError("The expression should be a character vector.") } star <- any(grepl("[*]", input)) if (!identical(snames, "")) { snames <- splitstr(snames) if (any(nchar(snames) > 1)) { star <- TRUE } } multivalue <- any(grepl("\\[|\\]|\\{|\\}", input)) if (multivalue) { start <- FALSE if (is.null(noflevels) | identical(snames, "")) { stopError( paste( "Set names and their number of levels are required", "to negate multivalue expressions." ) ) } } scollapse <- scollapse | any(nchar(snames) > 1) | multivalue | star collapse <- ifelse(scollapse, "*", "") negateit <- function( x, snames = "", noflevels = NULL, simplify = TRUE, collapse = "*" ) { callist <- list(expression = x) callist$snames <- snames if (!is.null(noflevels)) callist$noflevels <- noflevels trexp <- do.call(translate, callist) snames <- colnames(trexp) if (is.null(noflevels)) { noflevels <- rep(2, ncol(trexp)) } snoflevels <- lapply(noflevels, function(x) seq(x) - 1) sr <- nrow(trexp) == 1 trcols <- apply(trexp, 2, function(x) any(x != "-1")) negated <- paste( apply(trexp, 1, function(x) { wx <- which(x != -1) x <- x[wx] nms <- names(x) x <- sapply(seq_along(x), function(i) { paste( setdiff(snoflevels[wx][[i]], splitstr(x[i])), collapse = "," ) }) if (multivalue) { return(paste( ifelse(sr | length(wx) == 1, "", "("), paste( nms, "[", x, "]", sep = "", collapse = " + " ), ifelse(sr | length(wx) == 1, "", ")"), sep = "" )) } else { nms[x == 0] <- paste0("~", nms[x == 0]) return(paste( ifelse(sr | length(wx) == 1, "", "("), paste(nms, collapse = " + ", sep = ""), ifelse(sr | length(wx) == 1, "", ")"), sep = "")) } }), collapse = collapse ) negated <- expandBrackets( negated, snames = snames, noflevels = noflevels, scollapse = scollapse ) if (simplify) { callist$expression <- negated callist$scollapse <- identical(collapse, "*") callist$snames <- snames[trcols] if (!is.null(noflevels)) { callist$noflevels <- noflevels[trcols] } return(unclass(do.call("simplify", callist))) } return(negated) } result <- lapply( input, negateit, snames = snames, noflevels = noflevels, simplify = simplify, collapse = collapse ) if (any(unlist(lapply(result, length)) == 0)) { return(invisible(character(0))) } names(result) <- unname(input) if (!minimized) { attr(result, "expressions") <- input } if (!identical(snames, "")) { attr(result, "snames") <- snames } if (!is.null(isol)) { attr(result, "isol") <- isol } attr(result, "minimized") <- minimized return(classify(result, "admisc_deMorgan")) } #' @export `deMorgan` <- function(...) { .Deprecated(msg = "Function deMorgan() is deprecated. Use function invert() instead.\n") negate(...) } #' @export `negate` <- function(...) { invert(...) } admisc/R/equality.R0000644000176200001440000001544315161273642013711 0ustar liggesusers# Copyright (c) 2019 - 2026, 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. #' Check difference and / or (in)equality of numbers #' #' Check if one number is greater / lower than (or equal to) another. #' #' @name agtb #' @rdname equality #' @aliases altb #' @aliases agteb #' @aliases alteb #' @aliases aeqb #' @aliases aneqb #' @rawRd #' \usage{ #' agtb(a, b, bincat) #' altb(a, b, bincat) #' agteb(a, b, bincat) #' alteb(a, b, bincat) #' aeqb(a, b, bincat) #' aneqb(a, b, bincat) #' } #' #' \arguments{ #' \item{a}{Numerical vector} #' \item{b}{Numerical vector} #' \item{bincat}{Binary categorization values, an atomic vector of length 2} #' } #' #' \details{ #' Not all numbers (especially the decimal ones) can be represented exactly in #' floating point arithmetic, and their arithmetic may not give the normal expected #' result. #' #' This set of functions check for the in(equality) between two numerical vectors a #' and b, with the following name convention: #' #' \bold{\code{gt}} means \dQuote{greater than} #' #' \bold{\code{lt}} means a \dQuote{lower than} b #' #' \bold{\code{gte}} means a \dQuote{greater than or equal to} b #' #' \bold{\code{lte}} means a \dQuote{lower than or equal to} b #' #' \bold{\code{eq}} means a \dQuote{equal to} b #' #' \bold{\code{neq}} means a \dQuote{not equal to} b #' #' The argument \bold{\code{values}} is useful to replace the TRUE / FALSE values #' with custom categories. #' } #' #' \author{ #' Adrian Dusa #' } #' #' #' \references{ #' Goldberg, David (1991) "What Every Computer Scientist Should Know About #' Floating-point Arithmetic", ACM Computing Surveys vol.23, no.1, pp.5-48, #' \doi{10.1145/103162.103163} #' } #' #' #' \keyword{functions} NULL `undeclareit` <- function(x, drop = FALSE, ...) { na_index <- attr(x, "na_index") attrx <- attributes(x) attributes(x) <- NULL if (!is.null(na_index)) { x[na_index] <- names(na_index) } x <- coerceMode(x) attrx$na_index <- NULL attrx$na_values <- NULL attrx$na_range <- NULL if (isFALSE(drop)) { attributes (x) <- attrx } return(x) } #' @export `agtb` <- function(a, b, bincat) { if (inherits(a, "declared")) a <- undeclareit(a) if (inherits(b, "declared")) b <- undeclareit(b) tol <- getOption("admisc.tol") result <- (a - tol) > b if (!missing(bincat)) { if (!is.atomic(bincat) || length(bincat) != 2) { stopError( "The argument 'bincat' should be an atomic vector of length 2" ) } false <- !result result[result] <- bincat[1] result[false] <- bincat[2] } return(coerceMode(result)) } #' @export `altb` <- function(a, b, bincat) { if (inherits(a, "declared")) a <- undeclareit(a) if (inherits(b, "declared")) b <- undeclareit(b) tol <- getOption("admisc.tol") result <- a < (b - tol) if (!missing(bincat)) { if (!is.atomic(bincat) || length(bincat) != 2) { stopError( "The argument 'bincat' should be an atomic vector of length 2" ) } false <- !result result[result] <- bincat[1] result[false] <- bincat[2] } return(coerceMode(result)) } #' @export `agteb` <- function(a, b, bincat) { if (inherits(a, "declared")) a <- undeclareit(a) if (inherits(b, "declared")) b <- undeclareit(b) tol <- getOption("admisc.tol") result <- (a + tol) > b if (!missing(bincat)) { if (!is.atomic(bincat) || length(bincat) != 2) { stopError( "The argument 'bincat' should be an atomic vector of length 2" ) } false <- !result result[result] <- bincat[1] result[false] <- bincat[2] } return(coerceMode(result)) } #' @export `alteb` <- function(a, b, bincat) { if (inherits(a, "declared")) a <- undeclareit(a) if (inherits(b, "declared")) b <- undeclareit(b) tol <- getOption("admisc.tol") result <- a < (b + tol) if (!missing(bincat)) { if (!is.atomic(bincat) || length(bincat) != 2) { stopError( "The argument 'bincat' should be an atomic vector of length 2" ) } false <- !result result[result] <- bincat[1] result[false] <- bincat[2] } return(coerceMode(result)) } #' @export `aeqb` <- function(a, b, bincat) { if (inherits(a, "declared")) a <- undeclareit(a) if (inherits(b, "declared")) b <- undeclareit(b) tol <- getOption("admisc.tol") result <- abs(a - b) < tol if (!missing(bincat)) { if (!is.atomic(bincat) || length(bincat) != 2) { stopError( "The argument 'bincat' should be an atomic vector of length 2" ) } false <- !result result[result] <- bincat[1] result[false] <- bincat[2] } return(coerceMode(result)) } #' @export `aneqb` <- function(a, b, bincat) { if (inherits(a, "declared")) a <- undeclareit(a) if (inherits(b, "declared")) b <- undeclareit(b) tol <- getOption("admisc.tol") result <- abs(a - b) > tol if (!missing(bincat)) { if (!is.atomic(bincat) || length(bincat) != 2) { stopError( "The argument 'bincat' should be an atomic vector of length 2" ) } false <- !result result[result] <- bincat[1] result[false] <- bincat[2] } return(coerceMode(result)) } admisc/R/asNumeric.R0000644000176200001440000001164715161273642014004 0ustar liggesusers# Copyright (c) 2019 - 2026, 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. #' Numeric vectors #' #' Coerces objects to class "numeric", and checks if an object is numeric. #' #' @name asNumeric #' @rdname numerics #' @aliases possibleNumeric #' @aliases wholeNumeric #' @rawRd #' \usage{ #' asNumeric(x, ...) #' possibleNumeric(x, each = FALSE) #' wholeNumeric(x, each = FALSE) #' } #' #' \arguments{ #' \item{x}{A vector of values} #' \item{each}{Logical, return the result for each value in the vector} #' \item{...}{Other arguments to be passed for class based methods} #' } #' #' #' \details{ #' Unlike the function \bold{\code{as.numeric}()} from the \bold{\pkg{base}} #' package, the function \bold{\code{asNumeric()}} coerces to numeric without a #' warning if any values are not numeric. All such values are considered NA missing. #' #' This is a generic function, with specific class methods for factors and objects #' of class \dQuote{declared}. The usual way of coercing factors to numeric is #' meaningless, converting the inner storage numbers. The class method of this #' particular function coerces the levels to numeric, via the default activated #' argument \code{levels}. #' #' For objects of class \dQuote{declared}, a similar argument called \code{na_values} #' is by default activated to coerce the declared missing values to numeric. #' #' The function \bold{\code{possibleNumeric()}} tests if the values in a vector are #' possibly numeric, irrespective of their storing as character or numbers. In the #' case of factors, it tests its levels representation. #' #' Function \bold{\code{wholeNumeric()}} tests if numbers in a vector are whole #' (round) numbers. Whole numbers are different from \dQuote{integer} numbers (which #' have special memory representation), and consequently the function #' \bold{\code{is.integer}()} tests something different, how numbers are stored in #' memory (see the description of function \bold{\code{\link[base]{double}()}} for #' more details). #' #' The function #' } #' #' #' \seealso{ #' \code{\link[base]{numeric}}, #' \code{\link[base]{integer}}, #' \code{\link[base]{double}} #' } #' #' #' \author{ #' Adrian Dusa #' } #' #' \examples{ #' x <- c("-.1", " 2.7 ", "B") #' asNumeric(x) # no warning #' #' f <- factor(c(3, 2, "a")) #' #' asNumeric(f) #' #' asNumeric(f, levels = FALSE) #' #' possibleNumeric(x) # FALSE #' #' possibleNumeric(x, each = TRUE) # TRUE TRUE FALSE #' #' possibleNumeric(c("1", 2, 3)) # TRUE #' #' is.integer(1) # FALSE #' #' # Signaling an integer in R #' is.integer(1L) # TRUE #' #' wholeNumeric(1) # TRUE #' #' wholeNumeric(c(1, 1.1), each = TRUE) # TRUE FALSE #' } #' #' #' \keyword{functions} NULL #' @export `asNumeric` <- function(x, ...) { UseMethod("asNumeric") } #' @export `asNumeric.declared` <- function(x, ..., na_values = TRUE) { na_index <- attr(x, "na_index") attributes(x) <- NULL if (isTRUE(na_values)) { if (!is.null(na_index)) { x[na_index] <- as.numeric(names(na_index)) } } NextMethod() } #' @export `asNumeric.factor` <- function(x, ..., levels = TRUE) { if (isTRUE(levels)) { return(suppressWarnings(as.numeric(levels(x)))[x]) } return(as.numeric(x)) } #' @export `asNumeric.default` <- function(x, ...) { attributes(x) <- NULL if (is.numeric(x)) { return(x) } x <- gsub("\u00a0", " ", x) result <- rep(NA, length(x)) multibyte <- grepl("[^!-~ ]", x) result[!multibyte] <- suppressWarnings(as.numeric(x[!multibyte])) return(result) } admisc/R/print.R0000755000176200001440000002435415161273642013214 0ustar liggesusers# Copyright (c) 2019 - 2026, 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 `print.admisc_deMorgan` <- function(x, ...) { prettyNums <- formatC(seq(length(x)), digits = nchar(length(x)) - 1, flag = 0) pM <- paste("M", prettyNums, sep = "") if (!is.null(isol <- attr(x, "isol"))) { pM <- paste(pM, isol, sep = "-") } pM <- paste(pM, ": ", sep = "") cat("\n") if (length(x) == 1 & !attr(x, "minimized")) { fx <- x[[1]] if (is.null(fx)) { cat("No negation possible.\n") } else { for (j in seq(length(fx))) { prettyNumsFact <- formatC(seq(length(fx)), digits = nchar(length(fx)) - 1, flag = 0) cat(paste("N", prettyNumsFact[j], ": ", sep = "")) flength <- nchar(prettyNumsFact[j]) + 1 strvctr <- unlist(strsplit(fx[j], split = " + ")) cat(prettyString(strvctr, getOption("width") - flength, flength, "+"), "\n", sep = "") } cat("\n") } } else { for (i in seq(length(x))) { cat(paste(pM[i], names(x)[i], sep = ""), "\n") fx <- x[[i]] if (is.null(fx)) { cat("No negation possible.\n") } else { for (j in seq(length(fx))) { prettyNumsFact <- formatC(seq(length(fx)), digits = nchar(length(fx)) - 1, flag = 0) cat(paste(" N", prettyNumsFact[j], ": ", sep = "")) flength <- nchar(prettyNumsFact[j]) + 3 strvctr <- unlist(strsplit(fx[j], split = " + ")) cat(prettyString(strvctr, getOption("width") - flength, flength, "+"), "\n", sep = "") } cat("\n") } } } } #' @export `print.admisc_intersection` <- function(x, ...) { prettyNums <- formatC(seq(length(x)), digits = nchar(length(x)) - 1, flag = 0) pI <- paste("E", prettyNums, sep="") pO <- paste(" I", prettyNums, sep="") if (!is.null(isol <- attr(x, "isol"))) { pI <- paste(pI, isol, sep = "-") pO <- paste(pO, isol, sep = "-") } pI <- paste(pI, ": ", sep = "") pO <- paste(pO, ": ", sep = "") expressions <- attr(x, "expressions") ncharSI <- max(nchar(pI)) for (i in seq(length(x))) { cat("\n", pI[i], sep = "") cat(prettyString(expressions[i], getOption("width") - ncharSI, ncharSI, "+")) cat("\n", pO[i], sep = "") cat(prettyString(x[i], getOption("width") - ncharSI, ncharSI, "+")) cat("\n") } cat("\n") } #' @export `print.admisc_simplify` <- function(x, ...) { prettyNums <- formatC(seq(length(x)), digits = nchar(length(x)) - 1, flag = 0) cat("\n") if (all(x == "")) { cat("S1: \"\"\n") } else { for (i in seq(length(x))) { cat(paste("S", prettyNums[i], ": ", sep = "")) flength <- nchar(prettyNums[i]) + 1 strvctr <- unlist(strsplit(x[i], split = " + ")) cat(prettyString(strvctr, getOption("width") - flength, flength, "+"), "\n") } } cat("\n") } #' @export `print.admisc_factorize` <- function(x, ...) { prettyNums <- formatC(seq(length(x)), digits = nchar(length(x)) - 1, flag = 0) pM <- paste("M", prettyNums, sep = "") if (!is.null(isol <- attr(x, "isol"))) { pM <- paste(pM, isol, sep = "-") } pM <- paste(pM, ": ", sep = "") cat("\n") if (length(x) == 1) { fx <- x[[1]] if (is.null(fx)) { cat("No factorization possible.\n") } else { for (j in seq(length(fx))) { prettyNumsFact <- formatC(seq(length(fx)), digits = nchar(length(fx)) - 1, flag = 0) cat(paste("F", prettyNumsFact[j], ": ", sep = "")) flength <- nchar(prettyNumsFact[j]) + 1 strvctr <- unlist(strsplit(fx[j], split = " + ")) cat(prettyString(strvctr, getOption("width") - flength, flength, "+"), "\n", sep = "") } cat("\n") } } else { for (i in seq(length(x))) { cat(paste(pM[i], names(x)[i], sep = ""), "\n") fx <- x[[i]] if (is.null(fx)) { cat("No factorization possible.\n") } else { for (j in seq(length(fx))) { prettyNumsFact <- formatC(seq(length(fx)), digits = nchar(length(fx)) - 1, flag = 0) cat(paste(" F", prettyNumsFact[j], ": ", sep = "")) flength <- nchar(prettyNumsFact[j]) + 3 strvctr <- unlist(strsplit(fx[j], split = " + ")) cat(prettyString(strvctr, getOption("width") - flength, flength, "+"), "\n", sep = "") } cat("\n") } } } } #' @export `print.admisc_translate` <- function(x, ...) { dots <- list(...) cat("\n") original <- FALSE y <- matrix(as.vector(x), nrow = nrow(x)) if (is.element("original", names(dots))) { if (is.logical(dots$original)) { original <- dots$original[1] } } cols <- colnames(x) colnames(y) <- cols if (original) { minus <- any(y < 0) if (minus) { y[y >= 0] <- paste("", y[y >= 0]) cols[nchar(cols) == 1] <- paste("", cols[nchar(cols) == 1]) colnames(y) <- cols } } else { y[x < 0] <- "" } rownames(y) <- paste(rownames(x), " ") print(prettyTable(y)) cat("\n") } #' @export `print.admisc_fobject` <- function(x, startend = TRUE, ...) { class(x) <- setdiff(class(x), "admisc_fobject") if (is.list(x)) { split <- attr(x, "split") if (is.matrix(split)) { nms <- apply(attr(x, "split", exact = TRUE), 1, function(x) { paste(x, collapse = ", ") }) } else { nms <- split } cat(ifelse(startend, "\n", "")) for (i in seq(length(x))) { cat(nms[i], "\n") cat(paste(c(rep("-", nchar(nms[i])), "\n"), collapse = "")) if (is.null(x[[i]])) { cat("No data.\n") } else { if (is.matrix(x[[i]])) { class(x[[i]]) <- c("admisc_fobject", class(x[[i]])) } class(x[[i]]) <- setdiff(class(x[[i]]), "admisc_fobject") print(x[[i]], startend = FALSE) } if (i < length(x)) { cat("\n") } } cat(ifelse(startend, "\n", "")) } else { if (is.matrix(x)) { if (!all(dim(x) > 0)) { stopError("Incorrect _fobject_ to print, in package admisc.") } rnms <- rownames(x) max.nchar.rnms <- max(nchar(encodeString(rnms)), na.rm = TRUE) for (i in seq(length(rnms))) { if (nchar(rnms[i]) < max.nchar.rnms) { rnms[i] <- padLeft(rnms[i], max.nchar.rnms - nchar(rnms[i])) } } rownames(x) <- rnms } else if (is.atomic(x)) { x <- matrix( if (possibleNumeric(x)) round(asNumeric(x), 3) else x, nrow = 1, dimnames = list("", names(x)) ) } nax <- is.na(x) pN <- apply(x, 2, possibleNumeric) nms <- colnames(x) cx <- x for (c in seq(ncol(x))) { xc <- x[, c] max.nchar.nc <- max(nchar(xc), na.rm = TRUE) ndec <- 0 if (pN[c]) { ndec <- min(numdec(xc), 3) x[, c] <- sprintf( paste0("%", max.nchar.nc, ".", ndec, "f"), asNumeric(xc) ) } if (possibleNumeric(nms[c])) { nmsc <- sprintf( paste0("%", max.nchar.nc, ".", ndec, "f"), asNumeric(nms[c]) ) if (grepl("[.]", nmsc)) { nmsc <- paste( unlist(strsplit(nmsc, split = "[.]"))[1], paste(rep(" ", ndec), collapse = "") ) } nms[c] <- nmsc } } x[nax] <- "" max.nchars <- max(nchar(c(encodeString(nms), x)), na.rm = TRUE) for (i in seq(length(nms))) { if (nchar(nms[i]) < max.nchars) { nms[i] <- padBoth(nms[i], max.nchars - nchar(nms[i])) } } for (i in seq(length(x))) { if (nchar(x[i]) < max.nchars) { x[i] <- padBoth(x[i], max.nchars - nchar(x[i])) } } colnames(x) <- nms cat(ifelse(startend, "\n", "")) print(noquote(x)) cat(ifelse(startend, "\n", "")) } } admisc/R/possibleNumeric.R0000644000176200001440000000552415161273642015216 0ustar liggesusers# Copyright (c) 2019 - 2026, 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 `possibleNumeric` <- function(x, each = FALSE) { result <- rep(NA, length(x)) nax <- is.na(x) if (all(nax)) { if (each) { return(result) } return(FALSE) } if (is.logical(x)) { if (each) { result <- logical(length(x)) result[nax] <- NA return(result) } return(FALSE) } if (inherits(x, "haven_labelled") || inherits(x, "declared")) { num <- Recall(unclass(x), each = each) labels <- attr(x, "labels", exact = TRUE) if (!is.null(labels) && !each && num) { return(Recall(labels)) } return(num) } if (is.numeric(x)) { if (each) { result[!nax] <- TRUE return(result) } return(TRUE) } if (is.factor(x)) { x <- as.character(x) } x <- gsub( "\u00a0", " ", gsub( "\u009d", "", x ) ) multibyte <- grepl("[^!-~ ]", x) if (any(multibyte)) { result[multibyte] <- FALSE } if (sum(nax) < length(x)) { eachx <- suppressWarnings(as.numeric(x[!nax & !multibyte])) result[!nax & !multibyte] <- !is.na(eachx) } if (each | length(x) == 1) { return(result) } return(all(result[!nax])) } admisc/R/verify.R0000755000176200001440000001060215161273642013353 0ustar liggesusers# Copyright (c) 2019 - 2026, 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 `verify` <- function(data) { if (is.data.frame(data)) { if (is.null(colnames(data))) { stopError("The dataset doesn't have any columns names.") } checkNumUncal <- lapply(data, function(x) { is_a_factor <- is.factor(x) is_a_declared <- inherits(x, "declared") x <- setdiff(x, c("-", "dc", "?")) is_possible_numeric <- admisc::possibleNumeric(x) uncal <- mvuncal <- FALSE if (is_possible_numeric & !is_a_declared) { y <- na.omit(admisc::asNumeric(x)) if (any(y > 1) & any(abs(y - round(y)) >= .Machine$double.eps^0.5)) { uncal <- TRUE } if (length(seq(0, max(y))) > 20) { mvuncal <- TRUE } } return(c(is_possible_numeric, uncal, mvuncal, is_a_factor, is_a_declared)) }) checknumeric <- sapply(checkNumUncal, "[[", 1) checkuncal <- sapply(checkNumUncal, "[[", 2) checkmvuncal <- sapply(checkNumUncal, "[[", 3) checkfactor <- sapply(checkNumUncal, "[[", 4) checkdeclared <- sapply(checkNumUncal, "[[", 5) if (!all(checknumeric | checkfactor | checkdeclared)) { notnumeric <- colnames(data)[!checknumeric] errmessage <- paste("The causal condition", ifelse(length(notnumeric) == 1, " ", "s "), paste(notnumeric, collapse=", "), ifelse(length(notnumeric) == 1, " is ", " are "), "not numeric.", sep="") stopError(paste(strwrap(errmessage, exdent = 7), collapse = "\n", sep = "")) } if (any(checkuncal)) { uncalibrated <- colnames(data)[checkuncal] errmessage <- paste("Uncalibrated data.\n", "Fuzzy sets should have values bound to the interval [0 , 1] and all other sets should be crisp.\n", "Please check the following condition", ifelse(length(uncalibrated) == 1, "", "s"), ":\n", paste(uncalibrated, collapse = ", "), sep="") stopError(paste(strwrap(errmessage, exdent = 7), collapse = "\n", sep = "")) } if (any(checkmvuncal)) { uncalibrated <- colnames(data)[checkmvuncal] errmessage <- paste("Possibly uncalibrated data.\n", "Multivalue conditions with more than 20 levels are unlikely to be (properly) calibrated.\n", "Please check the following condition", ifelse(length(uncalibrated) == 1, "", "s"), ":\n", paste(uncalibrated, collapse = ", "), sep="") stopError(paste(strwrap(errmessage, exdent = 7), collapse = "\n", sep = "")) } } else if (is.vector(drop(data))) { if (!possibleNumeric(data)) { stopError("Non numeric input.") } } } admisc/R/simplify.R0000644000176200001440000001221415161273642013701 0ustar liggesusers# Copyright (c) 2019 - 2026, 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 `simplify` <- function(expression = "", snames = "", noflevels = NULL, ...) { expression <- recreate(substitute(expression)) snames <- recreate(substitute(snames)) dots <- list(...) mvregexp <- "\\[|\\]|\\{|\\}" enter <- if (is.element("enter", names(dots))) dots$enter else "\n" all.sol <- if (is.element("all.sol", names(dots))) dots$all.sol else FALSE scollapse <- if (is.element("scollapse", names(dots))) dots$scollapse else FALSE if (identical(snames, "")) { syscalls <- unlist(lapply(sys.calls(), deparse)) usingwith <- "admisc::using\\(|using\\(|with\\(" if (any(usingdata <- grepl(usingwith, syscalls))) { data <- get( unlist(strsplit(gsub(usingwith, "", syscalls), split = ","))[1], envir = length(syscalls) - tail(which(usingdata), 1) ) if (is.data.frame(data) | is.matrix(data)) { snames <- colnames(data) } } } scollapse <- scollapse | grepl("[*]", expression) multivalue <- any(grepl(mvregexp, expression)) curly <- grepl("[{]", expression) if (multivalue) { if (is.null(noflevels) | identical(snames, "")) { stopError("Set names and their number of levels are required to simplify multivalue expressions.") } } implicants <- expand(expression, snames = snames, noflevels = noflevels, implicants = TRUE) if (identical(unclass(implicants), "")) { return(implicants) } if (is.null(noflevels)) { noflevels <- rep(2, ncol(implicants)) } qca_version <- tryCatch( if (requireNamespace("QCA", quietly = TRUE)) { packageDescription("QCA")$Version } else { NULL }, error = function(e) NULL ) if (is.null(qca_version) || compareVersion(qca_version, "3.7") < 0) { message( paste( enter, "Package QCA (>= 3.7) is needed to simplify this expression.", enter, sep = "" ) ) return(invisible(character(0))) } dataset <- cbind(implicants - 1, 1) outcome <- paste(sample(LETTERS, 10), collapse = "") colnames(dataset)[ncol(dataset)] <- outcome test <- tryCatchWEM(sols <- QCA::minimize(dataset, outcome = outcome, all.sol = all.sol, simplify = TRUE)) if (!is.null(test)) { if (!is.null(test$error)) { if (grepl("All truth table", test$error)) { return("") } message( paste( enter, "QCA minimization failed.", enter, sep = "" ) ) return(invisible(character(0))) } } scollapse <- scollapse | any(nchar(colnames(implicants)) > 1) | any(grepl(mvregexp, unlist(sols$solution))) expression <- unlist(lapply(sols$solution, function(x) { if (!scollapse) x <- gsub("\\*", "", x) return(paste(x, collapse = " + ")) })) if (curly) { expression <- gsub("\\[", "\\{", expression) expression <- gsub("\\]", "\\}", expression) } else { expression <- gsub("\\{", "\\[", expression) expression <- gsub("\\}", "\\]", expression) } if (!identical(snames, "")) { attr(expression, "snames") <- snames } return(classify(expression, "admisc_simplify")) } #' @export `sop` <- function(...) { .Deprecated(msg = "Function sop() is deprecated, and has been renamed to simplify()\n") simplify(...) } admisc/R/mvSOP.R0000644000176200001440000001042015161273642013046 0ustar liggesusers# Copyright (c) 2019 - 2026, 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 `mvSOP` <- function( expression = "", snames = "", data = NULL, keep.tilde = TRUE, ... ) { expression <- recreate(substitute(expression)) snames <- recreate(substitute(snames)) dots <- list(...) if (any(grepl("\\[|\\]|\\{|\\}", expression))) { stopError("The expression is already in multi-value notation.", ... = ...) } if (identical(snames, "")) { if (!is.null(data)) { snames <- colnames(data) } } else { snames <- splitstr(snames) } noflevels <- NULL oldc <- newc <- c() categories <- list() if (is.null(data)) { if (!is.null(dots$categories)) { categories <- dots$categories } } else { infodata <- getInfo(data) noflevels <- infodata$noflevels categories <- infodata$categories } checkValid( expression = expression, snames = snames, data = data, categories = categories ) if (length(categories) > 0) { fnames <- names(categories) oldc <- c(paste0("~", fnames), fnames) newc <- c(paste0(fnames, "[0]"), paste0(fnames, "[1]")) for (i in seq(length(categories))) { values <- seq(length(categories[[i]])) - 1 oldc <- c(oldc, categories[[i]]) newc <- c(newc, paste0(fnames[i], "[", values, "]")) if (!keep.tilde) { oldc <- c(oldc, paste0("~", categories[[i]])) for (v in values) { newc <- c(newc, paste0( fnames[i], "[", paste(setdiff(values, v), collapse = ","), "]" ) ) } } } } oldc <- c(oldc, paste0("~", snames), snames) newc <- c(newc, paste0(snames, "[0]"), paste0(snames, "[1]")) expression <- replaceText(expression, oldc, newc) if (any(!is.element(squareBrackets(expression, outside = TRUE), snames))) { stopError("Unkown condition(s) in the expression.", ... = ...) } if (!is.null(noflevels)) { if (any(infodata$hastime)) { noflevels[infodata$hastime] <- noflevels[infodata$hastime] - 1 } rnames <- colnames(validateNames(expression, snames = snames, data = data)) noflevels <- noflevels[match(rnames, colnames(data))] if (any(noflevels > 2)) { stopError("Part(s) of the expression refer to multi-value data.", ... = ...) } } if (isTRUE(dots$translate)) { return( list( expression = expression, oldc = oldc, newc = newc ) ) } return(expression) } admisc/R/inside.R0000644000176200001440000001243215161273642013322 0ustar liggesusers# Copyright (c) 2019 - 2026, 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. #' Evaluate an Expression in a Data Environment #' #' Evaluate an R expression in an environment constructed from data. #' #' @name inside #' @rdname inside #' @aliases inside.list #' @rawRd #' \usage{ #' inside(data, expr, ...) #' #' \S3method{inside}{list}(data, expr, keepAttrs = TRUE, \dots) #' } #' #' \arguments{ #' \item{data}{Data to use for constructing an environment a \code{data frame} #' or a \code{list}.} #' \item{expr}{Expression to evaluate, often a \dQuote{compound} expression, #' i.e., of the form \preformatted{ #' { #' a <- somefun() #' b <- otherfun() #' ..... #' rm(unused1, temp) #' } #' }} #' #' \item{keepAttrs}{For the \code{\link{list}} method of \code{inside()}, #' a \code{\link{logical}} specifying if the resulting list should keep #' the \code{\link{attributes}} from \code{data} and have its #' \code{\link{names}} in the same order. Often this is unneeded as #' the result is a \emph{named} list anyway, and then \code{keepAttrs = #' FALSE} is more efficient.} #' \item{...}{Arguments to be passed to (future) methods.} #' } #' #' \details{ #' This is a modified version of the base R function \code{within()}, with exactly #' the same arguments and functionality but only one fundamental difference: #' instead of returning a modified copy of the input data, this function alters the #' data directly. #' } #' #' \author{ #' Adrian Dusa #' } #' #' \examples{ #' mt <- mtcars #' inside(mt, hwratio <- hp/wt) #' #' dim(mtcars) #' #' dim(mt) #' } #' #' \keyword{functions} NULL #' @export `inside` <- function(data, expr, ...) { UseMethod("inside") } #' @export `inside.data.frame` <- function(data, expr, ...) { dataname <- deparse(substitute(data)) parent <- parent.frame() e <- evalq(environment(), data, parent) if (missing(expr)) { args <- unlist(lapply(match.call(), deparse)[-1]) args <- args[setdiff(names(args), c("data", "expr"))] if (length(args) > 1) { stopError("Missing or ambiguous expression") } expr <- str2lang(paste(names(args), args[[1]], sep = "<-")) } eval(substitute(expr), e) l <- as.list(e, all.names = TRUE) l <- l[!vapply(l, is.null, NA, USE.NAMES = FALSE)] nl <- names(l) del <- setdiff(names(data), nl) data[nl] <- l data[del] <- NULL if (exists(dataname, parent)) { parent[[dataname]] <- data } else { structure_string <- paste(capture.output(dput(data)), collapse = " ") eval( parse(text = sprintf(paste(dataname, "<- %s"), structure_string)), envir = parent ) } } #' @export `inside.list` <- function(data, expr, keepAttrs = TRUE, ...) { parent <- parent.frame() dataname <- deparse(substitute(data)) e <- evalq(environment(), data, parent) if (missing(expr)) { args <- unlist(lapply(match.call(), deparse)[-1]) args <- args[setdiff(names(args), c("data", "expr", "keepAttrs"))] if (length(args) > 1) { stopError("Missing or ambiguous expression") } expr <- str2lang(paste(names(args), args[[1]], sep = "<-")) } eval(substitute(expr), e) if (keepAttrs) { l <- as.list(e, all.names=TRUE) nl <- names(l) del <- setdiff(names(data), nl) data[nl] <- l data[del] <- NULL } else { data <- as.list(e, all.names=TRUE) } if (exists(dataname, parent)) { parent[[dataname]] <- data } else { structure_string <- paste(capture.output(dput(data)), collapse = " ") eval( parse(text = sprintf(paste(dataname, "<- %s"), structure_string)), envir = parent ) } } admisc/R/objRDA.R0000644000176200001440000000350215161273642013146 0ustar liggesusers# Copyright (c) 2019 - 2026, 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 `objRDA` <- function(.filename) { attached_filename <- paste0("file:", .filename, "") suppressMessages(do.call("attach", list(what = .filename, name = attached_filename))) on.exit(eval(substitute(detach(name), list(name = attached_filename)))) return(ls(envir = as.environment(attached_filename))) } admisc/R/pad.R0000644000176200001440000000353215161273642012614 0ustar liggesusers# Copyright (c) 2019 - 2026, 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 `padLeft` <- function(x, n) { paste(c(rep(" ", n), x), collapse = "", sep = "") } #' @export `padRight` <- function(x, n) { paste(c(x, rep(" ", n)), collapse = "", sep = "") } #' @export `padBoth` <- function(x, n) { n1 <- ceiling(n/2) n2 <- floor(n/2) paste(c(rep(" ", n1), x, rep(" ", n2)), collapse = "", sep = "") } admisc/R/expand.R0000644000176200001440000002034515161273642013330 0ustar liggesusers# Copyright (c) 2019 - 2026, 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 `expand` <- function(expression = "", snames = "", noflevels = NULL, partial = FALSE, implicants = FALSE, ...) { expression <- recreate(substitute(expression)) snames <- recreate(substitute(snames)) dots <- list(...) multivalue <- FALSE scollapse <- ifelse(is.element("scollapse", names(dots)), dots$scollapse, FALSE) scollapse <- scollapse | grepl("[*]", expression) if (!is.null(noflevels)) { if (is.character(noflevels) & length(noflevels) == 1) { noflevels <- splitstr(noflevels) } } `remred` <- function(x) { if (nrow(x) > 1) { redundant <- logical(nrow(x)) for (i in seq(nrow(x) - 1)) { if (!redundant[i]) { for (j in seq(i + 1, nrow(x))) { if (!redundant[j]) { subsetrow <- checkSubset(x[c(i, j), , drop = FALSE]) if (!is.null(subsetrow)) { redundant[c(i, j)[subsetrow]] <- TRUE } } } } } x <- x[!redundant, , drop = FALSE] } return(x) } `dnf` <- function(x, noflevels = NULL, partial = FALSE) { if (is.null(noflevels)) { noflevels <- rep(2, ncol(x)) } zeroc <- which(apply(x, 2, function(x) all(x == 0))) if (length(zeroc) > 0 & partial) { x <- x[, -zeroc, drop = FALSE] } result <- matrix(nrow = 0, ncol = ncol(x)) rmin <- min(apply(x, 1, function(x) sum(x == 0))) for (i in seq(nrow(x))) { xi <- x[i, ] rxi <- sum(xi == 0) if (rxi > 0 & ifelse(partial, rxi > rmin, TRUE)) { wxi <- which(xi == 0) if (partial) { combs <- combnk(rxi, rxi - rmin) for (col in seq(ncol(combs))) { wxic <- wxi[combs[, col]] rest <- getMatrix(noflevels[wxic]) + 1 basemat <- matrix(rep(xi[-wxic], nrow(rest)), nrow = nrow(rest), byrow = TRUE) resmat <- cbind(basemat, rest)[, order(c(seq(ncol(x))[-wxic], wxic)), drop = FALSE] result <- rbind(result, resmat) } } else { rest <- getMatrix(noflevels[wxi]) + 1 basemat <- matrix(rep(xi[-wxi], nrow(rest)), nrow = nrow(rest), byrow = TRUE) resmat <- cbind(basemat, rest)[, order(c(seq(ncol(x))[-wxi], wxi)), drop = FALSE] result <- rbind(result, resmat) } } else { result <- rbind(result, xi) } } colnames(result) <- colnames(x) if (length(zeroc) > 0 & partial) { for (i in zeroc) { result <- cbind(result, 0) } result <- result[, order(c(seq(ncol(result))[-zeroc], zeroc)), drop = FALSE] colnames(result)[zeroc] <- names(zeroc) } return(unique(result)) } if (is.character(expression)) { if (length(expression) > 1) { expression <- expression[1] } if (identical(snames, "")) { syscalls <- unlist(lapply(sys.calls(), deparse)) usingwith <- "admisc::using\\(|using\\(|with\\(" if (any(usingdata <- grepl(usingwith, syscalls))) { data <- get( unlist(strsplit(gsub(usingwith, "", syscalls), split = ","))[1], envir = length(syscalls) - tail(which(usingdata), 1) ) if (is.data.frame(data) | is.matrix(data)) { snames <- colnames(data) } } } snames <- splitstr(snames) multivalue <- any(grepl("\\[|\\]|\\{|\\}", expression)) if (multivalue) { expression <- gsub("[*]", "", expression) checkMV(expression, snames = snames, noflevels = noflevels) } if (!grepl("[+]", expression) & grepl("[,]", expression)) { if (multivalue) { values <- squareBrackets(expression) atvalues <- paste("@", seq(length(values)), sep = "") for (i in seq(length(values))) { expression <- gsub(values[i], atvalues[i], expression) } expression <- gsub(",", "+", expression) for (i in seq(length(values))) { expression <- gsub(atvalues[i], values[i], expression) } } else { oldway <- unlist(strsplit(gsub("[-|;|,|[:space:]]", "", expression), split = "")) if (!possibleNumeric(oldway) & length(oldway) > 0) { expression <- gsub(",", "+", expression) } } } if (any(grepl("[(|)]", expression))) { bl <- expandBrackets(expression, snames = snames, noflevels = noflevels) } else { bl <- expression } if (identical(bl, "")) { return(classify("", "admisc_simplify")) } tlist <- list(expression = bl, snames = snames) if (!is.null(noflevels)) { tlist$noflevels <- noflevels } bl <- tryCatch(do.call(translate, tlist), error = function(e) e) if (is.list(bl)) { return(classify("", "admisc_simplify")) } expression <- matrix(nrow = 0, ncol = ncol(bl)) colnames(expression) <- colnames(bl) for (i in seq(nrow(bl))) { expression <- rbind(expression, as.matrix(expand.grid(lapply(bl[i, ], function(x) { asNumeric(splitstr(x)) + 1 })))) } } else if (!is.matrix(expression)) { stopError("The input should be either a character expression or a matrix.") } if (is.null(noflevels)) noflevels <- rep(2, ncol(expression)) expression <- dnf(remred(expression), noflevels = noflevels, partial = partial) if (implicants) { for (i in seq(ncol(expression), 1)) { expression <- expression[order(expression[, i]), , drop = FALSE] } rownames(expression) <- NULL return(expression) } if (is.null(colnames(expression))) { stopError("The input matrix should have column names.") } scollapse <- scollapse | any(nchar(snames) > 1) expression <- writePIs(expression, multivalue, collapse = ifelse(scollapse, "*", "")) expression <- paste(expression, collapse = " + ") if (!identical(snames, "")) { attr(expression, "snames") <- snames } return(classify(expression, "admisc_simplify")) } admisc/R/dimnames.R0000644000176200001440000000516315161273642013647 0ustar liggesusers# Copyright (c) 2019 - 2026, 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. #' Set matrix row or column names #' #' Set matrix row or column names without copying, especially useful for (very) #' large matrices. #' #' @name setColnames #' @rdname dimnames #' @aliases dimnames #' @aliases setRownames #' @aliases setDimnames #' @rawRd #' \usage{ #' setColnames(matrix, colnames) #' setRownames(matrix, rownames) #' setDimnames(matrix, nameslist) #' } #' #' \arguments{ #' \item{matrix}{An R matrix} #' \item{colnames}{Character vector of column names} #' \item{rownames}{Character vector of row names} #' \item{nameslist}{A two-component list containing rownames and colnames} #' } #' #' #' \author{ #' Adrian Dusa #' } #' #' \examples{ #' #' mat <- matrix(1:9, nrow = 3) #' setDimnames(mat, list(LETTERS[1:3], letters[1:3])) #' } #' #' #' \keyword{functions} NULL #' @export `setColnames` <- function(matrix, colnames) { invisible(.Call("C_setColnames", matrix, colnames)) } #' @export `setRownames` <- function(matrix, rownames) { invisible(.Call("C_setRownames", matrix, rownames)) } #' @export `setDimnames` <- function(matrix, nameslist) { invisible(.Call("C_setDimnames", matrix, nameslist)) } admisc/R/checkSubset.R0000644000176200001440000000337515161273642014320 0ustar liggesusers# Copyright (c) 2019 - 2026, 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 `checkSubset` <- function(mat, implicants = TRUE) { for (i in 1:2) { eqz <- mat[i, ] == ifelse(implicants, 0, -1) if (nrow(unique(mat[, !eqz, drop = FALSE])) == 1) { return(3 - i) } } return(NULL) } admisc/R/SOPexpression.R0000644000176200001440000002355615161273642014641 0ustar liggesusers# Copyright (c) 2019 - 2026, 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. #' Functions to interpret and manupulate a SOP/DNF expression #' #' These functions interpret an expression written in sum of products (SOP) or in #' canonical disjunctive normal form (DNF), for both crisp and multivalue notations. #' The function \bold{\code{compute()}} calculates set membership scores based on a #' SOP expression applied to a calibrated data set (see function #' \bold{\code{\link[QCA]{calibrate}()}} from package \bold{\pkg{QCA}}), while the #' function \bold{\code{translate()}} translates a SOP expression into a matrix form. #' #' @name asSOP #' @rdname SOPexpression #' @aliases compute #' @aliases expand #' @aliases mvSOP #' @aliases simplify #' @aliases sop #' @aliases translate #' @rawRd #' \usage{ #' asSOP(expression = "", snames = "", noflevels = NULL) #' #' compute(expression = "", data = NULL, separate = FALSE, ...) #' #' expand(expression = "", snames = "", noflevels = NULL, partial = FALSE, #' implicants = FALSE, ...) #' #' mvSOP(expression = "", snames = "", data = NULL, keep.tilde = TRUE, ...) #' #' simplify(expression = "", snames = "", noflevels = NULL, ...) #' #' translate(expression = "", snames = "", noflevels = NULL, data = NULL, ...) #' } #' #' \arguments{ #' \item{expression}{String, a SOP expression.} #' \item{data}{A dataset with binary cs, mv and fs data.} #' \item{separate}{Logical, perform computations on individual, separate paths.} #' \item{snames}{A string containing the sets' names, separated by commas.} #' \item{noflevels}{Numerical vector containing the number of levels for each set.} #' \item{partial}{Logical, perform a partial Quine expansion.} #' \item{implicants}{Logical, return an expanded matrix in the implicants space.} #' \item{keep.tilde}{Logical, preserves the tilde sign when coercing a factor level} #' \item{...}{Other arguments, mainly for backwards compatibility.} #' } #' #' \details{ #' An expression written in sum of products (SOP), is a "union of intersections", #' for example \bold{\code{A*B + B*~C}}. The disjunctive normal form (DNF) is also #' a sum of products, with the restriction that each product has to contain all #' literals. The equivalent DNF expression is: \bold{\code{A*B*~C + A*B*C + ~A*B*~C}} #' #' The same expression can be written in multivalue notation: #' \bold{\code{A[1]*B[1] + B[1]*C[0]}}. #' #' Expressions can contain multiple values for the same condition, separated by a #' comma. If B was a multivalue causal condition, an expression could be: #' \bold{\code{A[1] + B[1,2]*C[0]}}. #' #' Whether crisp or multivalue, expressions are treated as Boolean. In this last #' example, all values in B equal to either 1 or 2 will be converted to 1, and the #' rest of the (multi)values will be converted to 0. #' #' Negating a multivalue condition requires a known number of levels (see examples #' below). Intersections between multiple levels of the same condition are possible. #' For a causal condition with 3 levels (0, 1 and 2) the following expression #' \bold{\code{~A[0,2]*A[1,2]}} is equivalent with \bold{\code{A[1]}}, while #' \bold{\code{A[0]*A[1]}} results in the empty set. #' #' The number of levels, as well as the set names can be automatically detected #' from a dataset via the argument \bold{\code{data}}. When specified, arguments #' \bold{\code{snames}} and \bold{\code{noflevels}} have precedence over #' \bold{\code{data}}. #' #' The product operator \bold{\code{*}} should always be used, but it can be omitted #' when the data is multivalue (where product terms are separated by curly brackets), #' and/or when the set names are single letters (for example \bold{\code{AD + B~C}}), #' and/or when the set names are provided via the argument \bold{\code{snames}}. #' #' When expressions are simplified, their simplest equivalent can result in the #' empty set, if the conditions cancel each other out. #' #' The function \bold{\code{mvSOP()}} assumes binary crisp conditions in the #' expression, except for categorical data used as multi-value conditions. The #' factor levels are read directly from the data, and they should be unique accross #' all conditions. #' } #' #' #' \value{ #' For the function \bold{\code{compute()}}, a vector of set membership values. #' #' For function \bold{\code{simplify()}}, a character expression. #' #' For the function \bold{\code{translate()}}, a matrix containing the implicants #' on the rows and the set names on the columns, with the following codes: #' \tabular{rl}{ #' 0 \tab absence of a causal condition\cr #' 1 \tab presence of a causal condition\cr #' -1 \tab causal condition was eliminated #' } #' The matrix was also assigned a class "translate", to avoid printing the -1 codes #' when signaling a minimized condition. The mode of this matrix is character, to #' allow printing multiple levels in the same cell, such as "1,2". #' #' For function \bold{\code{expand()}}, a character expression or a matrix of #' implicants. #' } #' #' \author{ #' Adrian Dusa #' } #' #' \references{ #' Ragin, C.C. (1987) \emph{The Comparative Method: Moving beyond Qualitative and #' Quantitative Strategies}. Berkeley: University of California Press. #' } #' #' \examples{ #' \dontrun{ #' # make sure the package QCA is loaded #' #' # ----- #' # for compute() #' library(QCA) #' compute(DEV*~IND + URB*STB, data = LF) #' #' # calculating individual paths #' compute(DEV*~IND + URB*STB, data = LF, separate = TRUE) #' } #' #' #' # ----- #' # for simplify() also make sure the package QCA is installed #' simplify(asSOP("(A + B)(A + ~B)")) # result is "A" #' #' # works even without the quotes #' simplify(asSOP((A + B)(A + ~B))) # result is "A" #' #' # but to avoid confusion POS expressions are more clear when quoted #' # to force a certain order of the set names #' simplify("(URB + LIT*~DEV)(~LIT + ~DEV)", snames = c(DEV, URB, LIT)) #' #' # multilevel conditions can also be specified (and negated) #' simplify("(A[1] + ~B[0])(B[1] + C[0])", snames = c(A, B, C), noflevels = c(2, 3, 2)) #' #' #' # Ragin's (1987) book presents the equation E = SG + LW as the result #' # of the Boolean minimization for the ethnic political mobilization. #' #' # intersecting the reactive ethnicity perspective (R = ~L~W) #' # with the equation E (page 144) #' #' simplify("~L~W(SG + LW)", snames = c(S, L, W, G)) #' #' # [1] "S~L~WG" #' #' #' # resources for size and wealth (C = SW) with E (page 145) #' simplify("SW(SG + LW)", snames = c(S, L, W, G)) #' #' # [1] "SWG + SLW" #' #' #' # and factorized #' factorize(simplify("SW(SG + LW)", snames = c(S, L, W, G))) #' #' # F1: SW(G + L) #' #' #' # developmental perspective (D = Lg) and E (page 146) #' simplify("L~G(SG + LW)", snames = c(S, L, W, G)) #' #' # [1] "LW~G" #' #' # subnations that exhibit ethnic political mobilization (E) but were #' # not hypothesized by any of the three theories (page 147) #' # ~H = ~(~L~W + SW + L~G) = GL~S + GL~W + G~SW + ~L~SW #' #' simplify("(GL~S + GL~W + G~SW + ~L~SW)(SG + LW)", snames = c(S, L, W, G)) #' #' #' # ----- #' # for translate() #' translate(A + B*C) #' #' # same thing in multivalue notation #' translate(A[1] + B[1]*C[1]) #' #' # tilde as a standard negation (note the condition "b"!) #' translate(~A + b*C) #' #' # and even for multivalue variables #' # in multivalue notation, the product sign * is redundant #' translate(C[1] + T[2] + T[1]*V[0] + C[0]) #' #' # negation of multivalue sets requires the number of levels #' translate(~A[1] + ~B[0]*C[1], snames = c(A, B, C), noflevels = c(2, 2, 2)) #' #' # multiple values can be specified #' translate(C[1] + T[1,2] + T[1]*V[0] + C[0]) #' #' # or even negated #' translate(C[1] + ~T[1,2] + T[1]*V[0] + C[0], snames = c(C, T, V), noflevels = c(2,3,2)) #' #' # if the expression does not contain the product sign * #' # snames are required to complete the translation #' translate(AaBb + ~CcDd, snames = c(Aa, Bb, Cc, Dd)) #' #' # to print _all_ codes from the standard output matrix #' (obj <- translate(A + ~B*C)) #' print(obj, original = TRUE) # also prints the -1 code #' #' #' # ----- #' # for expand() #' expand(~AB + B~C) #' #' # S1: ~AB~C + ~ABC + AB~C #' #' expand(~AB + B~C, snames = c(A, B, C, D)) #' #' # S1: ~AB~C~D + ~AB~CD + ~ABC~D + ~ABCD + AB~C~D + AB~CD #' #' # In implicants form: #' expand(~AB + B~C, snames = c(A, B, C, D), implicants = TRUE) #' #' # A B C D #' # [1,] 1 2 1 1 ~AB~C~D #' # [2,] 1 2 1 2 ~AB~CD #' # [3,] 1 2 2 1 ~ABC~D #' # [4,] 1 2 2 2 ~ABCD #' # [5,] 2 2 1 1 AB~C~D #' # [6,] 2 2 1 2 AB~CD #' #' } #' #' \keyword{functions} NULL admisc/R/tilde.R0000644000176200001440000000647715161273642013164 0ustar liggesusers# Copyright (c) 2019 - 2026, 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. #' Tilde operations #' #' Checks and changes expressions containing set negations using a tilde. #' #' @name hastilde #' @rdname tilde #' @aliases notilde #' @aliases tilde1st #' @rawRd #' \usage{ #' hastilde(x) #' notilde(x) #' tilde1st(x) #' } #' #' \arguments{ #' \item{x}{A vector of values} #' } #' #' #' \details{ #' Boolean expressions can be negated in various ways. For binary crisp and fuzzy sets, one of #' the most straightforward ways to invert the set membership scores is to subtract them from 1. #' This is both possible using R vectors and also often used to signal a negation in SOP #' (sum of products) expressions. #' #' Some other times, SOP expressions can signal a set negation (also known as the absence of a #' causal condition) by using lower case letters, while upper case letters are used to signal #' the presence of a causal condition. SOP expressions also use a tilde to signal a set negation, #' immediately preceding the set name. #' #' This set of functions detect when and if a set present in a SOP expression contains a tilde #' (function \bold{\code{hastilde}}), whether the entire expression begins with a tilde (function #' \bold{\code{tilde1st}}). #' } #' #' \author{ #' Adrian Dusa #' } #' #' \examples{ #' hastilde("~A") #' } #' #' #' \keyword{functions} NULL #' @export `tilde1st` <- function(x) { is.element( substring( gsub( paste0("[[:space:]|", "\u00a0", "]"), "", x ), 1, 1 ), tildae() ) } #' @export `hastilde` <- function(x) { grepl(paste(tildae(), collapse = "|"), x) } #' @export `notilde` <- function(x) { gsub( paste(tildae(), collapse = "|"), "", gsub( paste0("[[:space:]|", "\u00a0", "]"), "", x ) ) } admisc/R/hclr.R0000644000176200001440000000613415161273642013001 0ustar liggesusers# Copyright (c) 2019 - 2026, 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. #' Colors from the HCL spectrum #' #' Produces colors from the HCL (Hue Chroma Luminance) spectrum, based on the number of levels #' from a factor. #' #' @name hclr #' @rdname hclr #' @rawRd #' \usage{ #' hclr(x, starth = 25, c = 50, l = 75, alpha = 1, fixup = TRUE) #' } #' #' \arguments{ #' \item{x}{Number of factor levels, or the factor itself, or a frequency distribution #' from a factor} #' \item{starth}{Starting point for the hue (in the interval 0 - 360)} #' \item{c}{chroma - color purity, small values produce dark and high values produce #' bright colors} #' \item{l}{color luminance - a number between 0 and 100} #' \item{alpha}{color transparency, where 0 is a completely transparent color, up to 1} #' \item{fixup}{logical, corrects the RGB values foto produce a realistic color} #' } #' #' \value{ #' The RBG code for the corresponding HCL colors. #' } #' #' \details{ #' Any value of \code{h} outside the interval 0 - 360 is constrained to this interval using #' modulo values. For instance, 410 is constrained to 50 = 410%%360. #' } #' #' \author{Adrian Dusa} #' #' #' \examples{ #' #' aa <- sample(letters[1:5], 100, replace = TRUE) #' #' hclr(aa) #' #' # same with #' hclr(5) #' #' # or #' hclr(table(aa)) #' } #' #' \keyword{misc} NULL #' @export `hclr` <- function(x, starth = 25, c = 50, l = 75, alpha = 1, fixup = TRUE) { if (length(x) > 1) { x <- length(table(x)) } return( hcl( h = seq(starth, starth + 360, length = x + 1)%%360, c = c, l = l, alpha = alpha, fixup = fixup )[1:x] ) } admisc/R/update.R0000644000176200001440000000373315161273642013335 0ustar liggesusers# Copyright (c) 2019 - 2026, 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 `update.character` <- function(object, ...) { dots <- list(...) Call <- as.list(match.call(expand.dots = TRUE))[-1] DDIwR <- eval(parse(text = "requireNamespace('DDIwR', quietly = TRUE)")) if (!DDIwR) { stopError("Package DDIwR needs to be installed.") } if (length(object) != 1) { stopError("The path should be a single string.") } names(Call)[1] <- "xmlfile" eval(parse(text = "do.call('updateCodebook', Call)")) } admisc/R/getLevels.R0000644000176200001440000000477415161273642014013 0ustar liggesusers# Copyright (c) 2019 - 2026, 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 `getLevels` <- function(data) { data <- as.data.frame(data) colnames <- paste("V", ncol(data), sep = ".") pN <- sapply(data, possibleNumeric) noflevels <- rep(NA, ncol(data)) ulevels <- rep(NA, ncol(data)) noflevels[pN] <- apply( data[, pN, drop = FALSE], 2, function(x) max(as.numeric(x)) ) + 1 ulevels <- apply( data, 2, function(x) { return(length(unique(x))) } ) noflevels[is.na(noflevels)] <- ulevels[is.na(noflevels)] factor <- unlist(lapply(data, is.factor)) declared <- unlist(lapply(data, function(x) inherits(x, "declared"))) noflevels[pN][ apply( data[, pN, drop = FALSE], 2, function(x) any(as.numeric(x) %% 1 > 0) ) ] <- 2 if (any(factor | declared)) { noflevels[factor | declared] <- pmin(noflevels[factor | declared], ulevels[factor | declared]) } noflevels[noflevels == 1] <- 2 return(noflevels) } admisc/R/overwrite.R0000644000176200001440000000773015161273642014102 0ustar liggesusers# Copyright (c) 2019 - 2026, 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. #' Overwrite an object in a given environment. #' #' Utility function to overwrite an object, and bypass the assignment operator. #' #' @name overwrite #' @rdname overwrite #' @rawRd #' \usage{ #' overwrite(objname, content, environment) #' } #' #' \arguments{ #' \item{objname}{Character, the name of the object to overwrite.} #' \item{content}{An R object} #' \item{environment}{The environment where to perform the overwrite procedure.} #' } #' #' \details{ #' \code{assign()} is sufficient when \code{objname} is a simple object name, #' such as \code{"bar"}. It is not sufficient when the target is an expression, #' such as \code{"bar$A"}. A call such as \code{assign(bar$A, 1, envir = #' parent.frame())} fails because \code{assign()} expects its first argument to #' evaluate to a character string. If that expression is first deparsed, for #' instance to \code{"bar$A"}, then \code{assign()} would create an object #' literally named \code{"bar$A"} in the target environment rather than #' replacing component \code{A} inside \code{bar}. #' #' This function handles both situations. For simple names, it overwrites the #' object directly in the target environment. For expressions, it reconstructs #' and evaluates the corresponding assignment call in that environment. #' } #' #' \value{ #' This function does not return anything. #' } #' #' \author{ #' Adrian Dusa #' } #' #' \examples{ #' foo <- function(object, x) { #' objname <- deparse(substitute(object)) #' overwrite(objname, x, parent.frame()) #' } #' #' #' bar <- 1 #' foo(bar, 2) #' #' bar #' # [1] 2 #' #' bar <- list(A = bar) #' foo(bar$A, 3) #' #' bar #' # $A #' # [1] 3 #' #' #' foo_assign <- function(object, x) { #' objname <- deparse(substitute(object)) #' assign(objname, x, envir = parent.frame()) #' } #' #' bar <- list(A = 1) #' try(assign(bar$A, 3, envir = parent.frame())) #' #' bar <- 1 #' foo_assign(bar, 2) #' #' bar #' # [1] 2 #' #' bar <- list(A = 1) #' foo_assign(bar$A, 3) #' #' bar #' # $A #' # [1] 1 #' #' `bar$A` #' # [1] 3 #' } #' #' \keyword{functions} NULL #' @export `overwrite` <- function(objname, content, environment) { objname <- gsub("'|\"|[[:space:]]", "", objname) if (exists(objname, environment)) { environment[[objname]] <- content } else { structure_string <- paste(capture.output(dput(content)), collapse = " ") eval( parse(text = sprintf(paste(objname, "<- %s"), structure_string)), envir = environment ) } } admisc/R/unicode.R0000644000176200001440000000361315161273642013476 0ustar liggesusers# Copyright (c) 2019 - 2026, 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 `dashes` <- function() { return(c("\u002d", "\u2013")) } #' @export `tildae` <- function() { return(c("\u007e", "\u223c", "\u00ac", "\u223d")) } #' @export `singlequotes` <- function() { return(c("\u00b4", "\u0060", "\u2018", "\u2019")) } #' @export `doublequotes` <- function() { return(c("\u201c", "\u201d")) } #' @export `spaces` <- function() { return("\u00a0") } admisc/R/string.R0000644000176200001440000003276615161273642013371 0ustar liggesusers# Copyright (c) 2019 - 2026, 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 `trimstr` <- function(x, what = " ", side = "both") { if (is.element(what, c("*", "+"))) { what <- paste("\\", what, sep = "") } what <- ifelse( identical(what, " "), paste0("[[:space:]|", "\u00a0", "]"), what ) pattern <- switch(side, both = paste("^", what, "+|", what, "+$", sep = ""), left = paste("^", what, "+", sep = ""), right = paste(what, "+$", sep = "") ) gsub(pattern, "", x) } #' @export `splitstr` <- function(x) { if (identical(x, "") || is.null(x)) return(x) x <- gsub("\\n", "", x) oldv <- newv <- NULL if (any(grepl(",|;", x) & grepl("\\{|\\[", x))) { curly <- grepl("\\{", x) squared <- grepl("\\[", x) if (curly & squared) { stopError( "Multi-value expressions should not mix curly and squared brackets." ) } regexp <- ifelse(curly, "\\{[[:alnum:]|,|;]+\\}", "\\[[[:alnum:]|,|;]+\\]") oldv <- regmatches(x, gregexpr(regexp, x), invert = FALSE)[[1]] newv <- paste("XYZW", seq(length(oldv)), sep = "") x <- replaceText( expression = x, target = oldv, replacement = newv, checktarget = FALSE ) } y <- trimstr(unlist(strsplit(x, split = ","))) if (length(y) == 1) { y <- gsub("\\n", "", unlist(strsplit(gsub("[[:space:]]", "", y), split = ";"))) } if (!is.null(oldv)) { for (i in seq(length(y))) { y[i] <- replaceText( expression = y[i], target = newv, replacement = oldv, checknone = TRUE ) } } metacall <- match.call()$x if (metacall == "sort.by") { if (any(grepl("[=]", y))) { y <- t(as.data.frame(strsplit(gsub("[[:space:]]", "", y), split = "="))) values <- y[, 2] == TRUE names(values) <- y[, 1] } else { values <- !grepl("[+]", y) names(values) <- gsub("[+|-]", "", y) } return(values) } else if (metacall == "decreasing") { return(as.logical(y)) } else if (metacall == "thresholds") { if (any(grepl("[=]", y))) { y <- t(as.data.frame(strsplit(gsub("[[:space:]]", "", y), split = "="))) values <- y[, 2] if (possibleNumeric(values)) { values <- asNumeric(values) } names(values) <- y[, 1] } else { if (possibleNumeric(y)) { values <- asNumeric(y) } } return(values) } else { if (possibleNumeric(y)) { y <- asNumeric(y) } return(y) } } #' @export `splitMainComponents` <- function(expression) { expression <- gsub("[[:space:]]", "", expression) ind.char <- unlist(strsplit(expression, split = "")) openclosed <- grepl("\\(", expression) | grepl("\\)", expression) if (openclosed) { open.brackets <- which(ind.char == "(") closed.brackets <- which(ind.char == ")") invalid <- ifelse( openclosed, length(open.brackets) != length(closed.brackets), TRUE ) if (invalid) { stopError("Invalid expression, open bracket \"(\" not closed with \")\".") } all.brackets <- sort(c(open.brackets, closed.brackets)) if (length(all.brackets) > 2) { for (i in seq(3, length(all.brackets))) { if (all.brackets[i] - all.brackets[i - 1] == 1) { open.brackets <- setdiff(open.brackets, all.brackets[seq(i - 1, i)]) closed.brackets <- setdiff(closed.brackets, all.brackets[seq(i - 1, i)]) } if ( all.brackets[i] - all.brackets[i - 1] == 2 && ind.char[all.brackets[i] - 1] != "+" ) { open.brackets <- setdiff(open.brackets, all.brackets[seq(i - 1, i)]) closed.brackets <- setdiff(closed.brackets, all.brackets[seq(i - 1, i)]) } } } for (i in seq(length(open.brackets))) { plus.signs <- which(ind.char == "+") last.plus.sign <- plus.signs[plus.signs < open.brackets[i]] if (length(last.plus.sign) > 0) { open.brackets[i] <- max(last.plus.sign) + 1 } else { if (1 == 1) { open.brackets[i] <- 1 } } next.plus.sign <- plus.signs[plus.signs > closed.brackets[i]] if(length(next.plus.sign) > 0) { closed.brackets[i] <- min(next.plus.sign) - 1 } else { closed.brackets[i] <- length(ind.char) } } big.list <- vector(mode = "list", length = length(open.brackets) + 2) if (length(open.brackets) == 1) { if (open.brackets > 1) { big.list[[1]] <- paste( ind.char[seq(1, open.brackets - 2)], collapse = "" ) } nep <- min(which(unlist(lapply(big.list, is.null)))) big.list[[nep]] <- paste( ind.char[seq(open.brackets, closed.brackets)], collapse = "" ) if (closed.brackets < length(ind.char)) { nep <- min(which(unlist(lapply(big.list, is.null)))) big.list[[nep]] <- paste( ind.char[seq(closed.brackets + 2, length(ind.char))], collapse = "" ) } } else { for (i in seq(length(open.brackets))) { if (i == 1) { if (open.brackets[1] > 1) { big.list[[1]] <- paste( ind.char[seq(1, open.brackets[1] - 2)], collapse = "" ) } nep <- min(which(unlist(lapply(big.list, is.null)))) big.list[[nep]] <- paste( ind.char[seq(open.brackets[i], closed.brackets[i])], collapse = "" ) } else { nep <- min(which(unlist(lapply(big.list, is.null)))) big.list[[nep]] <- paste( ind.char[seq(open.brackets[i], closed.brackets[i])], collapse = "" ) if (i == length(closed.brackets)) { if (closed.brackets[i] < length(ind.char)) { nep <- min(which(unlist(lapply(big.list, is.null)))) big.list[[nep]] <- paste( ind.char[seq(closed.brackets[i] + 2, length(ind.char))], collapse = "" ) } } } } } nulls <- unlist(lapply(big.list, is.null)) if (any(nulls)) { big.list <- big.list[-which(nulls)] } } else { big.list <- list(expression) } return(big.list) } #' @export `splitBrackets` <- function(big.list) { return(lapply(big.list, function(x) { as.list(unlist(strsplit(unlist(strsplit(x, split="\\(")), split="\\)"))) })) } #' @export `removeSingleStars` <- function(big.list) { return(lapply(big.list, function(x) { single.stars <- unlist(lapply(x, function(y) { return(y == "*") })) return(x[!single.stars]) })) } #' @export `splitPluses` <- function(big.list) { return(lapply(big.list, function(x) { lapply(x, function(y) { plus.split <- unlist(strsplit(y, "\\+")) return(as.list(plus.split[plus.split != ""])) }) })) } #' @export `splitStars` <- function(big.list, prod.split) { return(lapply(big.list, function(x) { lapply(x, function(y) { lapply(y, function(z) { star.split <- unlist(strsplit(z, ifelse(prod.split == "", "", paste("\\", prod.split, sep="")))) star.split <- star.split[star.split != ""] if (prod.split == "") { tilda <- hastilde(star.split) & length(star.split) > 1 if (any(tilda)) { tilda.pos <- which(tilda) if (max(tilda.pos) == length(star.split)) { stopError(paste("Unusual expression \"", z, "\": terminated with a \"~\" sign?", sep = "")) } star.split[tilda.pos + 1] <- paste("~", star.split[tilda.pos + 1], sep="") star.split <- star.split[-tilda.pos] } } return(as.list(star.split[star.split != ""])) }) }) })) } #' @export `splitTildas` <- function (big.list) { return(lapply(big.list, function(x) { lapply(x, function(y) { lapply(y, function(z) { lapply(z, function(w) { if (hastilde(w)) { wsplit <- unlist(strsplit(w, split = "")) if (max(which(hastilde(wsplit))) > 1) { stopError(paste("Unusual expression: ", w, ". Perhaps you meant \"*~\"?", sep = "")) } else { return(c("~", notilde(w))) } } else { return(w) } }) }) }) })) } #' @export `solveBrackets` <- function(big.list) { bracket.comps <- which(unlist(lapply(big.list, length)) > 1) if (length(bracket.comps) > 0) { for (i in bracket.comps) { lengths <- unlist(lapply(big.list[[i]], length)) indexes <- expand.grid(lapply(lengths - 1, seq, from = 0)) + 1 ncol.ind <- ncol(indexes) i.list <- vector("list", length = nrow(indexes)) for (j in seq(length(i.list))) { i.list[[j]] <- vector("list", length = prod(dim(indexes))) start.position <- 1 for (k in seq(ncol.ind)) { for (l in seq(length(big.list[[i]][[k]][[indexes[j, k]]]))) { i.list[[j]][[start.position]] <- big.list[[i]][[k]][[indexes[j, k]]][[l]] start.position <- start.position + 1 } } if (start.position <= length(i.list[[j]])) { i.list[[j]] <- i.list[[j]][- seq(start.position, length(i.list[[j]]))] } } big.list[[i]] <- list(i.list) } } return(big.list) } #' @export `simplifyList` <- function(big.list) { lengths <- unlist(lapply(big.list, function(x) length(x[[1]]))) bl <- vector("list", length = sum(lengths)) pos <- 1 for (i in seq(length(big.list))) { for (j in seq(lengths[i])) { blj <- unlist(big.list[[i]][[1]][[j]]) if (hastilde(blj[1]) & nchar(blj[1]) == 1) { blj <- blj[-1] for (b in seq(length(blj))) { if (tilde1st(blj[b])) { blj[b] <- notilde(blj[b]) } else { blj[b] <- paste0("~", blj[b]) } } } bl[[pos]] <- unique(blj) pos <- pos + 1 } } return(unique(bl[!unlist(lapply(bl, function(x) any(duplicated(notilde(x)))))])) } #' @export `getNonChars` <- function(x) { x <- gsub("^[[:space:]]+|[[:space:]]+$", "", unlist(strsplit(x, "\\+"))) z <- vector(mode="list", length=length(x)) for (i in seq(length(x))) { z[[i]] <- strsplit(gsub("[[:alnum:]]", "", x[i]), "+")[[1]] } z <- notilde(unique(unlist(z))) return(z[nzchar(z)]) } admisc/R/checkMV.R0000644000176200001440000001123715161273642013371 0ustar liggesusers# Copyright (c) 2019 - 2026, 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 `checkMV` <- function( expression, snames = "", noflevels = NULL, data = NULL, use.labels = FALSE, categories = list(), ... ) { curly <- any(grepl("[{]", expression)) if (length(unlist(gregexpr(ifelse(curly, "[{]+", "\\[+"), expression))) != length(unlist(gregexpr(ifelse(curly, "[}]+", "\\]+"), expression)))) { stopError("Incorrect expression, opened and closed brackets don't match.") } dots <- list(...) if (is.element("categorical", names(dots))) { use.labels <- dots$categorical dots$categorical <- NULL } tempexpr <- gsub("[*|,|;|(|)]", "", expression) pp <- trimstr(unlist(strsplit(tempexpr, split = "[+]"))) if (curly) { insb <- curlyBrackets(gsub("[*|(|)]", "", expression)) tempexpr <- curlyBrackets(tempexpr, outside = TRUE) } else { insb <- squareBrackets(gsub("[*|(|)]", "", expression)) tempexpr <- squareBrackets(tempexpr, outside = TRUE) } if (length(insb) != length(tempexpr)) { error <- TRUE if (use.labels) { tempexpr2 <- tempexpr[!is.element(tempexpr, names(unlist(unname(categories))))] error <- length(insb) != length(tempexpr2) } if (error) { stopError("Incorrect expression, some set names do not have brackets.") } } if (any(grepl("[a-zA-Z]", gsub("[,|;]", "", insb)))) { stopError("Invalid [multi]values, levels should be numeric.") } if (curly) { conds <- sort(unique(notilde(curlyBrackets(pp, outside = TRUE)))) } else { conds <- sort(unique(notilde(squareBrackets(pp, outside = TRUE)))) } if (is.null(data)) { if (is.null(noflevels)) { if (any(hastilde(expression))) { stopError("Negating a multivalue condition requires the number of levels.") } } else { if (identical(snames, "")) { stopError("Cannot verify the number of levels without the set names.") } snames <- splitstr(snames) if (is.character(noflevels)) { noflevels <- splitstr(noflevels) } if (length(noflevels) == 1 && is.numeric(noflevels) && length(snames) > 1) { noflevels <- rep(noflevels, length(snames)) } if (length(snames) != length(noflevels)) { stopError("Length of the set names differs from the length of the number of levels.") } for (i in seq(length(tempexpr))) { if (!is.element(notilde(tempexpr[i]), snames)) { stopError(sprintf("Condition %s not present in the set names.", tempexpr[i])) } if (max(asNumeric(splitstr(insb[i]))) > noflevels[match(notilde(tempexpr[i]), snames)] - 1) { stopError(sprintf("Levels outside the number of levels for condition %s.", tempexpr[i])) } } } } for (i in seq(length(expression))) { checkValid( expression = expression[i], snames = "something", data = data, categories = categories ) } } admisc/R/permutations.R0000644000176200001440000000416015161273642014600 0ustar liggesusers# Copyright (c) 2019 - 2026, 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. #' Calculates the permutations of a vector #' #' Generates all possible permutations of elements from a vector. #' #' @name permutations #' @rdname permutations #' @rawRd #' \usage{ #' permutations(x) #' } #' #' \arguments{ #' \item{x}{Any kind of vector.} #' } #' #' #' \author{ #' Adrian Dusa #' } #' #' \examples{ #' #' permutations(1:3) #' #' } #' #' \keyword{functions} NULL #' @export permutations <- function(x) { if (length(x) == 1) { return(x) } res <- matrix(nrow = 0, ncol = length(x)) for (i in seq_along(x)) { res <- rbind(res, cbind(x[i], Recall(x[-i]))) } return(res) } admisc/R/unload.R0000644000176200001440000000372015161273642013331 0ustar liggesusers# Copyright (c) 2019 - 2026, 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 `unload` <- function(package) { package <- recreate(substitute(package)) if (is.element(package, .packages())) { detach(paste("package", package, sep = ":"), character.only = TRUE, unload = TRUE, force = TRUE) unloadNamespace(package) } if (is.element(package, unlist(lapply(library.dynam(), "[[", 1)))) { library.dynam.unload(package, libpath = sub("/Meta.*", '', attr(packageDescription(package), "file"))) } } admisc/R/compute.R0000644000176200001440000001314315161273642013523 0ustar liggesusers# Copyright (c) 2019 - 2026, 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 #' @noRd `compute` <- function(expression = "", data = NULL, separate = FALSE, ...) { expression <- recreate(substitute(expression)) syscalls <- as.character(sys.calls()) usingwith <- "admisc::using\\(|using\\(|with\\(" if (is.null(data)) { if (any(usingdata <- grepl(usingwith, syscalls))) { dataname <- unlist(strsplit(gsub(usingwith, "", syscalls), split = ","))[1] data <- eval.parent(parse(text = dataname, n = 1)) } } if (!is.element(expression, colnames(data))) { if (exists(expression, envir = parent.frame())) { temp <- eval.parent(parse(text = expression, n = 1)) if (!is.function(temp)) { expression <- temp } } else if (grepl("\\$", expression)) { expression <- eval(parse(text = expression), envir = parent.frame()) } if (!is.atomic(expression) || length(expression) > 1 || !is.character(expression)) { stopError("The function compute() expects a single character string for an expression.") } } if (grepl("<-|<=|=>|->", expression)) { stopError("This function is not intended to calculate parameters of fit.") } enchar <- nchar(expression) if ( identical(substring(expression, 1, 2), "~(") & identical(substring(expression, enchar, enchar), ")") ) { expression <- paste0("1-", substring(expression, 3, enchar - 1)) } negated <- identical(unname(substring(expression, 1, 2)), "1-") expression <- gsub("1-", "", expression) if (is.null(data)) { colnms <- colnames( validateNames( notilde(expression), sort(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(sapply(data, length))) > 1) { stopError("Objects should be vectors of the same length.") } names(data) <- colnms data <- as.data.frame(data) } multivalue <- grepl("\\{|\\}|\\[|\\]", expression) if (!multivalue) { mvsop <- mvSOP(expression, data = data, ... = ...) ppm <- translate(mvsop, data = data, retlist = TRUE) rownames(ppm) <- trimstr(unlist(strsplit(expression, split = "\\+"))) } else { ppm <- translate(expression, data = data, retlist = TRUE) } 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] infodata <- getInfo(data) data <- infodata$data verify(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]) } nao <- na.omit(temp[, j]) if (any(abs(nao - round(nao)) >= .Machine$double.eps^0.5)) { if (length(val[[j]]) > 1) { stopError("Multiple values specified for fuzzy data.") } 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 <- apply(temp, 1, min, na.rm = FALSE) } tempList[[i]] <- temp } res <- as.data.frame(matrix(unlist(tempList), ncol = length(tempList))) colnames(res) <- rownames(ppm) if (ncol(res) > 1) { if (!separate) { res <- apply(res, 1, max, na.rm = FALSE) } } else { res <- as.vector(res[, 1]) } if (negated) res <- 1 - res return(res) } admisc/R/combnk.R0000644000176200001440000000746115161273642013326 0ustar liggesusers# Copyright (c) 2019 - 2026, 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. #' Generate all combinations of n numbers, taken k at a time #' #' A fast function to generate all possible combinations of n numbers, taken k at a time, #' starting from the first k numbers or starting from a combination that contain a #' certain number. #' #' @name combnk #' @rdname combnk #' @rawRd #' \usage{ #' combnk(n, k, ogte = 0, zerobased = FALSE) #' } #' #' \arguments{ #' \item{n}{Vector of any kind, or a numerical scalar.} #' \item{k}{Numeric scalar.} #' \item{ogte}{At least one value greater than or equal to this number.} #' \item{zerobased}{Logical, zero or one based.} #' } #' #' \details{ #' When a scalar, argument \code{n} should be numeric, otherwise when a vector its #' length should not be less than \code{k}. #' #' When the argument \bold{\code{ogte}} is specified, the combinations will sequentially #' be incremented from those which contain a certain number, or a certain position from #' \code{n} when specified as a vector. #' } #' #' #' \value{ #' A matrix with \code{k} rows and \code{choose(n, k)} columns. #' } #' #' \author{ #' Adrian Dusa #' } #' #' \examples{ #' combnk(5, 2) #' #' combnk(5, 2, ogte = 3) #' #' combnk(letters[1:5], 2) #' } #' #' \keyword{functions} NULL #' @export `combnk` <- function(n, k, ogte = 0, zerobased = FALSE) { if (!is.numeric(k)) { stopError("Argument k should be numeric.") } if (length(k) != 1L) { stopError("Argument k should be a scalar of length 1.") } if (k < 0) { stopError("Argument k should be positive.") } len <- length(n) lngt1 <- len > 1 if (lngt1) { if (len < k) { stopError("Argument k cannot be greater than the length of n.") } } else { if (!is.numeric(n)) { stopError("When scalar, argument n should be numeric.") } if (n < k) { stopError("Argument n should be greater than or equal to k.") } } copyn <- n if (lngt1) { n <- len } resmat <- .Call( "C_ombnk", list( n = as.integer(n), k = as.integer(k), ogte = as.integer(ogte), zerobased = as.integer(zerobased) ), PACKAGE = "admisc" ) if (lngt1) { resmat <- matrix(copyn[resmat], nrow = nrow(resmat)) } return(resmat) } admisc/R/sortExpressions.R0000644000176200001440000000402215161273642015275 0ustar liggesusers# Copyright (c) 2019 - 2026, 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 `sortExpressions` <- function(x) { if (is.matrix(x)) { mat <- x } else if (is.character(x)) { } for (i in rev(seq(ncol(mat)))) { mat <- mat[order(mat[, i], decreasing = TRUE), , drop = FALSE] if (length(wx <- which(mat[, i] > 0)) > 0) { rest <- if (max(wx) == nrow(mat)) NULL else seq(max(wx) + 1, nrow(mat)) mat <- mat[c(order(mat[wx, i]), rest), , drop = FALSE] } } return(mat[order(apply(mat, 1, function(x) sum(x > 0))), , drop = FALSE]) } admisc/R/intersection.R0000644000176200001440000002166115161273642014561 0ustar liggesusers# Copyright (c) 2019 - 2026, 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. #' Intersect expressions #' #' This function takes two or more SOP expressions (combinations of conjunctions and #' disjunctions) or even entire minimization objects, and finds their intersection. #' #' @name intersection #' @rdname intersection #' @rawRd #' \usage{ #' intersection(..., snames = "", noflevels) #' } #' #' \arguments{ #' \item{...}{One or more expressions, combined with / or minimization objects #' of class \code{"QCA_min"}.} #' \item{snames}{A string containing the sets' names, separated by commas.} #' \item{noflevels}{Numerical vector containing the number of levels for each set.} #' #' } #' #' \details{ #' The initial aim of this function was to provide a software implementation of the #' intersection examples presented by Ragin (1987: 144-147). That type of example can also #' be performed with the function \bold{\code{simplify()}}, while this #' function is now mainly used in conjunction with the \bold{\code{\link[QCA]{modelFit}()}} #' function from package \bold{\pkg{QCA}}, to assess the intersection between theory and a #' QCA model. #' #' Irrespective of the input type (character expressions and / or minimiation objects), #' this function is now a wrapper to the main \bold{\code{simplify()}} #' function (which only accepts character expressions). #' #' It can deal with any kind of expressions, but multivalent crisp conditions need additional #' information about their number of levels, via the argument \bold{\code{noflevels}}. #' #' The expressions can be formulated in terms of either lower case - upper case notation #' for the absence and the presence of the causal condition, or use the tilde notation #' (see examples below). Usage of either of these is automatically detected, as long as all #' expressions use the same notation. #' #' If the \bold{\code{snames}} argument is provided, the result is sorted according to the order #' of the causal conditions (set names) in the original dataset, otherwise it sorts the causal #' conditions in alphabetical order. #' #' For minimzation objects of class \code{"QCA_min"}, the number of levels, and the set names are #' automatically detected. #' } #' #' \author{ #' Adrian Dusa #' } #' #' #' \references{ #' Ragin, Charles C. 1987. \emph{The Comparative Method: Moving beyond Qualitative and #' Quantitative Strategies}. Berkeley: University of California Press. #' } #' #' #' \examples{ #' # using minimization objects #' \dontrun{ #' library(QCA) # if not already loaded #' ttLF <- truthTable(LF, outcome = "SURV", incl.cut = 0.8) #' pLF <- minimize(ttLF, include = "?") #' #' #' # for example the intersection between the parsimonious model and #' # a theoretical expectation #' intersection(pLF, DEV*STB) #' #' #' # negating the model #' intersection(negate(pLF), DEV*STB) #' } #' #' #' # ----- #' # in Ragin's (1987) book, the equation E = SG + LW is the result #' # of the Boolean minimization for the ethnic political mobilization. #' #' # intersecting the reactive ethnicity perspective (R = lw) #' # with the equation E (page 144) #' intersection(~L~W, SG + LW, snames = c(S, L, W, G)) #' #' #' # resources for size and wealth (C = SW) with E (page 145) #' intersection(SW, SG + LW, snames = c(S, L, W, G)) #' #' #' # and factorized #' factorize(intersection(SW, SG + LW, snames = c(S, L, W, G))) #' #' #' # developmental perspective (D = L~G) and E (page 146) #' intersection(L~G, SG + LW, snames = c(S, L, W, G)) #' #' #' # subnations that exhibit ethic political mobilization (E) but were #' # not hypothesized by any of the three theories (page 147) #' # ~H = ~(~L~W + SW + L~G) #' intersection(negate(~L~W + SW + L~G), SG + LW, snames = c(S, L, W, G)) #' } #' #' \keyword{functions} NULL #' @export `intersection` <- function(..., snames = "", noflevels = NULL) { dots <- substitute(list(...)) if (length(dots) > 1) { for (i in seq(2, length(dots))) { dots[[i]] <- recreate(dots[[i]]) } } dots <- eval(dots) snames <- recreate(substitute(snames)) if (length(dots) == 0) { stopError("Nothing to intersect.") } if (length(dots[[1]]) == 0) { return(invisible(character(0))) } snames <- splitstr(snames) sl <- ifelse(identical(snames, ""), FALSE, ifelse(all(nchar(snames) == 1), TRUE, FALSE)) isol <- NULL for (i in seq(length(dots))) { x <- dots[[i]] if (methods::is(dots[[i]], "QCA_min")) { if (identical(snames, "")) { snames <- dots[[i]]$tt$options$conditions if (dots[[i]]$options$use.letters) { snames <- LETTERS[seq(length(snames))] } } if (is.element("i.sol", names(x))) { elengths <- unlist(lapply(dots[[i]]$i.sol, function(x) length(x$solution))) isol <- paste(rep(names(dots[[i]]$i.sol), each = elengths), unlist(lapply(elengths, seq)), sep = "-") dots[[i]] <- as.vector(unlist(lapply(dots[[i]]$i.sol, function(x) { lapply(x$solution, paste, collapse = " + ") }))) } else { dots[[i]] <- as.vector(unlist(lapply(dots[[i]]$solution, paste, collapse = " + "))) } } else if (methods::is(dots[[i]], "admisc_deMorgan")) { isol <- attr(x, "isol") dots[[i]] <- unlist(x) if (!is.null(attr(x, "snames"))) { attr(dots[[i]], "snames") <- attr(x, "snames") } if (!is.null(attr(x, "isol"))) { attr(dots[[i]], "isol") <- attr(x, "isol") } attr(dots[[i]], "minimized") <- attr(x, "minimized") } if (!is.character(dots[[i]])) { stopError("Unrecognised input.") } } arglist <- list(snames = snames) if (!is.null(noflevels)) { arglist$noflevels <- noflevels } if (requireNamespace("QCA", quietly = TRUE)) { combs <- QCA::createMatrix(unlist(lapply(dots, length))) } else { combs <- getMatrix(unlist(lapply(dots, length))) } expressions <- result <- character(nrow(combs)) conj <- ifelse(sl, "", "*") for (i in seq(nrow(combs))) { x <- combs[i, ] + 1 expression <- c() for (j in seq(length(x))) { expression <- c(expression, dots[[j]][x[j]]) } disj <- grepl("[+]", expression) if (any(disj)) { expression[disj] <- paste("(", expression[disj], ")", sep = "") } if (any(!disj)) { ndisj <- which(!disj) if (any(ndisj == 1)) { expression[1] <- paste(expression[1], conj, sep = "") } if (any(ndisj == length(expression))) { expression[length(expression)] <- paste(conj, expression[length(expression)], sep = "") } if (length(ndisj <- setdiff(ndisj, c(1, length(expression)))) > 0) { expression[ndisj] <- paste(conj, expression[ndisj], conj, sep = "") } } expressions[i] <- paste(expression, collapse = "") expressions[i] <- gsub("\\*\\(", "(", expressions[i]) result[i] <- do.call(expandBrackets, c(list(expressions[i]), arglist)) } if (sl) { for (i in seq(length(expressions))) { result[i] <- gsub("[*]", "", result[i]) } } attr(result, "expressions") <- expressions if (!is.null(isol)) { attr(result, "isol") <- isol } class(result) <- c("character", "admisc_intersection") return(result) } admisc/R/checkValid.R0000644000176200001440000000502615161273642014105 0ustar liggesusers# Copyright (c) 2019 - 2026, 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 `checkValid` <- function( expression = "", snames = "", data = NULL, categories = list() ) { if (identical(snames, "")) { stopError("The expression cannot be verified without .") } allnames <- splitstr(snames) if (!is.null(data)) { allnames <- colnames(data) infodata <- getInfo(data) if (any(infodata$factor)) { allnames <- c(allnames, names(unlist(infodata$categories))) } } else if (length(categories) > 0) { allnames <- c(allnames, names(unlist(categories))) } allnames <- allnames[order(nchar(allnames), decreasing = TRUE)] for (n in allnames) { expression <- gsub(n, "", expression) } if (any(grepl(":alpha:", expression))) { stopError( sprintf( "Part(s) of the expression not found in the %s.", ifelse( is.null(data), " argument", "data" ) ) ) } } admisc/R/numdec.R0000644000176200001440000000623515161273642013326 0ustar liggesusers# Copyright (c) 2019 - 2026, 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. #' Count number of decimals #' #' Calculates the (maximum) number of decimals in a possibly numeric vector. #' #' @name numdec #' @rdname numdec #' @rawRd #' \usage{ #' numdec(x, each = FALSE, na.rm = TRUE, maxdec = 15) #' } #' #' \arguments{ #' \item{x}{A vector of values} #' \item{each}{Logical, return the result for each value in the vector} #' \item{na.rm}{Logical, ignore missing values} #' \item{maxdec}{Maximal number of decimals to count} #' } #' #' #' \author{ #' Adrian Dusa #' } #' #' \examples{ #' x <- c(12, 12.3, 12.34) #' #' numdec(x) # 2 #' #' numdec(x, each = TRUE) # 0, 1, 2 #' #' x <- c("-.1", " 2.75 ", "12", "B", NA) #' #' numdec(x) # 2 #' #' numdec(x, each = TRUE) # 1, 2, 0, NA, NA #' } #' #' #' \keyword{functions} NULL #' @export `numdec` <- function(x, each = FALSE, na.rm = TRUE, maxdec = 15) { maxdec <- min(15, maxdec) pN <- possibleNumeric(x, each = TRUE) if (sum(na.omit(pN)) == 0) { stopError("'x' should contain at least one (possibly) numeric value.") } if (is.character(x)) { x <- asNumeric(x) } result <- rep(NA, length(x)) wpN <- which(pN) x <- abs(x[wpN]) x <- x - floor(x) x <- sub("0\\.", "", sub("0+$", "", format(x, scientific = FALSE, digits = max(7, maxdec)) ) ) if (any(w9 <- grepl("999999", x))) { x[w9] <- sub( "0+", "1", sub("(*)999999.*", "\\1", x[w9]) ) } if (any(w0 <- grepl("000000", x))) { x[w0] <- sub("(*)000000.*", "\\1", x[w0]) } result[wpN] <- nchar(x) if (each) { return(pmin(result, maxdec)) } return(min(maxdec, max(result, na.rm = na.rm))) } admisc/R/tryCatchWEM.R0000644000176200001440000000711115161273642014177 0ustar liggesusers# Copyright (c) 2019 - 2026, 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. #' Try functions to capture warnings, errors and messages. #' #' This function combines the base functions \bold{\code{tryCatch}()} and #' \bold{\code{withCallingHandlers}()} for the specific purpose of capturing #' not only errors and warnings but messages as well. #' #' @name tryCatchWEM #' @rdname tryCatchWEM #' @rawRd #' \usage{ #' tryCatchWEM(expr, capture = FALSE) #' } #' #' #' #' #' #' #' \arguments{ #' \item{expr}{Expression to be evaluated.} #' \item{capture}{Logical, capture the visible output.} #' } #' #' \details{ #' In some situations it might be important not only to test a function, but also #' to capture everything that is written in the R console, be it an error, a warning #' or simply a message. #' #' For instance package \bold{\pkg{QCA}} (version 3.4) has a Graphical User Interface #' that simulates an R console embedded into a web based \bold{\pkg{shiny}} app. #' #' It is not intended to replace function \bold{\code{tryCatch}()} in any #' way, especially not evaluating an expression before returning or exiting, it simply #' captures everything that is printed on the console (the visible output). #' } #' #' #' \value{ #' A list, if anything would be printed on the screen, or an empty (NULL) object #' otherwise. #' } #' #' \author{ #' Adrian Dusa #' } #' #' \keyword{functions} NULL #' @export `tryCatchWEM` <- function(expr, capture = FALSE) { toreturn <- list() output <- withVisible(withCallingHandlers( tryCatch(expr, error = function(e) { toreturn$error <<- e$message NULL }), warning = function(w) { toreturn$warning <<- c(toreturn$warning, w$message) invokeRestart("muffleWarning") }, message = function(m) { toreturn$message <<- paste(toreturn$message, m$message, sep = "") invokeRestart("muffleMessage") } )) if (capture && output$visible && !is.null(output$value)) { toreturn$output <- capture.output(output$value) toreturn$value <- output$value } if (length(toreturn) > 0) { return(toreturn) } } admisc/R/frelevel.R0000755000176200001440000000543515161273642013663 0ustar liggesusers# Copyright (c) 2019 - 2026, 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. #' Modified \code{relevel()} function #' #' The base function \code{relevel()} accepts a single argument "ref", which #' can only be a scalar and not a vector of values. \code{frelevel()} accepts #' more (even all) levels and reorders them. #' #' @name frelevel #' @rdname frelevel #' @rawRd #' \usage{ #' frelevel(variable, levels) #' } #' #' \arguments{ #' \item{variable}{The categorical variable of interest} #' \item{levels}{One or more levels of the factor, in the desired order} #' } #' #' \value{A factor of the same length as the initial one.} #' #' \author{Adrian Dusa} #' #' \seealso{\code{\link[stats]{relevel}}} #' #' \examples{ #' words <- c("ini", "mini", "miny", "moe") #' variable <- factor(words, levels = words) #' #' # modify the order of the levels, keeping the order of the values #' frelevel(variable, c("moe", "ini", "miny", "mini")) #' #' } #' #' \keyword{functions} NULL #' @export `frelevel` <- function(variable, levels) { if (!is.factor(variable)) { stopError("The input variable is not a factor.") } if (any(!(levels %in% levels(variable)))) { stopError("One or more levels do not exist in the input variable.") } for (i in seq_len(length(levels))) { variable <- relevel(variable, ref = rev(levels)[i]) } return(variable) } admisc/R/sopos.R0000644000176200001440000001211415161273642013207 0ustar liggesusers# Copyright (c) 2019 - 2026, 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. `sopos` <- function(input, snames = "", noflevels = NULL) { if (!is.null(noflevels)) { noflevels <- splitstr(noflevels) } isol <- NULL input <- recreate(substitute(input)) snames <- recreate(substitute(snames)) minimized <- methods::is(input, "QCA_min") if (minimized) { snames <- input$tt$options$conditions star <- any(nchar(snames) > 1) if (input$options$use.letters) { snames <- LETTERS[seq(length(snames))] star <- FALSE } noflevels <- input$tt$noflevels if (is.element("i.sol", names(input))) { elengths <- unlist(lapply(input$i.sol, function(x) length(x$solution))) isol <- paste(rep(names(input$i.sol), each = elengths), unlist(lapply(elengths, seq)), sep = "-") input <- unlist(lapply(input$i.sol, function(x) { lapply(x$solution, paste, collapse = " + ") })) } else { input <- unlist(lapply(input$solution, paste, collapse = " + ")) } if (!star) { input <- gsub("[*]", "", input) } } if (methods::is(input, "admisc_deMorgan")) { input <- unlist(input) } if (!is.character(input)) { stopError("The expression should be a character vector.") } star <- any(grepl("[*]", input)) if (!identical(snames, "")) { snames <- splitstr(snames) if (any(nchar(snames) > 1)) { star <- TRUE } } mv <- any(grepl("\\{|\\}|\\[|\\]", input)) if (mv) start <- FALSE negateit <- function(x, snames = "", noflevels = NULL) { callist <- list(expression = x) if (!identical(snames, "")) callist$snames <- snames if (!is.null(noflevels)) callist$noflevels <- noflevels trexp <- do.call(translate, callist) snames <- colnames(trexp) if (is.null(noflevels)) { noflevels <- rep(2, ncol(trexp)) } snoflevels <- lapply(noflevels, function(x) seq(x) - 1) negated <- paste(apply(trexp, 1, function(x) { wx <- which(x != -1) x <- x[wx] nms <- names(x) x <- sapply(seq_along(x), function(i) { paste(setdiff(snoflevels[wx][[i]], splitstr(x[i])), collapse = ",") }) if (mv) { return(paste("(", paste(nms, "{", x, "}", sep = "", collapse = " + "), ")", sep = "")) } else { nms[x == 0] <- paste("~", nms[x == 0], sep = "") result <- paste(nms, collapse = " + ", sep = "") if (length(nms) > 1) { result <- paste("(", result, ")", sep = "") } return(result) } }), collapse = "*") return(negated) } result <- lapply(input, function(x) { if (grepl("\\(", x)) { xexp <- expandBrackets(x, snames = snames, noflevels = noflevels) if (!identical(xexp, gsub("\\(|\\)", "", x))) { return(xexp) } x <- xexp } return( paste( unlist(lapply(x, negateit, snames = snames, noflevels = noflevels)), collapse = " + " ) ) }) names(result) <- unname(input) if (!minimized) { attr(result, "expressions") <- input } if (!identical(snames, "")) { attr(result, "snames") <- snames } if (!is.null(isol)) { attr(result, "isol") <- isol } attr(result, "minimized") <- minimized return(classify(result, "admisc_deMorgan")) } admisc/R/stopError.R0000644000176200001440000000425215161273642014047 0ustar liggesusers# Copyright (c) 2019 - 2026, 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 `stopError` <- function(message, enter = "\n", ...) { dots <- list(...) message <- paste0( "Error: ", unlist( strsplit(message, split = "\\n") ) ) for (i in seq(length(message))) { message[i] <- gsub( "Error: ", ifelse(i > 1, " ", ""), paste( strwrap(message[i], exdent = 7), collapse = "\n" ) ) } if (!isFALSE(dots$prenter)) { cat(enter) } stop( simpleError( paste0( paste(message, collapse = "\n"), enter, enter ) ) ) } admisc/R/reload.R0000644000176200001440000000361515161273642013320 0ustar liggesusers# Copyright (c) 2019 - 2026, 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 `reload` <- function(package, silent = TRUE) { package <- as.character(substitute(package)) unload(package) if (is.element(package, rownames(installed.packages()))) { if (silent) { eval(parse(text = paste("suppressMessages(library(", package, "))"))) } else { eval(parse(text = paste("library(", package, ")"))) } } } admisc/R/writePIs.R0000755000176200001440000000664015161273642013624 0ustar liggesusers# Copyright (c) 2019 - 2026, 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 `writePIs` <- function( impmat, mv = FALSE, collapse = "*", snames = "", curly = FALSE, use.labels = FALSE, categories = list(), ... ) { if (any(impmat > 2)) { mv <- TRUE } dots <- list(...) if (is.element("categorical", names(dots))) { use.labels <- dots$categorical dots$categorical <- NULL } if (identical(snames, "")) { snames <- colnames(impmat) } else { impmat <- t(impmat) } chars <- matrix(snames[col(impmat)], nrow = nrow(impmat)) if (mv) { chars <- matrix( paste( chars, ifelse(curly, "{", "["), impmat - 1, ifelse(curly, "}", "]"), sep = "" ), nrow = nrow(impmat) ) if (use.labels && length(categories) > 0) { fnames <- names(categories) for (i in seq(length(categories))) { values <- impmat[, fnames[i]] pos <- nrow(impmat) * (which(snames == fnames[i]) - 1) + 1 pos <- seq(pos, pos + length(values) - 1)[values > 0] chars[pos] <- categories[[i]][values[values > 0]] } } } else { chars <- ifelse(impmat == 1L, paste0("~", chars), chars) if (use.labels && length(categories) > 0) { fnames <- names(categories) for (i in seq(length(categories))) { values <- impmat[, fnames[i]] chars[values > 0, fnames[i]] <- categories[[i]][values[values > 0]] } } } keep <- impmat > 0L return( as.vector( unlist( lapply( split(chars[keep], row(chars)[keep]), paste, collapse = collapse ) ) ) ) } #' @export `writePrimeimp` <- function(...) { writePIs(...) } admisc/R/frev.R0000755000176200001440000000526415161273642013021 0ustar liggesusers# Copyright (c) 2019 - 2026, 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. #' Inverts the values of a factor #' #' Provides a reversed version of the values from a factor, for instance #' a Likert type response scale. #' #' @name frev #' @rdname frev #' @aliases finvert #' @rawRd #' \usage{ #' frev(x, labels = FALSE) #' } #' #' \arguments{ #' \item{x}{A factor} #' \item{labels}{Logical, invert the labels as well} #' } #' #' \details{ #' The argument \code{labels} can also be used for the levels of a factor. #' } #' #' \value{A factor of the same length as the original one.} #' #' \author{Adrian Dusa} #' #' \examples{ #' words <- c("ini", "mini", "miny", "moe") #' variable <- factor(words, labels = words) #' #' # inverts the values, preserving the labels' order #' frev(variable) #' #' # inverts both values and labels #' frev(variable, labels = TRUE) #' #' } #' #' \keyword{misc} NULL #' @export `frev` <- function(x, labels = FALSE) { if (!is.factor(x)) { stopError("The variable is not a factor.") } flist <- list(levels(x), rev(levels(x))) return(factor(x, levels = flist[[1 + !labels]], labels = flist[[1 + labels]])) } `finvert` <- function(...) { .Deprecated(msg = "Function finvert() is deprecated, use frev().\n") frev(...) } admisc/R/recode.R0000644000176200001440000005023015161273642013306 0ustar liggesusers# Copyright (c) 2019 - 2026, 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. #' Recode a variable #' #' Recodes a vector (numeric, character or factor) according to a set of rules. #' It is similar to the function \bold{\code{recode}()} from package \pkg{car}, #' but more flexible. It also has similarities with the function #' \bold{\code{\link[base]{findInterval}()}} from package \bold{\pkg{base}}. #' #' @name recode #' @rdname recode #' @rawRd #' \usage{ #' recode(x, rules = NULL, cut = NULL, values = NULL, ...) #' } #' #' \arguments{ #' \item{x}{A vector of mode numeric, character or factor.} #' \item{rules}{Character string or a vector of character strings #' for recoding specifications.} #' \item{cut}{A vector of one or more unique cut points.} #' \item{values}{A vector of output values.} #' \item{...}{Other parameters, for compatibility with other functions such as #' \bold{\code{recode}()} in package \pkg{car} but also #' \bold{\code{\link[base]{factor}()}} in package \bold{\pkg{base}}} #' } #' #' \details{ #' Similar to the \bold{\code{recode()}} function in package \pkg{car}, the #' recoding rules are separated by semicolons, of the form \bold{\code{input = output}}, #' and allow for: #' #' #' \tabular{rl}{ #' a single value \tab \bold{\code{1 = 0}}\cr #' a range of values \tab \bold{\code{2:5 = 1}}\cr #' a set of values \tab \bold{\code{c(6,7,10) = 2}}\cr #' \bold{\code{else}} \tab everything that is not covered by the previously specified rules #' } #' #' Contrary to the \bold{\code{recode}()} function in package \pkg{car}, this #' function allows the \bold{\code{:}} sequence operator (even for factors), so #' that a rule such as \bold{\code{c(1,3,5:7)}}, or \bold{\code{c(a,d,f:h)}} would #' be valid. #' #' Actually, since all rules are specified in a string, it really doesn't matter #' if the \bold{\code{c()}} function is used or not. For compatibility reasons it #' accepts it, but a more simple way to specify a set of rules is #' \bold{\code{"1,3,5:7=A; else=B"}} #' #' Special values \bold{\code{lo}} and \bold{\code{hi}} may also appear in the #' range of values, while \bold{\code{else}} can be used with \bold{\code{else=copy}} #' to copy all values which were not specified in the recoding rules. #' #' In the package \pkg{car}, a character \bold{\code{output}} would have to be quoted, #' like \bold{\code{"1:2='A'"}} but that is not mandatory in this function, \bold{\code{"1:2=A"}} #' would do just as well. Output values such as \bold{\code{"NA"}} or \bold{\code{"missing"}} #' are converted to \bold{\code{NA}}. #' #' Another difference from the \pkg{car} package: the output is \bold{not} automatically #' converted to a factor even if the original variable is a factor. That option is left to the #' user's decision to specify \bold{\code{as.factor.result}}, defaulted to \bold{\code{FALSE}}. #' #' A capital difference is the treatment of the values not present in the recoding rules. By #' default, package \pkg{car} copies all those values in the new object, whereas in this #' package the default values are \bold{\code{NA}} and new values are added only if they are #' found in the rules. Users can choose to copy all other values not present in the recoding #' rules, by specifically adding \bold{\code{else=copy}} in the rules. #' #' Since the two functions have the same name, it is possible that users loading both #' packages to use one instead of the other (depending which package is loaded first). #' In order to preserve functionality and minimize possible namespace collisions with package #' \pkg{car}, special efforts have been invested to ensure perfect compatibility with #' the other \bold{\code{recode}()} function (plus more). #' #' The argument \bold{\code{...}} allows for more arguments specific to the \pkg{car} package, #' such as \bold{\code{as.factor.result}}, \bold{\code{as.numeric.result}}. In addition, it also #' accepts \bold{\code{levels}}, \bold{\code{labels}} and \bold{\code{ordered}} specific to function #' \bold{\code{\link[base]{factor}()}} in package \bold{\pkg{base}}. When using the arguments #' \bold{\code{levels}} and / or \bold{\code{labels}}, the output will automatically be coerced #' to a factor, unless the argument \bold{\code{values}} is used, as indicated below. #' #' Blank spaces outside category labels are ignored, see the last example. #' #' It is possible to use \bold{\code{recode()}} in a similar way to function #' \bold{\code{cut()}}, by specifying a vector of cut points. For any number of #' such \bold{\code{c}} cut ploints, there should be \bold{\code{c + 1}} values. #' If not otherwise specified, the argument \bold{\code{values}} is automatically #' constructed as a sequence of numbers from \bold{\code{1}} to \bold{\code{c + 1}}. #' #' Unlike the function \bold{\code{cut()}}, arguments such as #' \bold{\code{include.lowest}} or \bold{\code{right}} are not necessary because #' the final outcome can be changed by tweaking the cut values. #' #' If both arguments \bold{\code{values}} and \bold{\code{labels}} are provided, #' the labels are going to be stored as an attribute. #' } #' #' \author{ #' Adrian Dusa #' } #' #' \examples{ #' x <- rep(1:3, 3) #' # [1] 1 2 3 1 2 3 1 2 3 #' #' recode(x, "1:2 = A; else = B") #' # [1] "A" "A" "B" "A" "A" "B" "A" "A" "B" #' #' recode(x, "1:2 = 0; else = copy") #' # [1] 0 0 3 0 0 3 0 0 3 #' #' #' set.seed(1234) #' x <- sample(18:90, 20, replace = TRUE) #' # [1] 45 39 26 22 55 33 21 87 31 73 79 21 21 38 57 73 84 22 83 64 #' #' recode(x, cut = "35, 55") #' # [1] 2 2 1 1 2 1 1 3 1 3 3 1 1 2 3 3 3 1 3 3 #' #' set.seed(1234) #' x <- factor(sample(letters[1:10], 20, replace = TRUE), #' levels = letters[1:10]) #' # [1] j f e i e f d b g f j f d h d d e h d h #' # Levels: a b c d e f g h i j #' #' recode(x, "b:d = 1; g:hi = 2; else = NA") # note the "hi" special value #' # [1] 2 NA NA 2 NA NA 1 1 2 NA 2 NA 1 2 1 1 NA 2 1 2 #' #' recode(x, "a, c:f = A; g:hi = B; else = C", labels = "A, B, C") #' # [1] B A A B A A A C B A B A A B A A A B A B #' # Levels: A B C #' #' recode(x, "a, c:f = 1; g:hi = 2; else = 3", #' labels = c("one", "two", "three"), ordered = TRUE) #' # [1] two one one two one one one three two one #' # [11] two one one two one one one two one two #' # Levels: one < two < three #' #' set.seed(1234) #' categories <- c("An", "example", "that has", "spaces") #' x <- factor(sample(categories, 20, replace = TRUE), #' levels = categories, ordered = TRUE) #' sort(x) #' # [1] An An An example example example example #' # [8] example example example example that has that has that has #' # [15] spaces spaces spaces spaces spaces spaces #' # Levels: An < example < that has < spaces #' #' recode(sort(x), "An : that has = 1; spaces = 2") #' # [1] 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 #' #' # single quotes work, but are not necessary #' recode(sort(x), "An : 'that has' = 1; spaces = 2") #' # [1] 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 #' #' # same using cut values #' recode(sort(x), cut = "that has") #' # [1] 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 #' #' # modifying the output values #' recode(sort(x), cut = "that has", values = 0:1) #' # [1] 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 #' #' # more treatment of "else" values #' x <- 10:20 #' #' # recoding rules don't overlap all existing values, the rest are empty #' recode(x, "8:15 = 1") #' # [1] 1 1 1 1 1 1 NA NA NA NA NA #' #' # all other values copied #' recode(x, "8:15 = 1; else = copy") #' # [1] 1 1 1 1 1 1 16 17 18 19 20 #' #' } #' #' \keyword{functions} NULL #' @export `recode` <- function(x, rules = NULL, cut = NULL, values = NULL, ...) { UseMethod("recode") } #' @export `recode.declared` <- function(x, rules = NULL, cut = NULL, values = NULL, ...) { dots <- list(...) na_index <- attr(x, "na_index") na_values <- attr(x, "na_values") na_range <- attr(x, "na_range") xlabels <- attr(x, "labels", exact = TRUE) attributes(x) <- NULL labels <- splitstr(dots[["labels"]]) label <- dots[["label"]] x <- recode(x = x, rules = rules, cut = cut, values = values) if (is.null(names(labels))) { values <- sort(unique(x)) if (!is.null(labels)) { if (length(values) == length(labels)) { names(values) <- labels labels <- values } else { stopError("The number of labels should be equal to the number of recodings.") } } } if (is.null(na_index)) { xlabels <- NULL } else { attr(x, "na_index") <- na_index attr(x, "na_values") <- na_values attr(x, "na_range") <- na_range } if (!is.null(xlabels)) { if (!is.null(na_values)) { xlabels <- xlabels[is.element(xlabels, na_values)] } else if (!is.null(na_range)) { xlabels <- xlabels[xlabels >= na_range[1] & xlabels <= na_range[2]] } } attr(x, "labels") <- c(labels, xlabels) attr(x, "label") <- label class(x) <- c("declared", class(x)) return(x) } #' @export `recode.default` <- function(x, rules = NULL, cut = NULL, values = NULL, ...) { if (missing(x)) { stopError("Argument 'x' is missing.") } if (!is.atomic(x)) { stopError("The input 'x' should be an atomic vector / factor.") } if (all(is.na(x))) { stopError("Nothing to recode, all values are missing.") } dots <- recreate(list(...)) as.factor.result <- isTRUE(dots$as.factor.result) as.numeric.result <- !isFALSE(dots$as.numeric.result) factor.levels <- splitstr(dots$levels) factor.labels <- splitstr(dots[["labels"]]) factor.ordered <- FALSE if (is.element("ordered", names(dots))) { factor.ordered <- dots$ordered } else if (is.element("ordered_result", names(dots))) { factor.ordered <- dots$ordered_result } if (is.element("cuts", names(dots)) & missing(cut)) { cut <- dots[["cuts"]] } if (is.logical(factor.labels)) { factor.labels <- character(0) } if (!is.null(factor.levels) || !is.null(factor.labels)) { as.factor.result <- TRUE } `getFromRange` <- function(a, b, uniques, xisnumeric) { copya <- a copyb <- b a <- ifelse(a == "lo", uniques[1], a) b <- ifelse(b == "hi", uniques[length(uniques)], b) if (xisnumeric) { a <- asNumeric(a) b <- asNumeric(b) if (a > b & (copya == "lo" | copyb == "hi")) return(NULL) } seqfrom <- which(uniques == a) seqto <- which(uniques == b) temp2 <- sort(unique(c(uniques, a, b))) if (length(seqfrom) == 0) { seqfrom <- which(uniques == temp2[which(temp2 == a) + 1]) } if (length(seqto) == 0) { seqto <- which(uniques == temp2[which(temp2 == b) - 1]) } if (length(c(seqfrom, seqto)) < 2) return(NULL) return(seq(seqfrom, seqto)) } if (is.null(cut)) { if (is.null(rules)) { stopError("At least one argument 'rules' or 'cut' should be provided.") } rules <- gsub( "\n|\t", "", gsub( "'", "", gsub( ")", "", gsub( "c(", "", rules, fixed = TRUE ) ) ) ) if (length(rules) == 1) { semicolons <- gsub("[^;]", "", rules) equals <- gsub("[^=]", "", rules) if (nchar(equals) != nchar(semicolons) + 1) { stopError("The rules should be separated by a semicolon.") } rules <- unlist(strsplit(rules, split = ";")) } rulsplit <- strsplit(rules, split = "=") oldval <- trimws(sapply(rulsplit, "[", 1)) newval <- trimws(sapply(rulsplit, "[", 2)) if (!is.null(factor.labels)) { if (length(factor.labels) != length(newval)) { stopError("The number of labels should be equal to the number of recodings.") } } temp <- rep(NA, length(x)) elsecopy <- oldval == "else" & newval == "copy" if (any(elsecopy)) { if (is.factor(x)) { temp <- as.character(x) } else { temp <- x } newval <- newval[!elsecopy] oldval <- oldval[!elsecopy] } newval[newval == "missing" | newval == "NA"] <- NA if (any(oldval == "else")) { if (sum(oldval == "else") > 1) { stopError("Too many \"else\" statements.") } whichelse <- which(oldval == "else") oldval <- c(oldval[-whichelse], oldval[whichelse]) newval <- c(newval[-whichelse], newval[whichelse]) } oldval <- lapply( lapply( lapply(oldval, strsplit, split = ","), "[[", 1 ), function(y) { lapply( strsplit(y, split = ":"), trimstr ) } ) newval <- trimstr(rep(newval, unlist(lapply(oldval, length)))) if (any(unlist(lapply(oldval, function(y) lapply(y, length))) > 2)) { stopError("Too many : sequence operators.") } from <- unlist(lapply(oldval, function(y) lapply(y, "[", 1))) to <- unlist(lapply(oldval, function(y) lapply(y, "[", 2))) uniques <- if(is.factor(x)) levels(x) else sort(unique(x[!is.na(x)])) recoded <- NULL xisnumeric <- possibleNumeric(uniques) if (xisnumeric) { x <- asNumeric(x) uniques <- asNumeric(uniques) } for (i in seq(length(from))) { if (!is.na(to[i])) { torecode <- getFromRange(from[i], to[i], uniques, xisnumeric) if (!is.null(torecode)) { vals <- uniques[torecode] temp[is.element(x, vals)] <- newval[i] recoded <- c(recoded, vals) } } else { if (from[i] == "else") { temp[!is.element(x, recoded)] <- newval[i] } else if (from[i] == "missing" | from[i] == "NA") { temp[is.na(x)] <- newval[i] } else { temp[x == from[i]] <- newval[i] } recoded <- c(recoded, from[i]) } } } else { if (length(cut) == 1 & is.character(cut)) { cut <- gsub( "\n|\t", "", gsub( "'", "", gsub( ")", "", gsub( "c(", "", cut, fixed = TRUE ) ) ) ) cut <- trimstr(unlist(strsplit(cut, split = ","))) if (length(cut) == 1) { cut <- trimstr(unlist(strsplit(cut, split = ";"))) } } if (possibleNumeric(cut)) { cut <- asNumeric(cut) } if (any(duplicated(cut))) { stopError("Cut values should be unique.") } if (is.null(values)) { values <- seq(length(cut) + 1) } else { if (length(values) == 1 & is.character(values)) { values <- gsub( "\n|\t", "", gsub( "'", "", gsub( ")", "", gsub( "c(", "", values, fixed = TRUE ) ) ) ) values <- trimstr(unlist(strsplit(values, split = ","))) if (length(values) == 1) { values <- trimstr(unlist(strsplit(values, split = ";"))) } } if (length(values) == length(cut) + 1) { as.numeric.result <- possibleNumeric(values) if (as.numeric.result) { values <- asNumeric(values) } } else { stopError( paste0( "There should be ", length(cut) + 1, " values for ", length(cut), " cut value", ifelse(length(cut) == 1, "", "s"), "." ) ) } } if (!is.null(factor.labels)) { if (length(factor.labels) != length(values)) { stopError("The number of labels should be equal to the number of recodings.") } } if (is.factor(x)) { lx <- levels(x) minx <- lx[1] maxx <- lx[length(lx)] if (is.numeric(cut)) { insidex <- FALSE } else { insidex <- all(is.element(cut, lx)) } } else { if (is.character(x) & is.numeric(cut)) { insidex <- FALSE } else if (is.character(x) & is.character(cut)) { insidex <- is.element(cut, x[!is.na(x)]) } else { insidex <- cut >= min(x, na.rm = TRUE) & cut <= max(x, na.rm = TRUE) } } if (!all(insidex)) { message <- "Cut value(s) outside the input vector." stopError(message) } if (is.factor(x)) { nx <- as.numeric(x) nlx <- seq(length(lx)) nc <- match(cut, lx) temp <- rep(values[1], length(x)) for (i in seq(length(cut))) { temp[nx > nc[i]] = values[i + 1] } } else { nax <- which(is.na(x)) temp <- rep(values[1], length(x)) for (i in seq(length(cut))) { temp[x > cut[i]] = values[i + 1] } if (length(nax) > 0) { temp[nax] <- NA } } if (!is.null(factor.labels) && length(factor.labels) == 0 && is.numeric(cut)) { factor.labels <- values } } if (as.factor.result) { if (length(factor.levels) == 0) { factor.levels <- sort(unique(na.omit(temp))) } if (!is.null(factor.labels) && length(factor.labels) == 0) { factor.labels <- factor.levels } temp <- factor( temp, levels = factor.levels, labels = factor.labels, ordered = factor.ordered ) } else if (as.numeric.result) { if (possibleNumeric(temp)) { temp <- asNumeric(temp) } if (!is.null(factor.labels)) { names(values) <- factor.labels attr(temp, "labels") <- values } } return(temp) } admisc/R/admisc_package.R0000644000176200001440000000577115161273642014772 0ustar liggesusers# Copyright (c) 2019 - 2026, 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. #' @keywords internal #' "_PACKAGE" #' #' @name admisc_package #' @aliases admisc-package #' #' @title Adrian Dusa's Miscellaneous #' #' @description Contains functions used across packages 'DDIwR', 'QCA' and 'venn'. #' Interprets and translates, factorizes and negates SOP - Sum of Products #' expressions, for both binary and multi-value crisp sets, and extracts #' information (set names, set values) from those expressions. Other functions #' perform various checks if possibly numeric (even if all numbers reside in a #' character vector) and coerce to numeric, or check if the numbers are whole. It #' also offers, among many others, a highly versatile recoding routine and some #' more flexible alternatives to the base functions `with()` and `within()`. #' SOP simplification functions in this package use related minimization from #' package **QCA**, which is recommended to be installed despite not being listed #' in the Imports field, due to circular dependency issues. #' #' @author Adrian Dusa #' #' Maintainer: Adrian Dusa (dusa.adrian@unibuc.ro) #' #' @details #' \tabular{ll}{ #' Package: \tab admisc\cr #' Type: \tab Package\cr #' Version: \tab 0.40\cr #' Date: \tab 2026-03-26\cr #' License: \tab GPL (>= 3)\cr #' } #' #' @importFrom utils read.csv write.csv write.table capture.output installed.packages packageDescription compareVersion remove.packages tail #' @importFrom stats na.omit dist relevel #' @importFrom methods is #' @importFrom grDevices hcl #' @useDynLib admisc, .registration = TRUE NULL admisc/R/tagged.R0000644000176200001440000000525215161273642013304 0ustar liggesusers# Copyright (c) 2019 - 2026, 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 `makeTag` <- function(...) { x <- as.character(c(...)) x <- .Call("_tag", x, PACKAGE = "admisc") class(x) <- "double" return(x) } #' @export `hasTag` <- function(x, tag = NULL) { if (!is.double(x)) { return(logical(length(x))) } if (!is.null(tag) && (!is.atomic(tag) || length(tag) > 1 || is.na(tag))) { stopError("`tag` should be a vector of length 1.") } if (!is.null(tag)) { tag <- as.character(tag) } return(.Call("_has_tag", x, tag, PACKAGE = "admisc")) } #' @export `getTag` <- function(x) { if (is.double(x)) { x <- .Call("_get_tag", x, PACKAGE = "admisc") if (!any(is.na(suppressWarnings(as.numeric(na.omit(x)))))) { x <- as.numeric(x) } return(x) } else { return(rep(NA, length(x))) } } #' @export `anyTagged` <- function(x) { if (is.data.frame(x)) { i <- 1 tagged <- FALSE while(!tagged & i <= ncol(x)) { tagged <- Recall(x[[i]]) i <- i + 1 } return(tagged) } if (is.double(x)) { return(.Call("_any_tagged", x, PACKAGE = "admisc")) } return(FALSE) } admisc/R/admisc_internal.R0000644000176200001440000000516415161273642015207 0ustar liggesusers# Copyright (c) 2019 - 2026, 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. #' admisc internal functions #' #' Functions to be used internally in package `admisc`. #' #' @name admisc_internal #' @aliases anyTagged #' @aliases checkMV #' @aliases checkSubset #' @aliases classify #' @aliases dashes #' @aliases doublequotes #' @aliases expandBrackets #' @aliases getInfo #' @aliases getLevels #' @aliases getMatrix #' @aliases getNonChars #' @aliases getTag #' @aliases hasTag #' @aliases makeTag #' @aliases negateLoop #' @aliases padLeft #' @aliases padRight #' @aliases padBoth #' @aliases prettyString #' @aliases prettyTable #' @aliases reload #' @aliases removeSingleStars #' @aliases splitMainComponents #' @aliases splitstr #' @aliases splitBrackets #' @aliases splitPluses #' @aliases splitProducts #' @aliases splitStars #' @aliases splitTildas #' @aliases solveBrackets #' @aliases sortExpressions #' @aliases simplifyList #' @aliases singlequotes #' @aliases spaces #' @aliases stopError #' @aliases tildae #' @aliases trimstr #' @aliases uninstall #' @aliases unload #' @aliases checkValid #' @aliases validateNames #' @aliases verify #' @aliases writePIs #' @aliases writePrimeimp #' @keywords internal NULL admisc/R/getMatrix.R0000755000176200001440000000457415161273642014026 0ustar liggesusers# Copyright (c) 2019 - 2026, 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 `getMatrix` <- function(noflevels, depth = 0) { nofconds <- length(noflevels) pwr <- unique(noflevels) if (length(pwr) == 1) { create <- function(idx) { rep.int(c(sapply(seq_len(pwr) - 1, function(x) rep.int(x, pwr^(idx - 1)))), pwr^nofconds/pwr^idx) } retmat <- sapply(rev(seq_len(nofconds)), create) } else { mbase <- c(rev(cumprod(rev(noflevels))), 1)[-1] orep <- cumprod(rev(c(rev(noflevels)[-1], 1))) retmat <- sapply(seq_len(nofconds), function(x) { rep.int(rep.int(seq_len(noflevels[x]) - 1, rep.int(mbase[x], noflevels[x])), orep[x]) }) } if (is.vector(retmat)) { retmat <- matrix(retmat, nrow = 1) } if (depth > 0) { retmat <- retmat[apply(retmat, 1, function(x) sum(x > 0) <= depth ), , drop = FALSE] } return(retmat) } admisc/R/scan.clipboard.R0000644000176200001440000000514215161273642014731 0ustar liggesusers# Copyright (c) 2019 - 2026, 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. #' Cross platform scan/write clipboard #' #' Functions to read and write to the system's clipboard, for copy/paste operations. #' #' @name scan.clipboard #' @rdname clipboard #' @aliases write.clipboard #' @rawRd #' \usage{ #' scan.clipboard(...) #' write.clipboard(x) #' } #' #' \arguments{ #' \item{x}{Object to be written to the clipboard} #' \item{...}{Same arguments that are used in the base function \bold{\code{scan}}} #' } #' #' #' \author{ #' Adrian Dusa #' } #' #' \keyword{functions} NULL #' @export scan.clipboard <- function (...) { dots <- list(...) if (Sys.info()[['sysname']] == "Darwin") { clipboard <- readLines(textConnection(system("pbpaste", intern = TRUE))) sep <- ifelse(is.null(dots$sep), "\t", dots$sep) clipboard <- unlist(strsplit(clipboard, split = sep)) } else if (Sys.info()[['sysname']] == "Windows") { dots$file <- "clipboard" clipboard <- do.call("scan", dots) } clipboard <- clipboard[clipboard != ""] if (possibleNumeric(clipboard)) { return(asNumeric(clipboard)) } else { return(clipboard) } } admisc/R/recreate.R0000644000176200001440000002045215161273642013642 0ustar liggesusers# Copyright (c) 2019 - 2026, 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. #' Facilitate expression substitution #' #' Utility function based on \code{substitute()}, to recover an unquoted input. #' #' @name recreate #' @rdname recreate #' @rawRd #' \usage{ #' recreate(x, snames = NULL, ...) #' } #' #' \arguments{ #' \item{x}{A substituted input.} #' \item{snames}{A character string containing set names.} #' \item{...}{Other arguments, mainly for internal use.} #' } #' #' \details{ #' This function is especially useful when users have to provide lots of quoted #' inputs, such as the name of the columns from a data frame to be considered #' for a particular function. #' #' This is actually one of the main uses of the base function #' \bold{\code{\link[base]{substitute}()}}, but here it can be employed to also #' detect SOP (sum of products) expressions, explained for instance in function #' \bold{\code{\link{translate}()}}. #' #' Such SOP expressions are usually used in contexts of sufficieny and necessity, #' which are indicated with the usual signs \code{->} and \code{<-}. These are #' both allowed by the R parser, indicating standard assignment. Due to the R's #' internal parsing system, a sufficient expression using \code{->} is automatically #' flipped to a necessity statement \code{<-} with reversed LHS to RHS, but this #' function is able to determine what is the expression and what is the output. #' #' The other necessity code \code{<=} is also recognized, but the equivalent #' sufficiency code \code{=>} is not allowed in unquoted expressions. #' } #' #' \value{ #' A quoted, equivalent expression or a substituted object. #' } #' #' \author{ #' Adrian Dusa #' } #' #' \seealso{\code{\link[base]{substitute}}, \code{\link{simplify}}} #' #' \examples{ #' recreate(substitute(A + ~B*C)) #' #' foo <- function(x, ...) recreate(substitute(list(...))) #' #' foo(arg1 = 3, arg2 = A + ~B*C) #' #' df <- data.frame(A = 1, B = 2, C = 3, Y = 4) #' #' # substitute from the global environment #' # the result is the builtin C() function #' res <- recreate(substitute(C)) #' #' is.function(res) # TRUE #' #' # search first within the column name space from df #' recreate(substitute(C), colnames(df)) #' # "C" #' #' # necessity well recognized #' recreate(substitute(A <- B)) #' #' # but sufficiency is flipped #' recreate(substitute(A -> B)) #' #' # more complex SOP expressions are still recovered #' recreate(substitute(A + ~B*C -> Y)) #' } #' #' \keyword{functions} NULL #' @export `recreate` <- function(x, snames = NULL, ...) { if (is.null(x) | is.logical(x) | is.character(x) | is.list(x)) return(x) withinobj <- function(x) { x <- gsub("\"|[[:space:]]", "", x) for (i in seq(length(x))) { if (!grepl("<-|->", x[i])) { x[i] <- gsub(">|=>|-\\.>", "->", gsub("<|<=|<\\.-", "<-", x[i])) } arrows <- c("<-", "->") found <- sapply(arrows, grepl, x[i]) if (sum(found) > 0) { if (sum(found) > 1) { stopError("Ambiguous expression, more than one relation sign.") } xs <- unlist(strsplit(x[i], split = arrows[found])) if (length(xs) == 2) { if (all(grepl("\\*|\\+", xs))) { stopError("The outcome should be a single condition.") } if ( ( ( grepl("\\*|\\+", xs[2]) & !grepl("\\*|\\+", xs[1]) ) | ( grepl("~", ifelse(tilde1st(xs[2]), substring(xs[2], 2), xs[2])) & !grepl("~", ifelse(tilde1st(xs[1]), substring(xs[1], 2), xs[1])) ) ) & which(found) == 1 ) { x[i] <- paste(rev(xs), collapse = "->") } } } } return(x) } typev <- typel <- FALSE callx <- identical(class(x), "call") dx <- deparse(x) if (is.character(dx) && length(dx) == 2 && dx[1] == "~") { dx <- paste(dx, collapse = "") } if (callx) { typev <- is.name(x[[1]]) & identical(as.character(x[[1]]), "c") typel <- is.name(x[[1]]) & identical(as.character(x[[1]]), "list") } if (callx & (typev | typel)) { result <- dxlist <- vector(mode = "list", length = max(1, length(x) - 1)) if (length(x) == 1) { if (typev) return(NULL) if (typel) return(list()) } if (typev) { if (length(snames) > 0) { dx <- as.character(x)[-1] if (all(is.element(dx, snames))) { return(dx) } } } for (i in seq(length(result))) { dxlist[[i]] <- dx <- deparse(x[[i + 1]]) result[[i]] <- tryCatch(eval(x[[i + 1]], envir = parent.frame(n = 2)), error = function(e) { withinobj(dx) }) if (length(snames) > 0) { if (all(is.element(dx, snames))) { result[[i]] <- dx } } } classes <- unlist(lapply(result, class)) if (length(unique(classes)) > 1) { for (i in seq(length(result))) { if (identical(classes[i], "formula") | (identical(classes[i], "function") & typev)) { result[[i]] <- withinobj(dxlist[[i]]) } if (identical(classes[i], "logical") & typev & nchar(dxlist[[i]] == 1)) { result[[i]] <- withinobj(dxlist[[i]]) } if (identical(classes[i], "list")) { if (is.element("function", unlist(lapply(result[[i]], class)))) { result[[i]] <- dxlist[[i]] } } } } if (typev) { return(unlist(result)) } else if (typel) { names(result) <- names(x[-1]) return(result) } } if (length(snames) > 0 & all(!grepl("[[:punct:]]", notilde(dx)))) { if (all(is.element(notilde(dx), snames))) { return(dx) } } if (identical(class(x), "<-")) { return(withinobj(dx)) } ntdx <- dx negated <- all(tilde1st(dx) & !grepl("\\+|\\*", dx)) if (negated) { ntdx <- notilde(dx) } x <- tryCatch( eval( parse(text = ntdx), envir = parent.frame(n = 2) ), error = function(e) { withinobj(dx) } ) if (is.numeric(x)) { if (negated) { return(1 - x) } return(x) } if (identical(class(x), "formula")) { return(withinobj(dx)) } return(x) } admisc/R/asSOP.R0000644000176200001440000000410315161273642013030 0ustar liggesusers# Copyright (c) 2019 - 2026, 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 `asSOP` <- function( expression = "", snames = "", noflevels = NULL ) { expression <- recreate(substitute(expression)) snames <- recreate(substitute(snames)) arglist <- list(snames = snames) if (!is.null(noflevels)) { arglist$noflevels <- noflevels } return( unname(sapply(expression, function(x) { if (grepl("[(|)]", x)) { x <- do.call( expandBrackets, c(list(expression = x), arglist) ) } return(x) })) ) } admisc/R/write.clipboard.R0000644000176200001440000000346115161273642015141 0ustar liggesusers# Copyright (c) 2019 - 2026, 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 write.clipboard <- function (x) { if (Sys.info()[['sysname']] == "Darwin") { clipboard <- pipe("pbcopy", "w") write.table(x, file = clipboard) close(clipboard) } else if (Sys.info()[['sysname']] == "Windows") { write.table(x, "clipboard", sep = "\t") } } admisc/R/factorize.R0000755000176200001440000004005215161273642014037 0ustar liggesusers# Copyright (c) 2019 - 2026, 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 Boolean expressions #' #' This function finds all combinations of common factors in a Boolean expression #' written in SOP - sum of products. It makes use of the function #' \bold{\code{\link{simplify}()}}, which uses the function #' \bold{\code{\link[QCA]{minimize}()}} from package \bold{\pkg{QCA}}). Users are #' highly encouraged to install and load that package, despite not being present #' in the Imports field (due to circular dependency issues). #' #' @name factorize #' @rdname factorize #' #' @param input A string representing a SOP expression, or a minimization #' object of class `"qca"`. #' @param snames A string containing the sets' names, separated by commas. #' @param noflevels Numerical vector containing the number of levels for each set. #' @param pos Logical, if possible factorize using product(s) of sums. #' @param ... Other arguments (mainly for backwards compatibility). #' #' @details #' Factorization is a process of finding common factors in a Boolean expression, #' written in SOP - sum of products. Whenever possible, the factorization can also #' be performed in a POS - product of sums form. #' #' Conjunctions should preferably be indicated with a star `*` sign, but this is not #' necessary when conditions have single letters or when the expression is expressed in #' multi-value notation. #' #' The argument **`snames`** is only needed when conjunctions are not indicated by #' any sign, and the set names have more than one letter each (see function #' `translate()` for more details). #' #' The number of levels in **`noflevels`** is needed only when negating multivalue #' conditions, and it should complement the **`snames`** argument. #' #' If **`input`** is an object of class `"qca"` (the result of the #' function `minimize()` from package **QCA**), a factorization is performed #' for each of the minimized solutions. #' #' @return A named list, each component containing all possible factorizations of #' the input expression(s), found in the name(s). #' #' @author Adrian Dusa #' #' @references #' Ragin, C.C. (1987) *The Comparative Method. Moving beyond qualitative and #' quantitative strategies*, Berkeley: University of California Press #' #' @seealso \code{\link{translate}} #' #' @examples #' # typical example with redundant conditions #' factorize(a~b~cd + a~bc~d + a~bcd + abc~d) #' #' # results presented in alphabetical order #' factorize(~one*two*~four + ~one*three + three*~four) #' #' # to preserve a certain order of the set names #' factorize(~one*two*~four + ~one*three + three*~four, #' snames = c(one, two, three, four)) #' #' # using pos - products of sums #' factorize(~a~c + ~ad + ~b~c + ~bd, pos = TRUE) #' #' \dontrun{ #' # make sure the package QCA is loaded #' library(QCA) #' #' # using an object of class "qca" produced with function minimize() #' # in package QCA #' #' pCVF <- minimize(CVF, outcome = "PROTEST", incl.cut = 0.8, #' include = "?", use.letters = TRUE) #' #' factorize(pCVF) #' #' # using an object of class "deMorgan" produced with negate() #' factorize(negate(pCVF)) #' } #' #' @keywords functions NULL #' @export `factorize` <- function(input, snames = "", noflevels = NULL, pos = FALSE, ...) { input <- recreate(substitute(input)) if (identical(input, character(0))) { return(invisible(input)) } snames <- recreate(substitute(snames)) dots <- list(...) scollapse <- ifelse(is.element("scollapse", names(dots)), dots$scollapse, FALSE) `pasteit` <- function(mat, comrows, cols, comvals, snames = "", mv = FALSE, collapse = "*", curly = FALSE) { if (!missing(cols)) { temp <- mat[comrows, -cols, drop = FALSE] if (mv) { cf <- paste(colnames(mat)[cols], ifelse(curly, "{", "["), comvals, ifelse(curly, "}", "]"), sep = "") rowsf <- lapply(seq(nrow(temp)), function(x) { fname <- colnames(temp) x <- temp[x, ] return(paste(fname, ifelse(curly, "{", "["), x, ifelse(curly, "}", "]"), sep = "")[x >= 0]) }) } else { for (i in seq(length(cols))) { if (comvals[i] == 0) { colnames(mat)[cols[i]] <- paste("~", colnames(mat)[cols[i]], sep = "") } } cf <- colnames(mat)[cols] rowsf <- lapply(seq(nrow(temp)), function(x) { x <- temp[x, ] nms <- names(x) if (!is.null(nms)) { nms[x == 0] <- paste("~", (nms[x == 0]), sep = "") 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 <- lapply(rowsf[rowsf != ""], function(x) { x <- x[order(match(gsub("[^A-Za-z]", "", x), snames))] return(paste(x, collapse = collapse)) }) rowsf <- sapply(rowsf, paste, collapse = collapse) rowsf <- unique(setdiff(rowsf, "")) if (all(nchar(unique(notilde(rowsf))) == 1)) { tblchar <- table(notilde(rowsf)) if (any(tblchar > 1)) { for (ch in names(tblchar)[tblchar > 1]) { rowsf <- rowsf[-which(notilde(rowsf) == ch)] } } } rowsf <- paste(rowsf, collapse = " + ") cf <- paste(cf[order(match(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), ifelse(curly, "{", "["), x, ifelse(curly, "}", "]"), sep = "")[x >= 0], collapse = "*") }), collapse = " + ") } else { pasted <- paste(sapply(seq(nrow(mat)), function(x) { colns <- colnames(mat) colns[mat[x, ] == 0] <- paste("~", colns[mat[x, ] == 0], sep = "") return(paste(colns[mat[x, ] >= 0], collapse = collapse)) }), collapse = " + ") } } return(pasted) } `getFacts` <- function(mat, snames = "", mv = FALSE, collapse = "*", curly = FALSE) { cfound <- FALSE result <- list() for (cc in seq(ncol(mat))) { allcols <- combnk(ncol(mat), cc) for (cols in seq(ncol(allcols))) { temp <- mat[, allcols[, cols], drop = FALSE] uniq <- unique(temp) uniq <- uniq[apply(uniq, 1, function(x) all(x >= 0)), , drop = FALSE] if (nrow(uniq) > 0) { for (i in seq(nrow(uniq))) { rows <- logical(nrow(mat)) comrows <- apply(temp, 1, function(x) { all(x == unname(uniq[i, ])) }) if (sum(comrows) > 1) { cfound <- TRUE rows <- rows | comrows pasted <- pasteit( mat = mat, comrows = comrows, cols = allcols[, cols], comvals = unname(uniq[i, ]), snames = snames, mv = mv, collapse = collapse, curly = curly) if (sum(rows) < nrow(mat)) { result[[length(result) + 1]] <- Recall(mat[!rows, , drop = FALSE], snames = snames, mv = mv, collapse = collapse) names(result)[length(result)] <- pasted } else { result <- list(NA) names(result) <- pasted } } } } } } if (!cfound) { result <- list(NA) names(result) <- pasteit(mat = mat, snames = snames, mv = mv, collapse = collapse, curly = curly) } return(result) } `getSol` <- function(sol, pos = FALSE, noflevels = NULL, snames = "", mv = FALSE, collapse = "*", curly = FALSE) { pospos <- FALSE sol <- lapply(unique(lapply(sol, sort)), function(x) { x <- strsplit(gsub("@1 \\+ 1", "", x), split = "@") x <- lapply(x, function(x) { x <- unlist(strsplit(x, split = "@")) for (i in seq(length(x))) { xi <- unlist(strsplit(x[i], split = " \\+ ")) for (j in seq(length(xi))) { xi[j] <- pasteit(translate(xi[j], snames = snames), snames = snames, mv = mv, collapse = collapse, curly = curly) } x[i] <- paste(xi, collapse = " + ") } return(x) }) if (pos) { tbl <- table(unlist(x)) if (any(tbl > 1)) { tbl <- names(tbl)[tbl > 1] checked <- logical(length(x)) common <- vector(mode = "list", length(tbl)) names(common) <- tbl for (i in seq(length(tbl))) { for (j in seq(length(x))) { if (!checked[j]) { if (any(x[[j]] == tbl[i])) { common[[i]] <- c(common[[i]], setdiff(x[[j]], tbl[i])) checked[j] <- TRUE } } } common[[i]] <- sort(common[[i]]) } common <- paste(as.vector(sapply(seq(length(common)), function(x) { sort(c(paste("(", paste(common[[x]], collapse = " + "), ")", sep = ""), paste("(", paste(tbl[x], collapse = " + "), ")", sep = ""))) })), collapse = collapse) x <- x[!checked] if (length(x) > 0) { common <- paste(c(common, sapply(x[order(match(gsub("[^A-Za-z]", "", x), snames))], paste, collapse = collapse)), collapse = " + ") } return(common) } else { x <- sort(sapply(x, function(y) { if (length(y) == 1) { return(y) } paste(y[1], collapse, "(", y[2], ")", sep = "") })) } } else { x <- sapply(x, function(y) { if (length(y) == 1) { return(y) } res <- simplify(y[2], snames = snames, noflevels = noflevels, scollapse = identical(collapse, "*")) if (identical(res, character(0))) { return(res) } if (res == "") { return(y[1]) } paste(y[1], collapse, "(", res, ")", sep = "") }) if (any(unlist(lapply(x, length)) == 0)) { return(character(0)) } x <- sort(x) } return(x) }) if (any(unlist(lapply(sol, length)) == 0)) { return(character(0)) } sol <- unlist(lapply(unique(sol), function(x) { paste(x, collapse = " + ") })) return(sol) } `factorizeit` <- function(x, pos = FALSE, noflevels = NULL, snames = "", mv = FALSE, curly = FALSE) { if (grepl("[(|)]", x)) { x <- expandBrackets(x, snames = snames, noflevels = noflevels) } trexp <- translate(x, snames = snames, noflevels = noflevels) snames <- colnames(trexp) collapse <- ifelse(any(nchar(snames) > 1) | mv | scollapse | grepl("[*]", x), "*", "") facts <- names(unlist(getFacts(mat = trexp, snames = snames, mv = mv, collapse = collapse, curly = curly))) facts <- lapply(facts, function(x) unlist(strsplit(x, split = "[.]"))) facts <- unique(lapply(facts, sort)) getSol(facts, pos = pos, noflevels = noflevels, snames = snames, mv = mv, collapse = collapse, curly = curly) } isol <- NULL if (methods::is(input, "QCA_min")) { noflevels <- input$tt$noflevels snames <- input$tt$options$conditions if (input$options$use.letters) { snames <- LETTERS[seq(length(snames))] } if (is.element("i.sol", names(input))) { elengths <- unlist(lapply(input$i.sol, function(x) length(x$solution))) isol <- paste(rep(names(input$i.sol), each = elengths), unlist(lapply(elengths, seq)), sep = "-") input <- unlist(lapply(input$i.sol, function(x) { lapply(x$solution, paste, collapse = " + ") })) } else { input <- unlist(lapply(input$solution, paste, collapse = " + ")) } } else if (methods::is(input, "admisc_deMorgan")) { if (any(names(attributes(input)) == "snames")) { snames <- attr(input, "snames") } if (is.list(input)) { input <- unlist(input) } } else if (methods::is(input, "admisc_simplify")) { if (any(names(attributes(input)) == "snames")) { snames <- attr(input, "snames") } } if (is.character(input)) { if (!identical(snames, "")) { snames <- splitstr(snames) } mv <- any(grepl("\\[|\\{", unlist(input))) curly <- any(grepl("\\{", unlist(input))) result <- lapply(input, function(x) { factorizeit(x, pos = pos, snames = snames, noflevels = noflevels, mv = mv, curly = curly) }) names(result) <- unname(input) if (!identical(snames, "")) { attr(result, "snames") <- snames } if (!is.null(isol)) { attr(result, "isol") <- isol } return(classify(result, "admisc_factorize")) } } admisc/R/getInfo.R0000644000176200001440000001025515161273642013443 0ustar liggesusers# Copyright (c) 2019 - 2026, 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 `getInfo` <- function(data, ...) { dots <- list(...) if (is.matrix(data)) { data <- as.data.frame(data) } dc.code <- unique(unlist(lapply(data, function(x) { if (is.numeric(x) && wholeNumeric(x)) { return(x[x < 0]) } else { return(as.character(x[is.element(x, c("-", "dc"))])) } }))) fuzzy.cc <- logical(ncol(data)) hastime <- logical(ncol(data)) factor <- sapply(data, is.factor) declared <- sapply(data, function(x) inherits(x, "declared")) noflevels <- getLevels(data) attributes(noflevels) <- NULL for (i in seq(ncol(data))) { cc <- data[, i] label <- attr(cc, "label", exact = TRUE) labels <- attr(cc, "labels", exact = TRUE) if (is.factor(cc)) { cc <- as.character(cc) } if (length(dc.code) > 0 && any(is.element(cc, dc.code))) { cc[is.element(cc, dc.code)] <- -1 } if (possibleNumeric(cc)) { cc <- asNumeric(cc) fuzzy.cc[i] <- any(na.omit(cc) %% 1 > 0) if (!fuzzy.cc[i] & !anyNA(cc)) { if (any(na.omit(cc) < 0)) { hastime[i] <- TRUE cc[cc < 0] <- max(cc) + 1 } } if (declared[i]) { attr(cc, "label") <- label attr(cc, "labels") <- labels class(cc) <- c("declared", class(cc)) } data[[i]] <- cc } } factor <- factor & !hastime categories <- list() columns <- colnames(data) if (any(factor | declared)) { for (i in which(factor | declared)) { if (factor[i]) { categories[[columns[i]]] <- levels(data[, i]) data[, i] <- as.numeric(data[, i]) - 1 } else { x <- data[, i] labels <- attr(x, "labels", exact = TRUE) if (fuzzy.cc[i]) { if (length(setdiff(0:1, labels) > 0)) { stopError("Declared fuzzy columns should have labels for the end points.") } } else if (length(setdiff(x, labels)) > 0) { stopError("Declared columns should have labels for all values.") } categories[[columns[i]]] <- names(sort(labels)) } } } return( list( data = data, fuzzy.cc = fuzzy.cc, hastime = hastime, factor = factor, declared = declared, categories = categories, dc.code = dc.code, noflevels = noflevels ) ) } admisc/R/getName.R0000644000176200001440000001246415161273642013434 0ustar liggesusers# Copyright (c) 2019 - 2026, 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. #' Get the name of the object being used in a function call #' #' This is a utility to be used inside a function. #' #' @name getName #' @rdname getName #' @rawRd #' \usage{ #' getName(x, object = FALSE) #' } #' #' \arguments{ #' \item{x}{String, expression to be evaluated} #' \item{object}{Logical, return the object's name} #' } #' #' \details{ #' Within a function, the argument \code{x} can be anything and it is usually #' evaluated as an object. #' #' This function should be used in conjunction with the base \code{match.call()}, #' to obtain the original name of the object being served as an input, regardless #' of how it is being served. #' #' A particular use case of this function relates to the cases when a variable #' within a data.frame is used. The overall name of the object (the data frame) #' is irrelevant, as the real object of interest is the variable. #' } #' #' #' \value{ #' A character vector of length 1. #' } #' #' \author{ #' Adrian Dusa #' } #' #' \examples{ #' foo <- function(x) { #' funargs <- sapply(match.call(), deparse)[-1] #' return(getName(funargs[1])) #' } #' #' dd <- data.frame(X = 1:5, Y = 1:5, Z = 1:5) #' #' foo(dd) #' # dd #' #' foo(dd$X) #' # X #' #' foo(dd[["X"]]) #' # X #' #' foo(dd[[c("X", "Y")]]) #' # X Y #' #' foo(dd[, 1]) #' # X #' #' foo(dd[, 2:3]) #' # Y Z #' } #' #' \keyword{functions} NULL #' @export `getName` <- function(x, object = FALSE) { result <- rep("", length(x)) x <- as.vector(gsub("1-", "", gsub("[[:space:]]", "", x))) condsplit <- unlist(strsplit(x, split = "")) startpos <- 0 keycode <- "" if (any(condsplit == "]")) { startpos <- max(which(condsplit == "]")) keycode <- "]" } if (any(condsplit == "$")) { sp <- max(which(condsplit == "$")) if (sp > startpos) { startpos <- sp keycode <- "$" } } if (identical(keycode, "$")) { if (object) { return(substring(x, 1, min(which(condsplit == "$")) - 1)) } result <- substring(x, startpos + 1) } else if (identical(keycode, "]")) { objname <- substring(x, 1, min(which(condsplit == "[")) - 1) if (object) { return(objname) } nms <- character(0) for (target in c("names", "colnames")) { for (n in 1:2) { if (length(nms) == 0) { testnms <- tryCatchWEM( nms <- eval.parent( parse( text = paste(target, "(", objname, ")", sep = "") ), n = n ) ) } } } stindex <- max(which(condsplit == "[")) stopindex <- ifelse( identical(condsplit[stindex - 1], "["), stindex - 2, stindex - 1 ) ptn <- gsub("]", "", substr(x, stindex + 1, startpos)) if (substring(ptn, 1, 1) == ",") { ptn <- substring(ptn, 2) } if (substring(ptn, 1, 2) == "c(") { ptn <- substring(ptn, 3, nchar(ptn) - 1) } postring <- grepl("'|\"", ptn) ptn <- gsub("'|\"|]|\ ", "", ptn) ptn <- unlist(strsplit(ptn, split = ",")) if (length(ptn) == 1) { ptn <- unlist(strsplit(ptn, split = ":")) } if (possibleNumeric(ptn)) { if (length(nms) > 0) { result <- nms[as.numeric(ptn)] } } else { if (postring) { return(ptn) } if (length(nms) > 0) { if (all(is.element(ptn, nms))) { return(ptn) } } } } else { result <- x } return(gsub(",|\ ", "", result)) } admisc/R/onLoad.R0000644000176200001440000000330515161273642013262 0ustar liggesusers# Copyright (c) 2019 - 2026, 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. .onLoad <- function(libname, pkgname) { options(admisc.tol = .Machine$double.eps^0.5) } .onUnload <- function(libpath) { options(admisc.tol = NULL) library.dynam.unload("admisc", libpath) } admisc/R/validateNames.R0000644000176200001440000000356615161273642014634 0ustar liggesusers# Copyright (c) 2019 - 2026, 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 #' @noRd `validateNames` <- function(expression = "", snames = "", data = NULL) { if (is.null(data)) { ppm <- translate(expression = expression, snames = snames, validate = TRUE) } else { ppm <- translate(expression = expression, data = data, validate = TRUE) } return(ppm[, apply(ppm, 2, function(x) any(x >= 0)), drop = FALSE]) } admisc/R/export.R0000644000176200001440000001151215161273642013366 0ustar liggesusers# Copyright (c) 2019 - 2026, 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 an object to a file or a connection #' #' This is a generic function, usually a wrapper to \bold{\code{\link[utils]{write.table}()}}. #' #' @name export #' @rdname export #' @rawRd #' \usage{ #' export(what, ...) #' } #' #' \arguments{ #' \item{what}{The object to be written (matrix or dataframe)} #' \item{...}{Specific arguments to class functions.} #' } #' #' \details{ #' The default convention for \bold{\code{\link[utils]{write.table}()}} is to add a blank column #' name for the row names, but (despite it is a standard used for CSV files) that doesn't work #' with all spreadsheets or other programs that attempt to import the result of #' \bold{\code{\link[utils]{write.table}()}}. #' #' This function acts as if \bold{\code{\link[utils]{write.table}()}} was called, with only one #' difference: if row names are present in the dataframe (i.e. any of them should be different #' from the default row numbers), the final result will display a new column called #' \bold{\code{cases}} in the first position, except the situation that another column called #' \bold{\code{cases}} already exists in the data, when the row names will be completely ignored. #' #' If not otherwise specified, an argument \bold{\code{sep = ","}} is added by default. #' #' The argument \bold{\code{row.names}} is always set to FALSE, a new column being added anyways (if possible). #' #' Since this function pipes everything to \bold{\code{\link[utils]{write.table}()}}, the argument \bold{\code{file}} #' can also be a connection open for writing, and \bold{\code{""}} indicates output to the console. #' } #' #' \author{ #' Adrian Dusa #' } #' #' #' \seealso{ #' The \dQuote{R Data Import/Export} manual. #' #' \code{\link[utils]{write.table}} #' } #' #' \keyword{functions} NULL #' @export export <- function (what, ...) { UseMethod ("export") } #' @export `export.default` <- function (what, ...) { return(NULL) } #' @export `export.data.frame` <- function(what, ...) { dots <- list(...) Call <- as.list(match.call(expand.dots = TRUE))[-1] caseid <- "cases" if (any(names(dots) == "caseid")) { caseid <- dots[["caseid"]] Call[["caseid"]] <- NULL } if (any(rownames(what) != seq(nrow(what)))) { if (all(colnames(what) != caseid)) { what <- cbind("cases" = rownames(what), what) names(what)[1] <- caseid } } Call[["x"]] <- what Call[["what"]] <- NULL if (any(names(dots) == "sep")) { if (dots[["sep"]] == "tab") { dots[["sep"]] <- "\t" } Call[["sep"]] <- dots[["sep"]] } else { Call[["sep"]] <- "," } if (any(names(dots) == "col.names")) { Call[["col.names"]] <- dots[["col.names"]] } if (any(names(dots) == "row.names")) { message("The argument 'row.names' is always set to FALSE, by default.") } Call[["row.names"]] <- FALSE do.call("write.table", Call) } #' @export `export.list` <- function(what, ...) { dots <- list(...) Call <- as.list(match.call(expand.dots = TRUE))[-1] DDIwR <- eval(parse(text = "requireNamespace('DDIwR', quietly = TRUE)")) if (!DDIwR) { stopError("Package DDIwR needs to be installed.") } if (is.null(what$.extra)) { return(NULL) } names(Call)[1] <- "codeBook" eval(parse(text = "do.call('exportCodebook', Call)")) } admisc/R/prettyTable.R0000755000176200001440000000442515161273642014354 0ustar liggesusers# Copyright (c) 2019 - 2026, 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 #' @noRd `prettyTable` <- function(input) { if (methods::is(input, "QCA_pic")) { class(input) <- "matrix" } else { input <- as.matrix(input) } if (is.logical(input)) { input2 <- input input[input2] <- "x" input[!input2] <- "-" } if(is.null(colnames(input))) colnames(input) <- rep(" ", ncol(input)) nchars <- nchar(colnames(input)) colnames(input)[nchars == 1] <- format(colnames(input)[nchars == 1], width = 2, justify = "centre") nchars[nchars == 1] <- 2 for (i in seq((ncol(input) - any(colnames(input) == "lines")))) { input[, i] <- format(format(input[, i]), width = nchars[i], justify = "centre") } rownames(input) <- paste(rownames(input), "") return(noquote(input)) } admisc/R/classify.R0000644000176200001440000000315615161273642013667 0ustar liggesusers# Copyright (c) 2019 - 2026, 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 classify <- function(x, class = "admisc_simplify") { class(x) <- unique(c(class, class(x))) x } admisc/R/translate.R0000644000176200001440000003341315161273642014046 0ustar liggesusers# Copyright (c) 2019 - 2026, 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 `translate` <- function( expression = "", snames = "", noflevels = NULL, data = NULL, ... ) { expression <- recreate(substitute(expression)) attrs <- attributes(expression) snames <- recreate(substitute(snames)) dots <- list(...) enter <- ifelse (is.element("enter", names(dots)), "", "\n") categories <- list() if (!is.null(dots$categories)) { categories <- dots$categories } oldexp <- NULL if (identical(expression, "")) { stopError("Empty expression.") } if (any(grepl("[(|)]", expression))) { stopError("POS expressions cannot be translated directly.") } if (any(grepl("<=>|<->|=>|->|<=|<-", expression))) { stopError("Incorrect expression, contains outcome and relation.") } if (!is.vector(drop(snames))) { stopError("Set names should be a single string or a vector of names.") } if (!is.null(data)) { if (is.null(colnames(data))) { stopError("Data should have column names.") } } if (is.null(data) & (identical(snames, "") | is.null(noflevels))) { syscalls <- as.character(sys.calls()) usingwith <- "admisc::using\\(|using\\(|with\\(" if (any(usingdata <- grepl(usingwith, syscalls))) { data <- get( unlist(strsplit(gsub(usingwith, "", syscalls), split = ","))[1], envir = length(syscalls) - tail(which(usingdata), 1) ) } } if (!is.element("data.frame", class(data))) { data <- NULL } if (identical(snames, "")) { if (!is.null(data)) { snames <- colnames(data) } else if (!is.null(attrs$snames)) { snames <- attrs$snames } } else { snames <- splitstr(snames) if (!is.null(data)) { if (length(setdiff(snames, colnames(data))) > 0) { stopError("Some not found in the data column names.") } data <- data[, snames, drop = FALSE] } } multivalue <- any(grepl("\\[|\\]|\\{|\\}", expression)) if (length(expression) == 1) { expression <- splitstr(expression) } coerced2mv <- FALSE if (!identical(snames, "")) { checkValid( expression = expression, snames = snames, data = data, categories = categories ) oldexp <- trimstr(unlist(lapply(expression, strsplit, split = "\\+"))) if (!multivalue) { multivalue <- TRUE coerced2mv <- TRUE mv <- mvSOP( expression = paste(expression, collapse = "+"), snames = snames, data = data, categories = categories, translate = TRUE ) expression <- mv$expression oldc <- mv$newc newc <- mv$oldc } } replaced <- FALSE if (!identical(snames, "") && length(snames) > 0) { if (any(nchar(snames) > 1) & !is.element("validate", names(dots))) { snameso <- snames if (length(snames) < 27) { snamesr <- LETTERS[seq(length(snames))] } else { snamesr <- paste("X", seq(length(snames)), sep = "") } for (i in seq(length(expression))) { expression[i] <- replaceText(expression[i], snames, snamesr) } if (!is.null(data)) { colnames(data) <- snamesr[match(colnames(data), snames)] } snames <- snamesr replaced <- TRUE } } if (is.null(noflevels)) { if (!is.null(data)) { infodata <- getInfo(data) noflevels <- infodata$noflevels } } else { if (is.character(noflevels)) { noflevels <- splitstr(noflevels) } } expression <- gsub("[[:space:]]|[^ -~]+", "", expression) if (identical("1-", substring(expression, 1, 2))) { explist <- list(input = gsub("1-", "", expression), snames = snames) if (!is.null(noflevels)) { explist$noflevels <- noflevels } expression <- unlist(do.call(negate, explist)) } if (any(grepl(",", gsub(",[0-9]", "", expression)))) { expression <- paste(splitstr(expression), collapse = "+") } pporig <- trimstr(unlist(strsplit(expression, split="[+]"))) expression <- gsub("[[:space:]]", "", expression) beforemessage <- "Condition" aftermessage <- "does not match the set names from \"snames\" argument" if (is.element("validate", names(dots))) { if (is.null(data)) { beforemessage <- "Object" aftermessage <- "not found" } else { aftermessage <- "not found in the data" } } if (multivalue) { curly <- any(grepl("[{]", expression)) expression <- gsub("[*]", "", expression) checkMV( expression, snames = snames, noflevels = noflevels, data = data, ... = ... ) pp <- unlist(strsplit(expression, split = "[+]")) if (curly) { conds <- sort(unique(notilde(curlyBrackets(pp, outside = TRUE)))) } else { conds <- sort(unique(notilde(squareBrackets(pp, outside = TRUE)))) } if (identical(snames, "")) { if (!is.null(data)) { conds <- intersect(colnames(data), conds) } } else { if (all(is.element(conds, snames))) { conds <- snames } else { conds <- setdiff(conds, snames) if (length(conds) > 1) { beforemessage <- paste(beforemessage, "s", sep = "") aftermessage <- gsub("does", "do", aftermessage) } stopError( sprintf( "%s '%s' %s.", beforemessage, paste(conds, collapse = ","), aftermessage ) ) } } if (any(hastilde(expression))) { if (is.null(noflevels)) { noflevels <- getInfo(data[, conds, drop = FALSE])$noflevels } } retlist <- lapply(pp, function(x) { if (curly) { outx <- curlyBrackets(x, outside = TRUE) inx <- lapply(curlyBrackets(x), splitstr) } else { outx <- squareBrackets(x, outside = TRUE) inx <- lapply(squareBrackets(x), splitstr) } remtilde <- notilde(outx) dupnot <- duplicated(remtilde) if (length(win <- which(hastilde(outx))) > 0) { for (i in win) { inx[[i]] <- setdiff(seq(noflevels[which(is.element(conds, remtilde[i]))]) - 1, inx[[i]]) } } empty <- FALSE for (i in seq(length(conds))) { if (is.element(conds[i], remtilde[dupnot])) { wdup <- which(remtilde == conds[i]) inx[[wdup[1]]] <- intersect(inx[[wdup[1]]], inx[[wdup[2]]]) if (length(wdup) > 2) { for (i in seq(3, length(wdup))) { dupres <- intersect(dupres, inx[[wdup[i]]]) } } if (length(inx[[wdup[1]]]) == 0) { empty <- TRUE } } } ret <- as.list(rep(-1, length(conds))) names(ret) <- conds ret[notilde(outx[!dupnot])] <- inx[!dupnot] return(ret) }) names(retlist) <- pporig retlist <- retlist[ !unlist( lapply( retlist, function(x) { any(unlist(lapply(x, length)) == 0) } ) ) ] if (length(retlist) == 0) { stopError("The result is an empty set.") } } else { sl <- ifelse( identical(snames, "") || (replaced & length(snames) < 27), TRUE, all(nchar(snames) == 1) ) pp <- unlist(strsplit(expression, split = "[+]")) if (replaced) { pp <- gsub("[*]", "", pp) } splitchar <- ifelse( any(grepl("[*]", pp)) | !sl, "[*]", "" ) conds <- setdiff( sort( unique( notilde( unlist(strsplit(pp, split = splitchar)) ) ) ), "" ) if (!identical(snames, "")) { if (!is.null(data)) { if ( all(is.element(conds, snames)) & all(is.element(conds, colnames(data))) ) { infodata <- getInfo(data[, conds, drop = FALSE]) valid <- which(infodata$noflevels >= 2) invalid <- any( infodata$noflevels[valid] > 2 & !infodata$hastime[valid] & !infodata$factor[valid] ) if (invalid) { stopError("Expression should be multi-value, since it refers to multi-value data.") } } } if (all(is.element(conds, snames))) { conds <- snames } else { conds <- setdiff(conds, snames) if (length(conds) > 1) { beforemessage <- paste(beforemessage, "s", sep = "") aftermessage <- gsub("does", "do", aftermessage) } if (replaced) { conds <- replaceText(conds, snames, snameso) } stopError( sprintf( "%s '%s' %s.", beforemessage, paste(conds, collapse = ","), aftermessage ) ) } } retlist <- lapply(pp, function(x) { x <- unlist(strsplit(x, split = splitchar)) if (length(wx <- which(x == "~")) > 0) { x[wx + 1] <- paste0("~", x[wx + 1]) x <- x[-wx] } x <- unique(x) remtilde <- notilde(x) dup <- remtilde[duplicated(remtilde)] x <- x[!is.element(remtilde, dup)] ret <- as.list(rep(-1, length(conds))) names(ret) <- conds ret[notilde(x)] <- 1 - hastilde(x) return(ret) }) names(retlist) <- pporig } retlist <- retlist[!unlist(lapply(retlist, function(x) all(unlist(x) < 0)))] if (replaced) { for (i in seq(length(retlist))) { names(retlist)[i] <- replaceText(names(retlist)[i], snames, snameso) names(retlist[[i]]) <- snameso } } retmat <- do.call(rbind, lapply(retlist, function(x) { xnames <- names(x) x <- unlist(lapply(x, paste, collapse = ",")) names(x) <- xnames return(x) })) if (length(retmat) == 0) { stopError("Impossible to translate an empty set.") } if (coerced2mv) { for (i in seq(length(retlist))) { names(retlist)[i] <- replaceText(names(retlist)[i], oldc, newc) names(retlist[[i]]) <- replaceText(names(retlist[[i]]), oldc, newc) } rownms <- rownames(retmat) for (i in seq(nrow(retmat))) { rownms[i] <- replaceText(rownms[i], oldc, newc) } rownames(retmat) <- rownms colnms <- colnames(retmat) for (i in seq(ncol(retmat))) { colnms[i] <- replaceText(colnms[i], oldc, newc) } colnames(retmat) <- colnms } if (!is.null(oldexp) && length(oldexp) == nrow(retmat)) { rownames(retmat) <- oldexp names(retlist) <- oldexp } if (is.element("retlist", names(dots))) { attr(retmat, "retlist") <- retlist } class(retmat) <- c("matrix", "admisc_translate") return(retmat) } admisc/R/uninstall.R0000644000176200001440000000335315161273642014062 0ustar liggesusers# Copyright (c) 2019 - 2026, 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 `uninstall` <- function(package) { package <- gsub("\\\"", "", deparse(substitute(package))) admisc::unload(package) if (is.element(package, rownames(installed.packages()))) { remove.packages(package) } } admisc/R/brackets.R0000644000176200001440000002747115161273642013656 0ustar liggesusers# Copyright (c) 2019 - 2026, 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. #' Extract information from a multi-value SOP/DNF expression #' #' Functions to extract information from an expression written in SOP, or in the #' canonical DNF, for multi-value causal conditions. They extract either the #' values within brackets, or the causal condition names outside the brackets. #' #' @name betweenBrackets #' @rdname brackets #' @aliases insideBrackets #' @aliases outsideBrackets #' @aliases curlyBrackets #' @aliases squareBrackets #' @aliases roundBrackets #' #' @param x A DNF/SOP expression. #' @param type Brackets type: curly, round or square. #' @param invert Logical, if activated returns whatever is not within the #' brackets. #' @param outside Logical, if activated returns the condition names outside the #' brackets. #' @param regexp Optional regular expression to extract information with. #' @param expression A DNF/SOP expression. #' @param snames A string containing the sets' names, separated by commas. #' @param noflevels Numerical vector containing the number of levels for each #' set. #' @param simplify Logical, remove redundant expressions after expansion. #' #' @details #' Expressions written in SOP are used in Boolean logic, signaling a #' disjunction of conjunctions. #' #' These expressions are useful in Qualitative Comparative Analysis, a social #' science methodology used to search for causal configurations associated with #' a certain outcome. #' #' They are also used to draw Venn diagrams with package `venn`, which draws #' any kind of set intersection based on a custom SOP expression. #' #' `curlyBrackets()`, `squareBrackets()` and `roundBrackets()` are special cases #' of `betweenBrackets()` and `outsideBrackets()`, using curly, square or round #' brackets through the `type` argument. #' #' `outsideBrackets()` can also be seen as a special case of #' `betweenBrackets(invert = TRUE)`. #' #' SOP expressions are usually written using curly brackets for multi-value #' conditions but, to allow evaluation of unquoted expressions through R's #' parser, unquoted expressions should use square brackets and conjunctions #' should always use the product `*` sign. #' #' Sufficiency is recognized as `"=>"` in quoted expressions but this does not #' pass over R's parsing system in unquoted expressions. To overcome this #' problem, it is best to use the single arrow `"->"` notation. Necessity is #' recognized as either `"<="` or `"<-"`, both being valid in quoted and #' unquoted expressions. #' #' @author Adrian Dusa #' #' @examples #' sop <- "A[1] + B[2]*C[0]" #' #' betweenBrackets(sop) #' betweenBrackets(sop, invert = TRUE) #' #' # unquoted (valid) SOP expressions are allowed, same result #' betweenBrackets(A[1] + B[2]*C[0]) #' #' # curly brackets are also valid in quoted expressions #' betweenBrackets("A{1} + B{2}*C{0}", type = "{") #' curlyBrackets("A{1} + B{2}*C{0}") #' curlyBrackets("A{1} + B{2}*C{0}", outside = TRUE) #' #' squareBrackets(A[1] + B[2]*C[0]) #' squareBrackets(A[1] + B[2]*C[0], outside = TRUE) #' #' @keywords functions NULL #' @export `betweenBrackets` <- function(x, type = "[", invert = FALSE, regexp = NULL) { x <- recreate(substitute(x)) typematrix <- matrix(c("{", "[", "(", "}", "]", ")", "{}", "[]", "()"), nrow = 3) tml <- which(typematrix == type, arr.ind = TRUE)[1] if (is.na(tml)) { tml <- 1 } tml <- typematrix[tml, 1:2] if (is.null(regexp)) { regexp <- "[[:alnum:]|,]*" } result <- gsub( paste("\\", tml, sep = "", collapse = "|"), "", regmatches( x, gregexpr( paste("\\", tml, sep = "", collapse = regexp), x ), invert = invert )[[1]] ) result <- gsub("\\*|\\+", "", unlist(strsplit(gsub("\\s+", " ", result), split = " "))) return(result[result != ""]) } #' @export `insideBrackets` <- function(...) { .Deprecated(msg = "Function insideBrackets() is deprecated, use betweenBrackets().\n") betweenBrackets(...) } #' @export `outsideBrackets` <- function(x, type = "[", regexp = NULL) { x <- recreate(substitute(x)) typematrix <- matrix(c("{", "[", "(", "}", "]", ")", "{}", "[]", "()"), nrow = 3) tml <- which(typematrix == type, arr.ind = TRUE)[1] if (is.na(tml)) { tml <- 1 } tml <- typematrix[tml, 1:2] if (is.null(regexp)) { regexp <- "[[:alnum:]|,]*" } pattern <- paste("\\", tml, sep = "", collapse = regexp) result <- gsub( "\\*|\\+", "", unlist( strsplit( gsub( "\\s+", " ", trimstr(gsub(pattern, " ", x)) ), split = " " ) ) ) return(result[result != ""]) } #' @export `curlyBrackets` <- function(x, outside = FALSE, regexp = NULL) { x <- recreate(substitute(x)) x <- paste(x, collapse = "+") if (is.null(regexp)) { regexp <- "\\{[[:alnum:]|,|;]+\\}" } x <- gsub("[[:space:]]", "", x) res <- regmatches(x, gregexpr(regexp, x), invert = outside)[[1]] if (outside) { res <- gsub( "\\*", "", unlist(strsplit(res, split = "\\+")) ) return(res[res != ""]) } else { return(gsub("\\{|\\}|\\*", "", res)) } } #' @export `squareBrackets` <- function(x, outside = FALSE, regexp = NULL) { x <- recreate(substitute(x)) x <- paste(x, collapse = "+") if (is.null(regexp)) { regexp <- "\\[[[:alnum:]|,|;]+\\]" } x <- gsub("[[:space:]]", "", x) res <- regmatches(x, gregexpr(regexp, x), invert = outside)[[1]] if (outside) { res <- gsub( "\\*", "", unlist(strsplit(res, split = "\\+")) ) return(res[res != ""]) } else { return(gsub("\\[|\\]|\\*", "", res)) } } #' @export `roundBrackets` <- function(x, outside = FALSE, regexp = NULL) { x <- recreate(substitute(x)) if (is.null(regexp)) { regexp <- "\\(([^)]+)\\)" } x <- gsub("[[:space:]]", "", x) res <- regmatches(x, gregexpr(regexp, x), invert = outside)[[1]] if (outside) { res <- unlist(strsplit(res, split="\\+")) return(res[res != ""]) } else { return(gsub("\\(|\\)|\\*", "", res)) } } #' @export `expandBrackets` <- function( expression, snames = "", noflevels = NULL, scollapse = FALSE ) { expression <- recreate(substitute(expression)) snames <- splitstr(snames) star <- any(grepl("[*]", expression)) multivalue <- any(grepl("\\[|\\]|\\{|\\}", expression)) collapse <- ifelse( any(nchar(snames) > 1) | multivalue | star | scollapse, "*", "" ) curly <- grepl("[{]", expression) sl <- ifelse( identical(snames, ""), FALSE, ifelse( all(nchar(snames) == 1), TRUE, FALSE ) ) getbl <- function(expression, snames = "", noflevels = NULL) { bl <- splitMainComponents(gsub("[[:space:]]", "", expression)) bl <- splitBrackets(bl) bl <- lapply(bl, function(x) { if (tilde1st(x[[1]]) & nchar(x[[1]]) == 1) { x <- x[-1] x[[1]] <- as.character(negate(x[[1]], snames = snames, noflevels = noflevels)) } return(x) }) bl <- removeSingleStars(bl) bl <- splitPluses(bl) blu <- unlist(bl) bl <- splitStars( bl, ifelse( ( sl | any( hastilde(blu) & !tilde1st(blu) ) ) & !grepl("[*]", expression) & !multivalue, "", "*" ) ) bl <- solveBrackets(bl) bl <- simplifyList(bl) return(bl) } bl <- getbl(expression, snames = snames, noflevels = noflevels) if (length(bl) == 0) return("") bl <- paste( unlist( lapply( bl, paste, collapse = collapse ) ), collapse = " + " ) expressions <- translate(bl, snames = snames, noflevels = noflevels) snames <- colnames(expressions) redundant <- logical(nrow(expressions)) if (nrow(expressions) > 1) { for (i in seq(nrow(expressions) - 1)) { if (!redundant[i]) { for (j in seq(i + 1, nrow(expressions))) { if (!redundant[j]) { subsetrow <- checkSubset( expressions[c(i, j), , drop = FALSE], implicants = FALSE ) if (!is.null(subsetrow)) { redundant[c(i, j)[subsetrow]] <- TRUE } } } } } expressions <- expressions[!redundant, , drop = FALSE] if (possibleNumeric(expressions)) { mat <- matrix(asNumeric(expressions) + 1, nrow = nrow(expressions)) colnames(mat) <- colnames(expressions) expressions <- sortExpressions(mat) - 1 } else { eorder <- order( apply( expressions, 1, function(x) sum(x < 0) ), decreasing = TRUE ) expressions <- expressions[eorder, , drop = FALSE] } } expressions <- unlist(apply(expressions, 1, function(x) { result <- c() for (i in seq(length(snames))) { if (x[i] != -1) { if (multivalue) { result <- c( result, paste( snames[i], ifelse(curly, "{", "["), x[i], ifelse(curly, "}", "]"), sep = "" ) ) } else { if (x[i] == 0) { result <- c(result, paste("~", snames[i], sep = "")) } else { result <- c(result, snames[i]) } } } } return(paste(result, collapse = collapse)) })) return(paste(expressions, collapse = " + ")) } admisc/R/listRDA.R0000644000176200001440000000527015161273642013353 0ustar liggesusers# Copyright (c) 2019 - 2026, 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. #' Load and list objects from an .rda file #' #' Utility functions to read the names and load the objects from an .rda file, into #' an R list. #' #' @name listRDA #' @rdname rdaFunctions #' @aliases objRDA #' @rawRd #' \usage{ #' listRDA(.filename) #' #' objRDA(.filename) #' } #' #' \arguments{ #' \item{.filename}{The path to the file where the R object is saved.} #' } #' #' \details{ #' Files with the extension .rda are routinely created using the base function #' \bold{\code{\link[base]{save}()}}. #' #' The function \bold{\code{listRDA()}} loads the object(s) from the .rda file into a list, #' preserving the object names in the list components. #' #' The .rda file can naturally be loaded with the base \bold{\code{\link[base]{load}()}} function, #' but in doing so the containing objects will overwrite any existing objects with the same names. #' #' The function \bold{\code{objRDA()}} returns the names of the objects from the .rda file. #' } #' #' \value{ #' A list, containing the objects from the loaded .rda file. #' } #' #' \author{ #' Adrian Dusa #' } #' #' #' \keyword{functions} NULL #' @export `listRDA` <- function(.filename) { load(.filename) return(as.list(environment())) } admisc/R/wholeNumeric.R0000644000176200001440000000421215161273642014505 0ustar liggesusers# Copyright (c) 2019 - 2026, 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 `wholeNumeric` <- function(x, each = FALSE) { if (inherits(x, "haven_labelled") || inherits(x, "declared")) { return(Recall(unclass(x), each = each)) } if (!possibleNumeric(x) & !each) { return(FALSE) } result <- logical(length(x)) isna <- is.na(x) result[isna] <- NA if (all(isna) || is.logical(x)) { return(result) } x <- asNumeric(x) isnax <- is.na(x) result[!isna & isnax] <- FALSE isna <- isna | isnax x <- x[!isna] result[!isna] <- abs(x - round(x)) < .Machine$double.eps^0.5 if (each) { return(result) } return(all(result[!isna])) } admisc/R/prettyString.R0000755000176200001440000000733515161273642014576 0ustar liggesusers# Copyright (c) 2019 - 2026, 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 #' @noRd `prettyString` <- function(string.vector, string.width = 80, repeat.space = 5, separator = ",", sufnec = "", outcome = "", cases = FALSE) { if (length(string.vector) == 1) { if (nchar(encodeString(paste(string.vector, " ", sufnec, " ", outcome, sep=""))) >= string.width) { string.vector <- unlist(strsplit(string.vector, split = paste(" \\", separator, " ", sep = ""), useBytes = TRUE)) } } string <- string.vector[1] if (length(string.vector) > 1) { startpoint <- 1 for (j in seq(2, length(string.vector) + 1)) { if (j <= length(string.vector)) { if (nchar(encodeString(paste(string.vector[seq(startpoint, j - ifelse(separator == ";", 1, 0))], collapse = paste(ifelse(separator == ";", "", " "), separator, " ", sep = "")))) >= string.width) { string <- paste(paste(string, ifelse(separator == ";", "", " "), separator, "\n", sep = ""), paste(rep(" ", repeat.space), collapse=""), string.vector[j], sep="") startpoint <- j } else { string <- paste(string, ifelse(separator == ";", "", " "), separator, " ", string.vector[j], sep = "") } } else { if (outcome != "") { last.part <- paste(paste(string.vector[seq(startpoint, j - 1)], collapse = paste(ifelse(separator == ";", "", " "), separator, " ", sep="")), sep="") if (nchar(encodeString(paste(last.part, " ", sufnec, " ", outcome, sep = ""))) >= string.width) { string <- paste(paste(string, "\n", sep=""), paste(rep(" ", repeat.space), collapse=""), sufnec, " ", outcome, sep = "") } else { string <- paste(string, " ", sufnec, " ", outcome, sep = "") } } } } } else { if (outcome != "") { string <- paste(string, " ", sufnec, " ", outcome, sep = "") } } return(string) } admisc/R/replaceText.R0000644000176200001440000002404015161273642014325 0ustar liggesusers# Copyright (c) 2019 - 2026, 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. #' Replace text in a string #' #' Provides an improved method to replace strings, compared to function #' \bold{\code{gsub}()} in package \bold{\pkg{base}}. #' #' @name replaceText #' @rdname replaceText #' @rawRd #' \usage{ #' replaceText( #' expression = "", target = "", replacement = "", protect = "", #' boolean = FALSE, ...) #' } #' #' \arguments{ #' \item{expression}{Character string, usually a SOP - sum of products expression.} #' \item{target}{Character vector or a string containing the text to be replaced.} #' \item{replacement}{Character vector or a string containing the text to replace with.} #' \item{protect}{Character vector or a string containing the text to protect.} #' \item{boolean}{Treat characters in a boolean way, using upper and lower case letters.} #' \item{...}{Other arguments, from and to other functions.} #' } #' #' \details{ #' If the input expression is "J*JSR", and the task is to replace "J" with "A" and "JSR" with #' "B", function \bold{\code{gsub}()} is not very useful since the letter "J" is #' found in multiple places, including the second target. #' #' This function finds the exact location(s) of each target in the input string, starting with #' those having the largest number of characters, making sure the locations are unique. For #' instance, the target "JSR" is found on the location from 3 to 5, while the target "J" is #' is found on two locations 1 and 3, but 3 was already identified in the previously found #' location for the larger target. #' #' In addition, this function can also deal with target strings containing spaces. #' } #' #' #' \value{ #' The original string, replacing the target text with its replacement. #' } #' #' \author{ #' Adrian Dusa #' } #' #' #' \examples{ #' replaceText("J*JSR", "J, JSR", "A, B") #' #' # same output, on input expresions containing spaces #' replaceText("J*JS R", "J, JS R", "A, B") #' #' # works even with Boolean expressions, where lower case #' # letters signal the absence of the causal condition #' replaceText("DEV + urb*LIT", "DEV, URB, LIT", "A, B, C", boolean = TRUE) #' } #' #' \keyword{functions} NULL #' @export replaceText <- function( expression, target = "", replacement = "", protect = "", boolean = FALSE, ... ) { dots <- list(...) if (!is.character(target)) { stopError("The argument should be character.") } if (!is.character(replacement)) { stopError("The argument should be character.") } if (!isTRUE(dots$checknone)) { if (length(target) == 1 && !isFALSE(dots$checktarget)) { target <- splitstr(target) } if (length(replacement) == 1) replacement <- splitstr(replacement) if (length(protect) == 1) protect <- splitstr(protect) } if (length(target) != length(replacement)) { stopError("Length of target different from the length of replacement.") } torder <- order(nchar(target), decreasing = TRUE) tuplow <- target[torder] ruplow <- replacement[torder] protect <- protect[order(nchar(protect), decreasing = TRUE)] if ( all(target == toupper(target)) & all(expression != toupper(expression)) & !any(grepl("~", expression)) ) { boolean <- TRUE } if (boolean) { tuplow <- rep(toupper(tuplow), each = 2) ruplow <- rep(toupper(ruplow), each = 2) tuplow[seq(2, length(tuplow), by = 2)] <- tolower(tuplow[seq(2, length(tuplow), by = 2)]) ruplow[seq(2, length(ruplow), by = 2)] <- tolower(ruplow[seq(2, length(ruplow), by = 2)]) torder <- order(nchar(tuplow), decreasing = TRUE) tuplow <- tuplow[torder] ruplow <- ruplow[torder] } getPositions <- function(expression, x, y = NULL, protect = NULL) { if (identical(x, "")) { return(NULL) } positions <- vector(mode = "list", length = 0) pos <- 0 for (i in seq(length(x))) { escx <- gsub("([][{}*\\.])", "\\\\\\1", x[i]) locations <- gregexpr(escx, expression)[[1]] if (any(locations > 0)) { diffs <- c() for (l in seq(length(locations))) { tempd <- seq(locations[l], locations[l] + nchar(x[i]) - 1) if ( !any( is.element( tempd, c(unlist(positions), unlist(protect)) ) ) ) { diffs <- c(diffs, tempd) } } if (length(diffs) > 0) { if (length(diffs) == 1) { pos <- pos + 1 positions[[pos]] <- diffs names(positions)[pos] <- y[i] } else { start <- diffs[1] for (v in seq(2, length(diffs))) { if ((diffs[v] - diffs[v - 1]) > 1) { pos <- pos + 1 positions[[pos]] <- seq(start, diffs[v - 1]) if (!is.null(y)) { names(positions)[pos] <- y[i] } start <- diffs[v] } } pos <- pos + 1 positions[[pos]] <- seq(start, diffs[length(diffs)]) if (!is.null(y)) { names(positions)[pos] <- y[i] } } } } } return(positions) } posprotect <- NULL if (!identical(protect, "")) { larger <- tuplow[nchar(tuplow) > max(nchar(protect))] if (length(larger) > 0) { posprotect <- getPositions( expression, x = larger ) } } posprotect <- getPositions( expression, x = protect, protect = posprotect ) positions <- getPositions( expression, x = tuplow, y = ruplow, protect = posprotect ) covered <- logical(length(positions)) pos2 <- positions if (length(positions) > 1) { for (i in seq(length(pos2) - 1)) { if (!covered[i]) { for (j in seq(i + 1, length(pos2))) { if (!covered[j]) { if (all(is.element(seq(pos2[[j]][1], pos2[[j]][length(pos2[[j]])]), seq(pos2[[i]][1], pos2[[i]][length(pos2[[i]])])))) { covered[j] <- TRUE } } } } } } positions <- positions[!covered] if (length(positions) > 0) { first <- unlist(lapply(positions, "[[", 1)) positions <- positions[order(first, decreasing = TRUE)] expression <- unlist(strsplit(expression, split = "")) for (i in seq(length(positions))) { if (length(positions[[i]]) == 1) { expression[positions[[i]]] <- names(positions)[i] } if (length(positions[[i]] > 1)) { start <- positions[[i]][1] stop <- positions[[i]][length(positions[[i]])] if (start == 1) { expression <- c(names(positions)[i], expression[-seq(start, stop)]) } else { if (stop < length(expression)) { expression <- c(expression[seq(start - 1)], names(positions)[i], expression[seq(stop + 1, length(expression))]) } else { expression <- c(expression[seq(start - 1)], names(positions)[i]) } } } } expression <- paste(expression, collapse = "") } return(expression) } admisc/R/betweenQuotes.R0000644000176200001440000000455615161273642014711 0ustar liggesusers# Copyright (c) 2019 - 2026, 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. #' Extract information between quotes in a string #' #' Functions to extract the between the (escaped) quotes, in a string. #' #' @name betweenQuotes #' @rdname betweenQuotes #' @rawRd #' \usage{ #' betweenQuotes(x) #' } #' #' \arguments{ #' \item{x}{A string.} #' } #' #' #' \author{ #' Adrian Dusa #' } #' #' \examples{ #' x <- "An example of \"quoted\" text." #' #' betweenQuotes(x) #' } #' #' \keyword{functions} NULL #' @export `betweenQuotes` <- function(x) { pos <- gregexpr("\"", x) lpos <- length(pos[[1]]) if (lpos == 0) { return("") } else if (lpos%%2 != 0) { stopError("Odd number of quotes") } else { pos <- pos[[1]] result <- character(lpos) for (i in seq(1, lpos, by = 2)) { result[i] <- substr(x, pos[i] + 1, pos[i + 1] - 1) } return(result[nchar(result) > 0]) } } admisc/R/change.R0000644000176200001440000001101715161273642013272 0ustar liggesusers# Copyright (c) 2019 - 2026, 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. #' Generic function to change the structure of an object, function of the (changed) #' parameters used to create it. #' #' A generic function that applies different altering methods for different types #' of objects (of certain classes). #' #' @name change #' @rdname change #' @rawRd #' \usage{ #' change(x, ...) #' } #' #' \arguments{ #' \item{x}{An object of a particular class.} #' \item{...}{Arguments to be passed to a specific method.} #' } #' #' \details{ #' For the time being, this function is designed to change truth table objects (only). #' Future versions will likely add class methods for different other objects. #' } #' #' \value{ #' The changed object. #' } #' #' \author{ #' Adrian Dusa #' } #' #' \examples{ #' \dontrun{ #' # An example to change a QCA truth table #' library(QCA) #' #' ttLF <- truthTable(LF, outcome = SURV, incl.cut = 0.8) #' minimize(ttLF, include = "?") #' #' # excluding contradictory simplifying assumptions #' minimize( #' change(ttLF, exclude = findRows(type = 2)), #' include = "?" #' ) #' } #' } #' #' \keyword{functions} NULL #' @export `change` <- function(x, ...) { UseMethod("change") } #' @export `change.default` <- function(x, ...) { return(x) } #' @export `change.QCA_tt` <- function(x, ...) { metacall <- match.call(expand.dots = TRUE) callargs <- as.list(metacall[-1]) if (!requireNamespace("QCA", quietly = TRUE)) { enter <- ifelse(isFALSE(callargs$enter), "", "\n") message( paste( enter, "Error: Package QCA is needed to change a truth table.", enter, sep = "" ) ) return(invisible(character(0))) } nullargs <- sapply(callargs, is.null) nullnms <- names(nullargs)[nullargs] if (any(nullargs)) { callargs <- callargs[!nullargs] } if (length(callargs) == 1 & length(nullnms) == 0) { return(x) } object <- callargs[["x"]] `modify` <- function(x) { calls <- sapply(x, is.call) if (any(calls)) { for (i in which(calls)) { x[[i]] <- as.call(Recall(as.list(x[[i]]))) } } if (as.character(x[[1]]) == "findRows") { if (is.null(x$obj)) { x$obj <- object } } return(x) } callargs <- modify(callargs) callist <- as.list(x$call) ttname <- as.character(callargs[["x"]]) for (i in seq(2, length(callist))) { callist[[i]] <- admisc::recreate(callist[[i]]) } callist$data <- x$initial.data if (length(callargs) > 1) { for (i in seq(2, length(callargs))) { callargs[[i]] <- admisc::recreate(callargs[[i]]) } for (nm in names(callargs)[-1]) { callist[[nm]] <- callargs[[nm]] } } if (length(nullnms) > 0) { for (nm in nullnms) { callist[[nm]] <- NULL } } x <- do.call("truthTable", callist[-1]) callist$data <- ttname x$call <- as.call(callist) return(x) } admisc/R/coerceMode.R0000644000176200001440000000464115161273642014117 0ustar liggesusers# Copyright (c) 2019 - 2026, 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. #' Coerce an atomic vector to numeric or integer, if possible #' #' This function verifies if an R vector is possibly numeric, and further if the #' numbers inside are whole numbers. #' #' @name coerceMode #' @rdname coerceMode #' @rawRd #' \usage{ #' coerceMode(x) #' } #' #' \arguments{ #' \item{x}{An atomic R vector} #' } #' #' \value{ #' An R vector of coerced mode. #' } #' #' \author{ #' Adrian Dusa #' } #' #' \examples{ #' obj <- c("1.0", 2:5) #' #' is.integer(coerceMode(obj)) #' } #' #' \keyword{functions} NULL #' @export `coerceMode` <- function(x) { if (!is.atomic(x)) { stopError("The input is not atomic.") } if ( !is.numeric(x) && (possibleNumeric(x) || all(is.na(x))) ) { x <- asNumeric(x) } if ( !is.integer(x) && wholeNumeric(x) && is.null(tryCatchWEM(as.integer(x))) ) { x <- as.integer(x) } return(x) } admisc/src/0000755000176200001440000000000015161273643012311 5ustar liggesusersadmisc/src/utils.c0000644000176200001440000001000215161273642013605 0ustar liggesusers#include #include #include #include #include #include "utils.h" static R_INLINE unsigned long long int nchoosek(int n, int k) { if (k > n) return 0; if (k == 0 || k == n) return 1; unsigned long long int result = 1; if (k > n - k) { k = n - k; } for (int i = 0; i < k; i++) { if (result > ULLONG_MAX / (unsigned long long int) (n - i)) { return 0; } result *= (unsigned long long int) (n - i); if (result % (unsigned long long int) (i + 1) != 0) { return 0; } result /= (unsigned long long int) (i + 1); } return result; } void increment( int k, int *e, int *h, int nconds, int *tempk, int minval ) { if (k == 1) { tempk[0] += 1; } else { if (*e < nconds - *h) { *h = 1; tempk[k - 1] += 1; *e = tempk[k - 1]; if (tempk[k - 1] < minval) { tempk[k - 1] = minval; *e = minval; } } else { *e = tempk[k - *h - 1] + 1; ++*h; Rboolean under = TRUE; for (int j = 0; j < *h; j++) { under = under && (*e + j < minval); tempk[k - *h + j] = *e + j; } if (under) { *h = 1; tempk[k - *h] = minval; *e = minval; } } } } SEXP C_ombnk(SEXP list) { // ogte = at least one value greater than or equal to int nconds, k, ogte, zerobased; nconds = INTEGER(VECTOR_ELT(list, 0))[0]; k = INTEGER(VECTOR_ELT(list, 1))[0]; ogte = INTEGER(VECTOR_ELT(list, 2))[0] - 1; zerobased = INTEGER(VECTOR_ELT(list, 3))[0]; int nck = 1; for (int i = 1; i <= k; i++) { nck *= nconds - (k - i); nck /= i; } SEXP out; out = PROTECT(allocMatrix(INTSXP, k, nck)); int *p_out = INTEGER(out); int found = nck; int *valid = NULL; if (ogte > 0) { valid = (int *) R_Calloc(nck, int); found = 0; } #ifdef _OPENMP #pragma omp parallel for schedule(static, 1) reduction(+:found) #endif for (int task = 0; task < nck; task++) { #ifndef _OPENMP if (task > 0 && task % 1024 == 0) { R_CheckUserInterrupt(); } #endif int tempk[k]; unsigned long long int combination = (unsigned long long int) task; int x = 0; for (int i = 0; i < k; i++) { while (1) { unsigned long long int cval = nchoosek(nconds - (x + 1), k - (i + 1)); if (cval == 0 || cval > combination) { break; } combination -= cval; x++; } if (x < 0) { x = 0; } if (x >= nconds) { x = nconds - 1; } tempk[i] = x; x++; } Rboolean keep = (ogte <= 0) || (tempk[k - 1] >= ogte); if (ogte > 0) { valid[task] = keep; found += keep; } for (int i = 0; i < k; i++) { p_out[task * k + i] = tempk[i] + 1 - zerobased; } } R_CheckUserInterrupt(); if (ogte > 0 && found < nck) { SEXP copy = PROTECT(duplicate(out)); int *p_copy = INTEGER(copy); out = PROTECT(allocMatrix(INTSXP, k, found)); p_out = INTEGER(out); int col = 0; for (int task = 0; task < nck; task++) { if (task > 0 && task % 1024 == 0) { R_CheckUserInterrupt(); } if (valid[task]) { memcpy(&p_out[col * k], &p_copy[task * k], (size_t) k * sizeof(int)); col++; } } R_Free(valid); UNPROTECT(3); return(out); } if (valid) { R_Free(valid); } UNPROTECT(1); return(out); } admisc/src/Makevars.win0000644000176200001440000000011015161273642014570 0ustar liggesusersPKG_CFLAGS += $(SHLIB_OPENMP_CFLAGS) PKG_LIBS += $(SHLIB_OPENMP_CFLAGS) admisc/src/utils.h0000644000176200001440000000023215161273642013616 0ustar liggesusers #include void increment( int k, int *e, int *h, int nconds, int *tempk, int minval ); SEXP C_ombnk(SEXP list); admisc/src/Makevars0000644000176200001440000000010615161273642014001 0ustar liggesusersPKG_CFLAGS = $(SHLIB_OPENMP_CFLAGS) PKG_LIBS = $(SHLIB_OPENMP_CFLAGS) admisc/src/admisc.c0000644000176200001440000001503315161273642013716 0ustar liggesusers#include #include #include #include "admisc.h" #ifdef _OPENMP /* defines macro match that seems to break on some versions of Clang. See https://github.com/Bioconductor/SparseArray/blob/533a86a5fee60e5bcb2f5cd8c16f2019eca8ac04/src/thread_control.c#L7-L10 */ #undef match #include // a la package collapse #define OMP_NUM_PROCS omp_get_num_procs() #define OMP_THREAD_LIMIT omp_get_thread_limit() #define OMP_MAX_THREADS omp_get_max_threads() #else #define OMP_NUM_PROCS 1 #define OMP_THREAD_LIMIT 1 #define OMP_MAX_THREADS 1 #endif typedef union { double value; char byte[16]; } ieee_double; #ifdef WORDS_BIGENDIAN // First two bytes are sign & exponent // Last four bytes (that is, 32 bits) are 1954 const int TAG_BYTE = 3; #else const int TAG_BYTE = 4; #endif static R_INLINE Rboolean hasDimnames(SEXP matrix) { return !Rf_isNull(getAttrib(matrix, R_DimNamesSymbol)); } static R_INLINE Rboolean hasColnames(SEXP matrix) { return hasDimnames(matrix) ? !Rf_isNull(VECTOR_ELT(getAttrib(matrix, R_DimNamesSymbol), 1)) : FALSE; } static R_INLINE Rboolean hasRownames(SEXP matrix) { return hasDimnames(matrix) ? !Rf_isNull(VECTOR_ELT(getAttrib(matrix, R_DimNamesSymbol), 0)) : FALSE; } SEXP C_setDimnames(SEXP tt, SEXP dimnames) { setAttrib(tt, R_DimNamesSymbol, dimnames); return(R_NilValue); } SEXP C_setColnames(SEXP matrix, SEXP colnames) { SEXP dimnames = PROTECT(allocVector(VECSXP, 2)); SET_VECTOR_ELT(dimnames, 1, colnames); if (hasRownames(matrix)) { SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(getAttrib(matrix, R_DimNamesSymbol), 0)); } setAttrib(matrix, R_DimNamesSymbol, dimnames); UNPROTECT(1); return(R_NilValue); } SEXP C_setRownames(SEXP matrix, SEXP rownames) { SEXP dimnames = PROTECT(allocVector(VECSXP, 2)); SET_VECTOR_ELT(dimnames, 0, rownames); if (hasColnames(matrix)) { SET_VECTOR_ELT(dimnames, 1, VECTOR_ELT(getAttrib(matrix, R_DimNamesSymbol), 1)); } setAttrib(matrix, R_DimNamesSymbol, dimnames); UNPROTECT(1); return(R_NilValue); } SEXP _tag(SEXP x) { int n = Rf_length(x); SEXP out = PROTECT(Rf_allocVector(REALSXP, n)); for (int i = 0; i < n; ++i) { int nchars = Rf_length(STRING_ELT(x, i)); Rboolean firstminus = CHAR(STRING_ELT(x, i))[0] == CHAR(mkChar("-"))[0]; if (nchars > 2 + firstminus) { nchars = 2 + firstminus; } ieee_double y; y.value = NA_REAL; if (firstminus) { y.value = -1 * NA_REAL; } int bytepos = TAG_BYTE; for (int c = firstminus; c < nchars; c++) { y.byte[bytepos] = CHAR(STRING_ELT(x, i))[c]; if (TAG_BYTE == 3) { bytepos -= 1; } else { bytepos += 1; } } REAL(out)[i] = y.value; } UNPROTECT(1); return(out); } SEXP _any_tagged(SEXP x) { int n = Rf_length(x); SEXP out = PROTECT(Rf_allocVector(LGLSXP, 1)); LOGICAL(out)[0] = 0; int i = 0; while (!LOGICAL(out)[0] && i < n) { if (TYPEOF(x) == REALSXP) { double xi = REAL(x)[i]; if (isnan(xi)) { ieee_double y; y.value = xi; Rboolean firstminus = signbit(xi); char test[16 + 8 * firstminus]; if (firstminus) { test[0] = CHAR(mkChar("-"))[0]; } test[firstminus] = y.byte[TAG_BYTE]; LOGICAL(out)[0] = test[0] != '\0'; } } i += 1; } UNPROTECT(1); return out; } SEXP _has_tag(SEXP x, SEXP tag_) { int n = Rf_length(x); SEXP out = PROTECT(Rf_allocVector(LGLSXP, n)); if (TYPEOF(x) != REALSXP) { for (int i = 0; i < n; ++i) { LOGICAL(out)[i] = 0; } } else { for (int i = 0; i < n; ++i) { double xi = REAL(x)[i]; if (!isnan(xi)) { LOGICAL(out)[i] = false; } else { ieee_double y; y.value = xi; char tag = y.byte[TAG_BYTE]; Rboolean test = true; if (tag == '\0') { LOGICAL(out)[i] = false; } else { if (TYPEOF(tag_) != NILSXP) { int nchars = Rf_length(STRING_ELT(tag_, 0)); Rboolean firstminus = CHAR(STRING_ELT(tag_, 0))[0] == CHAR(mkChar("-"))[0]; if ((firstminus && !signbit(xi)) || (!firstminus && signbit(xi))) { LOGICAL(out)[i] = false; } else { if (nchars > 2 + firstminus) { nchars = 2 + firstminus; } test = test && tag == CHAR(STRING_ELT(tag_, 0))[firstminus]; char tag = y.byte[(TAG_BYTE == 4) ? 5 : 2]; if (Rf_length(STRING_ELT(tag_, 0)) > 1 && tag != '\0') { test = test && tag == CHAR(STRING_ELT(tag_, 0))[firstminus + 1]; } LOGICAL(out)[i] = test; } } else { LOGICAL(out)[i] = true; } } } } } UNPROTECT(1); return out; } SEXP _get_tag(SEXP x) { int n = Rf_length(x); SEXP out = PROTECT(Rf_allocVector(STRSXP, n)); for (int i = 0; i < n; ++i) { double xi = REAL(x)[i]; if (!isnan(xi)) { SET_STRING_ELT(out, i, NA_STRING); } else { ieee_double y; y.value = xi; Rboolean firstminus = signbit(xi); char test[16 + 8 * firstminus]; if (firstminus) { test[0] = CHAR(mkChar("-"))[0]; } test[firstminus] = y.byte[TAG_BYTE]; if (test[0] == '\0') { SET_STRING_ELT(out, i, NA_STRING); } else { char tag2 = y.byte[(TAG_BYTE == 4) ? 5 : 2]; int nchars = 1 + (strlen(&tag2) > 0) + firstminus; test[firstminus + 1] = tag2; SET_STRING_ELT(out, i, Rf_mkCharLenCE(test, nchars, CE_UTF8)); } } } UNPROTECT(1); return out; } admisc/src/admisc.h0000644000176200001440000000044415161273642013723 0ustar liggesusers#include #include "utils.h" SEXP C_setDimnames(SEXP tt, SEXP dimnames); SEXP C_setColnames(SEXP matrix, SEXP colnames); SEXP C_setRownames(SEXP matrix, SEXP rownames); SEXP _tag(SEXP x); SEXP _any_tagged(SEXP x); SEXP _has_tag(SEXP x, SEXP tag_); SEXP _get_tag(SEXP x); admisc/src/registerDynamicSymbol.c0000644000176200001440000000027615161273642017000 0ustar liggesusers#include #include #include void R_init_admisc(DllInfo *dll) { R_registerRoutines(dll, NULL, NULL, NULL, NULL); R_useDynamicSymbols(dll, TRUE); } admisc/NAMESPACE0000644000176200001440000000547315161273642012751 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method("[",admisc_fobject) S3method(asNumeric,declared) S3method(asNumeric,default) S3method(asNumeric,factor) S3method(change,QCA_tt) S3method(change,default) S3method(export,data.frame) S3method(export,default) S3method(export,list) S3method(inside,data.frame) S3method(inside,list) S3method(print,admisc_deMorgan) S3method(print,admisc_factorize) S3method(print,admisc_fobject) S3method(print,admisc_intersection) S3method(print,admisc_simplify) S3method(print,admisc_translate) S3method(recode,declared) S3method(recode,default) S3method(update,character) S3method(using,data.frame) S3method(using,default) S3method(using,matrix) export(aeqb) export(agtb) export(agteb) export(altb) export(alteb) export(aneqb) export(anyTagged) export(asNumeric) export(asSOP) export(betweenBrackets) export(betweenQuotes) export(change) export(checkMV) export(checkSubset) export(checkValid) export(classify) export(coerceMode) export(combnk) export(compute) export(curlyBrackets) export(dashes) export(deMorgan) export(doublequotes) export(expand) export(expandBrackets) export(export) export(factorize) export(frelevel) export(frev) export(getInfo) export(getLevels) export(getMatrix) export(getName) export(getNonChars) export(getTag) export(hasTag) export(hastilde) export(hclr) export(inside) export(insideBrackets) export(intersection) export(invert) export(listRDA) export(makeTag) export(mvSOP) export(negate) export(notilde) export(numdec) export(objRDA) export(outsideBrackets) export(overwrite) export(padBoth) export(padLeft) export(padRight) export(permutations) export(possibleNumeric) export(prettyString) export(prettyTable) export(recode) export(recreate) export(reload) export(removeSingleStars) export(replaceText) export(roundBrackets) export(scan.clipboard) export(setColnames) export(setDimnames) export(setRownames) export(simplify) export(simplifyList) export(singlequotes) export(solveBrackets) export(sop) export(sortExpressions) export(spaces) export(splitBrackets) export(splitMainComponents) export(splitPluses) export(splitStars) export(splitTildas) export(splitstr) export(squareBrackets) export(stopError) export(tildae) export(tilde1st) export(translate) export(trimstr) export(tryCatchWEM) export(uninstall) export(unload) export(using) export(validateNames) export(verify) export(wholeNumeric) export(write.clipboard) export(writePIs) export(writePrimeimp) importFrom(grDevices,hcl) importFrom(methods,is) importFrom(stats,dist) importFrom(stats,na.omit) importFrom(stats,relevel) importFrom(utils,capture.output) importFrom(utils,compareVersion) importFrom(utils,installed.packages) importFrom(utils,packageDescription) importFrom(utils,read.csv) importFrom(utils,remove.packages) importFrom(utils,tail) importFrom(utils,write.csv) importFrom(utils,write.table) useDynLib(admisc, .registration = TRUE) admisc/inst/0000755000176200001440000000000015161273642012476 5ustar liggesusersadmisc/inst/ChangeLog0000644000176200001440000002610315161273642014252 0ustar liggesusersVersion 0.40 o Function using() now correctly detects invisibly returned values o Package documentation now uses roxygen2 o Fixed situations when package QCA is needed but not installed Version 0.39 o Improved detection of sufficiency, in function recreate() o Fixed printing bug in objects of class "admisc_fobject", when expressions are evaluated using the "split.by" argument for a single variable o Function recode() now correctly preserves the labels for the declared missing values, if existing in the input data o If the input is a declared object, function recode() now allows providing a variable label for the resulting declared object, using the argument "label" (see also the argument "label" in function declared() from the package declared) o Function recode() now discards the labels for declared missing values, if no such declared values are found in the input data, for instance because of drop_na() o Bug fix in function recode(), the number of labels is now checked to be equal to the number of recodings o New class method for matrices (coerced to data frames) in function using() Version 0.38 o Bug fix in function recode() treating NA values using the argument cut o Improved function using() treating split.by argument and result printing o Function expand() now returns the snames as an attribute, if provided, and function translate() now detects it in the expression's attributes o Function writePrimeimp() renamed to writePIs() o Function negate() renamed to invert() o Former function invert() renamed to sopos() o Function finvert() renamed to frev() Version 0.37 o Better output for function using() with a vector of expressions o Function export() is now generic, allowing for class extensions o New S3 class extension for function update() to update a file (for the moment, specific to package DDIwR updating a DDI Codebook) Version 0.36 o Function recreate() now captures a tilde for global objects o Improved functions recode() and getInfo() for objects of class "declared" o New function betweenQuotes() o Function insideBrackets() is now deprecated, replaced by betweenBrackets() o Bug fixes in possibleNumeric(), where diacritics are detected as multi-byte characters, or when x has length 1 o Bug fixes in strsplit() and replaceText(), to avoid infinite loops calling each other Version 0.35 o Fixed recode() for the more recent treatment that c() is NULL o Improved function change() with respect to QCA truth tables o Function recreate() now recognizes "-.>" as a sufficiency operator o Small code improvements Version 0.34 o New function overwrite() o New function change() o Improved version of inside(), where now the argument "data" can be anything (including a list component) Version 0.33 o Minor changes to the internal function getInfo() o Employed hexadecimal representation for replacing special characters o More integration with the companion package QCA Version 0.32 o New functions setColnames(), setRownames() and setDimnames() o Bug fix in using(), when the split variable has missing range values Version 0.31 o New function inside(), as an alternative to the base function within() o New function scan.clipboard() o New argument "protect" in function replaceText() o Function using() is now generic, with exactly the same default functionality as the base function with() Version 0.30 o Improved treatment of multi-byte space characters in functions possibleNumeric() and asNumeric() o Function using() now accepts all types of variables for the "split.by" argument, that can be coerced to factors Version 0.29 o Functions asNumeric() and recode() are now generic, with class methods for factors and objects of class "declared" o New arguments "na_values" (for declared objects) in function recode() o Improved function getName() for more than one variable o New argument "object" in function getName() Version 0.28 o Bug fix in asNumeric() preserving classes for some types of objects o New arguments "levels" and "na_values" in function asNumeric() Version 0.27 o New argument "maxdec" in function numdec() o Correct way of checking the package QCA version for simplify() o More robust way to calculate expressions even when a condition is numeric, but of character mode Version 0.26 o New function numdec() to count the number of decimals in a possibly numeric value o Improved treatment of the "split.by" argument in function using() o Rewritten print method for resulting objects from function using(), now of a more general class "admisc_fobject" o Printing numerical vectors of class "admisc_fobject" are now automatically rounded to maximum three decimals Version 0.25 o Bug fix in function using(), function names were sometimes misinterpreted as column names in the data o Functions obj.rda() and list.rda() renamed to objRDA() and listRDA() o Dropped functions obj.rdata() and list.rdata() Version 0.24 o Fixed issue with too large whole numbers to be coerced to integers (thanks to Sarah Goslee for the report) o Function wholeNumeric() now returns FALSE for characters, instead of NA Version 0.23 o Bug fix in mvSOP(), for situations when some conditions are not present in the data o Bug fix in compute(), avoiding situations when mvSOP() fails o Improved possibleNumeric() and wholeNumeric() for logical vectors o New argument "bincat" for equality check functions (thanks to Brice Richard for the suggestion) Version 0.22 o Improved function tryCatchWEM(), now also returning the actual output value (thanks to John Fox for the suggestion) o New argument "regexp" to all brackets functions, extending functionality for any general purpose (thanks to Brice Richard for the suggestion) o New function using(), allowing to evaluate an expression in every subset of a split file o New function hclr(), to produce colors from the HCL spectrum o New function coerceMode(), to coerce objects to numeric or integer, if at all possible Version 0.21 o Bug fix in function negate(), expressions were not properly concatenated (thanks to Alessandra Costa for the report) Version 0.20 o New argument "each" in functions possibleNumeric() and wholeNumeric() Version 0.19 o New function asSOP(), to coerce a POS expression to a standard SOP format o New function mvSOP(), to coerce an expression from crisp set notation to multi-value notation Version 0.18 o Fixed bug affecting the function negate() when the SOP expression contains a single condition in one of the conjuncts / products (thanks to Michael Baumgartner for the report) o Fixed bug in asNumeric() preventing certain character objects of class "haven_labelled" to be converted as numeric o Improved function stopError(), printing error messages containing newline characters Version 0.17 o More robust support for multi-byte locales when detecting tilde and dash operators o Fixed bug in possibleNumeric() for objects of class declared Version 0.16 o New functions agtb(), altb() and aneqb() to test (in)equality of floats o New utility function getName() to return the name of the object being used in a function call o Fixed bug when recoding objects of class "declared" o Fixed bug detecting multibyte strings Version 0.15 o possibleNumeric() and asNumeric() are now more robust in situations with invalid multibyte strings o Argument "cuts" renamed to "cut" in function recode() o Fixed bug in function recode() that prevented creating ordered factors Version 0.12 o Solved bug in function translate() when called from plumber or callr (thanks to Trevor Strobel for the report) o Solved bug in dealing with expressions containing brackets with single letter conditions and no star signs to indicate conjunctions o New functions list.rda() and names.rda() o Small improvement of the recode() function Version 0.11 o New function finvert(), to invert a factor's values (and optional its levels) o New function frelevel(), an improved version of the base relevel() o New function permutations() o Improved version of combnk(), to cover input vectors of any type o Improved error trapping for functions negate() and simplify, when dealing with multivalue expressions Version 0.10 o Minor, internal functionality changes Version 0.9 o Solved bug in translate() recognizing column names for datasets with more than 27 columns (thanks to Sophia Birchinger for the report) o New function export(), moved here from package QCA Version 0.8 o Extended functionality to other types of vectors, such as having the class "haven_labelled" o Novel way of recognizing SOP expressions, even without quotes o New utility function recreate() to facilitate substitution Version 0.7 o Minor modification in function simplify(), to avoid the check error from the CRAN servers for the OS X platform Version 0.6 o Major modification (and *not* backwards compatible!) with respect to denoting negations. Using upper and lower case letters for presence and absence is no longer supported, a tilde being the only and the default method to signal a negation (thanks to Charles Ragin for making the point) o Removed deprecated argument "use.tilde" from all related functions o All functions treating a DNF/SOP expression now obey this major (and not backwards compatible) change denoting a negation. Upper and lower case conditions are no longer supported o All printing classes are now prefixed with "admisc", to avoid possible namespace collisions with (previous) versions of package QCA o New function invert() to convert a SOP expression to a POS expression (thanks to Charles Ragin for the suggestion) o New function expand() to perform a full or a partial Quine expansion to a SOP expression Version 0.5 o Functions compute(), factorize(), intersection(), negate() and simplify(), moved here from package QCA o New function replaceText() o Minor changes to internal functions getInfo() and getLevels() o Improved function translate() using replaceText(), now better suited in dealing with set names of variable number of characters, including space o As a result, argument "snames" from function venn() can deal with spaces in set names (thanks to Andre Gohr for the suggestion) Version 0.4 o Fixed small printing bug in possibleNumeric() o Function translate() is now more robust against non-printable characters Version 0.3 o Function combinations() renamed to combnk() o Improved function possibleNumeric() to deal with objects of class "haven_labelled" Version 0.2 o Function combinations() renamed to combnk() Version 0.1 o Start of the package admisc/build/0000755000176200001440000000000015161273643012621 5ustar liggesusersadmisc/build/partial.rdb0000644000176200001440000000007515161273643014750 0ustar liggesusers‹‹àb```b`aef`b1…À€… H02°0piÖ¼ÄÜÔb C"Éð+ƒ[7admisc/man/0000755000176200001440000000000015161273642012274 5ustar liggesusersadmisc/man/export.Rd0000644000176200001440000000333515161273642014110 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/export.R \name{export} \alias{export} \title{Export an object to a file or a connection} \description{ This is a generic function, usually a wrapper to \bold{\code{\link[utils]{write.table}()}}. } \usage{ export(what, ...) } \arguments{ \item{what}{The object to be written (matrix or dataframe)} \item{...}{Specific arguments to class functions.} } \details{ The default convention for \bold{\code{\link[utils]{write.table}()}} is to add a blank column name for the row names, but (despite it is a standard used for CSV files) that doesn't work with all spreadsheets or other programs that attempt to import the result of \bold{\code{\link[utils]{write.table}()}}. This function acts as if \bold{\code{\link[utils]{write.table}()}} was called, with only one difference: if row names are present in the dataframe (i.e. any of them should be different from the default row numbers), the final result will display a new column called \bold{\code{cases}} in the first position, except the situation that another column called \bold{\code{cases}} already exists in the data, when the row names will be completely ignored. If not otherwise specified, an argument \bold{\code{sep = ","}} is added by default. The argument \bold{\code{row.names}} is always set to FALSE, a new column being added anyways (if possible). Since this function pipes everything to \bold{\code{\link[utils]{write.table}()}}, the argument \bold{\code{file}} can also be a connection open for writing, and \bold{\code{""}} indicates output to the console. } \author{ Adrian Dusa } \seealso{ The \dQuote{R Data Import/Export} manual. \code{\link[utils]{write.table}} } \keyword{functions} admisc/man/overwrite.Rd0000644000176200001440000000363015161273642014613 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/overwrite.R \name{overwrite} \alias{overwrite} \title{Overwrite an object in a given environment.} \description{ Utility function to overwrite an object, and bypass the assignment operator. } \usage{ overwrite(objname, content, environment) } \arguments{ \item{objname}{Character, the name of the object to overwrite.} \item{content}{An R object} \item{environment}{The environment where to perform the overwrite procedure.} } \details{ \code{assign()} is sufficient when \code{objname} is a simple object name, such as \code{"bar"}. It is not sufficient when the target is an expression, such as \code{"bar$A"}. A call such as \code{assign(bar$A, 1, envir = parent.frame())} fails because \code{assign()} expects its first argument to evaluate to a character string. If that expression is first deparsed, for instance to \code{"bar$A"}, then \code{assign()} would create an object literally named \code{"bar$A"} in the target environment rather than replacing component \code{A} inside \code{bar}. This function handles both situations. For simple names, it overwrites the object directly in the target environment. For expressions, it reconstructs and evaluates the corresponding assignment call in that environment. } \value{ This function does not return anything. } \author{ Adrian Dusa } \examples{ foo <- function(object, x) { objname <- deparse(substitute(object)) overwrite(objname, x, parent.frame()) } bar <- 1 foo(bar, 2) bar # [1] 2 bar <- list(A = bar) foo(bar$A, 3) bar # $A # [1] 3 foo_assign <- function(object, x) { objname <- deparse(substitute(object)) assign(objname, x, envir = parent.frame()) } bar <- list(A = 1) try(assign(bar$A, 3, envir = parent.frame())) bar <- 1 foo_assign(bar, 2) bar # [1] 2 bar <- list(A = 1) foo_assign(bar$A, 3) bar # $A # [1] 1 `bar$A` # [1] 3 } \keyword{functions} admisc/man/tilde.Rd0000644000176200001440000000237515161273642013673 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tilde.R \name{hastilde} \alias{hastilde} \alias{notilde} \alias{tilde1st} \title{Tilde operations} \description{ Checks and changes expressions containing set negations using a tilde. } \usage{ hastilde(x) notilde(x) tilde1st(x) } \arguments{ \item{x}{A vector of values} } \details{ Boolean expressions can be negated in various ways. For binary crisp and fuzzy sets, one of the most straightforward ways to invert the set membership scores is to subtract them from 1. This is both possible using R vectors and also often used to signal a negation in SOP (sum of products) expressions. Some other times, SOP expressions can signal a set negation (also known as the absence of a causal condition) by using lower case letters, while upper case letters are used to signal the presence of a causal condition. SOP expressions also use a tilde to signal a set negation, immediately preceding the set name. This set of functions detect when and if a set present in a SOP expression contains a tilde (function \bold{\code{hastilde}}), whether the entire expression begins with a tilde (function \bold{\code{tilde1st}}). } \author{ Adrian Dusa } \examples{ hastilde("~A") } \keyword{functions} admisc/man/numerics.Rd0000644000176200001440000000467015161273642014417 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/asNumeric.R \name{asNumeric} \alias{asNumeric} \alias{possibleNumeric} \alias{wholeNumeric} \title{Numeric vectors} \description{ Coerces objects to class "numeric", and checks if an object is numeric. } \usage{ asNumeric(x, ...) possibleNumeric(x, each = FALSE) wholeNumeric(x, each = FALSE) } \arguments{ \item{x}{A vector of values} \item{each}{Logical, return the result for each value in the vector} \item{...}{Other arguments to be passed for class based methods} } \details{ Unlike the function \bold{\code{as.numeric}()} from the \bold{\pkg{base}} package, the function \bold{\code{asNumeric()}} coerces to numeric without a warning if any values are not numeric. All such values are considered NA missing. This is a generic function, with specific class methods for factors and objects of class \dQuote{declared}. The usual way of coercing factors to numeric is meaningless, converting the inner storage numbers. The class method of this particular function coerces the levels to numeric, via the default activated argument \code{levels}. For objects of class \dQuote{declared}, a similar argument called \code{na_values} is by default activated to coerce the declared missing values to numeric. The function \bold{\code{possibleNumeric()}} tests if the values in a vector are possibly numeric, irrespective of their storing as character or numbers. In the case of factors, it tests its levels representation. Function \bold{\code{wholeNumeric()}} tests if numbers in a vector are whole (round) numbers. Whole numbers are different from \dQuote{integer} numbers (which have special memory representation), and consequently the function \bold{\code{is.integer}()} tests something different, how numbers are stored in memory (see the description of function \bold{\code{\link[base]{double}()}} for more details). The function } \seealso{ \code{\link[base]{numeric}}, \code{\link[base]{integer}}, \code{\link[base]{double}} } \author{ Adrian Dusa } \examples{ x <- c("-.1", " 2.7 ", "B") asNumeric(x) # no warning f <- factor(c(3, 2, "a")) asNumeric(f) asNumeric(f, levels = FALSE) possibleNumeric(x) # FALSE possibleNumeric(x, each = TRUE) # TRUE TRUE FALSE possibleNumeric(c("1", 2, 3)) # TRUE is.integer(1) # FALSE # Signaling an integer in R is.integer(1L) # TRUE wholeNumeric(1) # TRUE wholeNumeric(c(1, 1.1), each = TRUE) # TRUE FALSE } \keyword{functions} admisc/man/intersection.Rd0000644000176200001440000000671515161273642015302 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/intersection.R \name{intersection} \alias{intersection} \title{Intersect expressions} \description{ This function takes two or more SOP expressions (combinations of conjunctions and disjunctions) or even entire minimization objects, and finds their intersection. } \usage{ intersection(..., snames = "", noflevels) } \arguments{ \item{...}{One or more expressions, combined with / or minimization objects of class \code{"QCA_min"}.} \item{snames}{A string containing the sets' names, separated by commas.} \item{noflevels}{Numerical vector containing the number of levels for each set.} } \details{ The initial aim of this function was to provide a software implementation of the intersection examples presented by Ragin (1987: 144-147). That type of example can also be performed with the function \bold{\code{simplify()}}, while this function is now mainly used in conjunction with the \bold{\code{\link[QCA]{modelFit}()}} function from package \bold{\pkg{QCA}}, to assess the intersection between theory and a QCA model. Irrespective of the input type (character expressions and / or minimiation objects), this function is now a wrapper to the main \bold{\code{simplify()}} function (which only accepts character expressions). It can deal with any kind of expressions, but multivalent crisp conditions need additional information about their number of levels, via the argument \bold{\code{noflevels}}. The expressions can be formulated in terms of either lower case - upper case notation for the absence and the presence of the causal condition, or use the tilde notation (see examples below). Usage of either of these is automatically detected, as long as all expressions use the same notation. If the \bold{\code{snames}} argument is provided, the result is sorted according to the order of the causal conditions (set names) in the original dataset, otherwise it sorts the causal conditions in alphabetical order. For minimzation objects of class \code{"QCA_min"}, the number of levels, and the set names are automatically detected. } \author{ Adrian Dusa } \references{ Ragin, Charles C. 1987. \emph{The Comparative Method: Moving beyond Qualitative and Quantitative Strategies}. Berkeley: University of California Press. } \examples{ # using minimization objects \dontrun{ library(QCA) # if not already loaded ttLF <- truthTable(LF, outcome = "SURV", incl.cut = 0.8) pLF <- minimize(ttLF, include = "?") # for example the intersection between the parsimonious model and # a theoretical expectation intersection(pLF, DEV*STB) # negating the model intersection(negate(pLF), DEV*STB) } # ----- # in Ragin's (1987) book, the equation E = SG + LW is the result # of the Boolean minimization for the ethnic political mobilization. # intersecting the reactive ethnicity perspective (R = lw) # with the equation E (page 144) intersection(~L~W, SG + LW, snames = c(S, L, W, G)) # resources for size and wealth (C = SW) with E (page 145) intersection(SW, SG + LW, snames = c(S, L, W, G)) # and factorized factorize(intersection(SW, SG + LW, snames = c(S, L, W, G))) # developmental perspective (D = L~G) and E (page 146) intersection(L~G, SG + LW, snames = c(S, L, W, G)) # subnations that exhibit ethic political mobilization (E) but were # not hypothesized by any of the three theories (page 147) # ~H = ~(~L~W + SW + L~G) intersection(negate(~L~W + SW + L~G), SG + LW, snames = c(S, L, W, G)) } \keyword{functions} admisc/man/frelevel.Rd0000755000176200001440000000161515161273642014375 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/frelevel.R \name{frelevel} \alias{frelevel} \title{Modified \code{relevel()} function} \description{ The base function \code{relevel()} accepts a single argument "ref", which can only be a scalar and not a vector of values. \code{frelevel()} accepts more (even all) levels and reorders them. } \usage{ frelevel(variable, levels) } \arguments{ \item{variable}{The categorical variable of interest} \item{levels}{One or more levels of the factor, in the desired order} } \value{A factor of the same length as the initial one.} \author{Adrian Dusa} \seealso{\code{\link[stats]{relevel}}} \examples{ words <- c("ini", "mini", "miny", "moe") variable <- factor(words, levels = words) # modify the order of the levels, keeping the order of the values frelevel(variable, c("moe", "ini", "miny", "mini")) } \keyword{functions} admisc/man/recreate.Rd0000644000176200001440000000441215161273642014356 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/recreate.R \name{recreate} \alias{recreate} \title{Facilitate expression substitution} \description{ Utility function based on \code{substitute()}, to recover an unquoted input. } \usage{ recreate(x, snames = NULL, ...) } \arguments{ \item{x}{A substituted input.} \item{snames}{A character string containing set names.} \item{...}{Other arguments, mainly for internal use.} } \details{ This function is especially useful when users have to provide lots of quoted inputs, such as the name of the columns from a data frame to be considered for a particular function. This is actually one of the main uses of the base function \bold{\code{\link[base]{substitute}()}}, but here it can be employed to also detect SOP (sum of products) expressions, explained for instance in function \bold{\code{\link{translate}()}}. Such SOP expressions are usually used in contexts of sufficieny and necessity, which are indicated with the usual signs \code{->} and \code{<-}. These are both allowed by the R parser, indicating standard assignment. Due to the R's internal parsing system, a sufficient expression using \code{->} is automatically flipped to a necessity statement \code{<-} with reversed LHS to RHS, but this function is able to determine what is the expression and what is the output. The other necessity code \code{<=} is also recognized, but the equivalent sufficiency code \code{=>} is not allowed in unquoted expressions. } \value{ A quoted, equivalent expression or a substituted object. } \author{ Adrian Dusa } \seealso{\code{\link[base]{substitute}}, \code{\link{simplify}}} \examples{ recreate(substitute(A + ~B*C)) foo <- function(x, ...) recreate(substitute(list(...))) foo(arg1 = 3, arg2 = A + ~B*C) df <- data.frame(A = 1, B = 2, C = 3, Y = 4) # substitute from the global environment # the result is the builtin C() function res <- recreate(substitute(C)) is.function(res) # TRUE # search first within the column name space from df recreate(substitute(C), colnames(df)) # "C" # necessity well recognized recreate(substitute(A <- B)) # but sufficiency is flipped recreate(substitute(A -> B)) # more complex SOP expressions are still recovered recreate(substitute(A + ~B*C -> Y)) } \keyword{functions} admisc/man/rdaFunctions.Rd0000644000176200001440000000210115161273642015214 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/listRDA.R \name{listRDA} \alias{listRDA} \alias{objRDA} \title{Load and list objects from an .rda file} \description{ Utility functions to read the names and load the objects from an .rda file, into an R list. } \usage{ listRDA(.filename) objRDA(.filename) } \arguments{ \item{.filename}{The path to the file where the R object is saved.} } \details{ Files with the extension .rda are routinely created using the base function \bold{\code{\link[base]{save}()}}. The function \bold{\code{listRDA()}} loads the object(s) from the .rda file into a list, preserving the object names in the list components. The .rda file can naturally be loaded with the base \bold{\code{\link[base]{load}()}} function, but in doing so the containing objects will overwrite any existing objects with the same names. The function \bold{\code{objRDA()}} returns the names of the objects from the .rda file. } \value{ A list, containing the objects from the loaded .rda file. } \author{ Adrian Dusa } \keyword{functions} admisc/man/tryCatchWEM.Rd0000644000176200001440000000243315161273642014717 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tryCatchWEM.R \name{tryCatchWEM} \alias{tryCatchWEM} \title{Try functions to capture warnings, errors and messages.} \description{ This function combines the base functions \bold{\code{tryCatch}()} and \bold{\code{withCallingHandlers}()} for the specific purpose of capturing not only errors and warnings but messages as well. } \usage{ tryCatchWEM(expr, capture = FALSE) } \arguments{ \item{expr}{Expression to be evaluated.} \item{capture}{Logical, capture the visible output.} } \details{ In some situations it might be important not only to test a function, but also to capture everything that is written in the R console, be it an error, a warning or simply a message. For instance package \bold{\pkg{QCA}} (version 3.4) has a Graphical User Interface that simulates an R console embedded into a web based \bold{\pkg{shiny}} app. It is not intended to replace function \bold{\code{tryCatch}()} in any way, especially not evaluating an expression before returning or exiting, it simply captures everything that is printed on the console (the visible output). } \value{ A list, if anything would be printed on the screen, or an empty (NULL) object otherwise. } \author{ Adrian Dusa } \keyword{functions} admisc/man/frev.Rd0000755000176200001440000000145715161273642013537 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/frev.R \name{frev} \alias{frev} \alias{finvert} \title{Inverts the values of a factor} \description{ Provides a reversed version of the values from a factor, for instance a Likert type response scale. } \usage{ frev(x, labels = FALSE) } \arguments{ \item{x}{A factor} \item{labels}{Logical, invert the labels as well} } \details{ The argument \code{labels} can also be used for the levels of a factor. } \value{A factor of the same length as the original one.} \author{Adrian Dusa} \examples{ words <- c("ini", "mini", "miny", "moe") variable <- factor(words, labels = words) # inverts the values, preserving the labels' order frev(variable) # inverts both values and labels frev(variable, labels = TRUE) } \keyword{misc} admisc/man/admisc_package.Rd0000644000176200001440000000243015161273642015475 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/admisc_package.R \name{admisc_package} \alias{admisc_package} \alias{admisc-package} \title{Adrian Dusa's Miscellaneous} \description{ Contains functions used across packages 'DDIwR', 'QCA' and 'venn'. Interprets and translates, factorizes and negates SOP - Sum of Products expressions, for both binary and multi-value crisp sets, and extracts information (set names, set values) from those expressions. Other functions perform various checks if possibly numeric (even if all numbers reside in a character vector) and coerce to numeric, or check if the numbers are whole. It also offers, among many others, a highly versatile recoding routine and some more flexible alternatives to the base functions \code{with()} and \code{within()}. SOP simplification functions in this package use related minimization from package \strong{QCA}, which is recommended to be installed despite not being listed in the Imports field, due to circular dependency issues. } \details{ \tabular{ll}{ Package: \tab admisc\cr Type: \tab Package\cr Version: \tab 0.40\cr Date: \tab 2026-03-26\cr License: \tab GPL (>= 3)\cr } } \author{ Adrian Dusa Maintainer: Adrian Dusa (dusa.adrian@unibuc.ro) } \keyword{"_PACKAGE"} \keyword{internal} admisc/man/using.Rd0000644000176200001440000000321415161273642013710 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/using.R \name{using} \alias{using} \alias{using.data.frame} \title{Evaluate an expression in a data environment} \description{ A function almost identical to the base function \code{with()}, but allowing to evaluate the expression in every subset of a split file. } \usage{ using(data, expr, split.by = NULL, ...) } \arguments{ \item{data}{A data frame.} \item{expr}{Expression to evaluate} \item{split.by}{A factor variable from the \code{data}, or a \code{declared}/\code{labelled} variable} \item{...}{Other internal arguments.} } \value{ A list of results, or a matrix if each separate result is a vector. } \author{ Adrian Dusa } \examples{ set.seed(123) DF <- data.frame( Area = factor(sample(c("Rural", "Urban"), 123, replace = TRUE)), Gender = factor(sample(c("Female", "Male"), 123, replace = TRUE)), Age = sample(18:90, 123, replace = TRUE), Children = sample(0:5, 123, replace = TRUE) ) # table of frequencies for Gender table(DF$Gender) # same with using(DF, table(Gender)) # same, but split by Area using(DF, table(Gender), split.by = Area) # calculate the mean age by gender using(DF, mean(Age), split.by = Gender) # same, but select cases from the urban area using(subset(DF, Area == "Urban"), mean(Age), split.by = Gender) # mean age by gender and area using(DF, mean(Age), split.by = Area & Gender) # same with using(DF, mean(Age), split.by = c(Area, Gender)) # average number of children by Area using(DF, mean(Children), split.by = Area) # frequency tables by Area using(DF, table(Children), split.by = Area) } \keyword{functions} admisc/man/hclr.Rd0000644000176200001440000000233015161273642013511 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/hclr.R \name{hclr} \alias{hclr} \title{Colors from the HCL spectrum} \description{ Produces colors from the HCL (Hue Chroma Luminance) spectrum, based on the number of levels from a factor. } \usage{ hclr(x, starth = 25, c = 50, l = 75, alpha = 1, fixup = TRUE) } \arguments{ \item{x}{Number of factor levels, or the factor itself, or a frequency distribution from a factor} \item{starth}{Starting point for the hue (in the interval 0 - 360)} \item{c}{chroma - color purity, small values produce dark and high values produce bright colors} \item{l}{color luminance - a number between 0 and 100} \item{alpha}{color transparency, where 0 is a completely transparent color, up to 1} \item{fixup}{logical, corrects the RGB values foto produce a realistic color} } \value{ The RBG code for the corresponding HCL colors. } \details{ Any value of \code{h} outside the interval 0 - 360 is constrained to this interval using modulo values. For instance, 410 is constrained to 50 = 410%%360. } \author{Adrian Dusa} \examples{ aa <- sample(letters[1:5], 100, replace = TRUE) hclr(aa) # same with hclr(5) # or hclr(table(aa)) } \keyword{misc} admisc/man/factorize.Rd0000644000176200001440000000607715161273642014563 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/factorize.R \name{factorize} \alias{factorize} \title{Factorize Boolean expressions} \arguments{ \item{input}{A string representing a SOP expression, or a minimization object of class \code{"qca"}.} \item{snames}{A string containing the sets' names, separated by commas.} \item{noflevels}{Numerical vector containing the number of levels for each set.} \item{pos}{Logical, if possible factorize using product(s) of sums.} \item{...}{Other arguments (mainly for backwards compatibility).} } \value{ A named list, each component containing all possible factorizations of the input expression(s), found in the name(s). } \description{ This function finds all combinations of common factors in a Boolean expression written in SOP - sum of products. It makes use of the function \bold{\code{\link{simplify}()}}, which uses the function \bold{\code{\link[QCA]{minimize}()}} from package \bold{\pkg{QCA}}). Users are highly encouraged to install and load that package, despite not being present in the Imports field (due to circular dependency issues). } \details{ Factorization is a process of finding common factors in a Boolean expression, written in SOP - sum of products. Whenever possible, the factorization can also be performed in a POS - product of sums form. Conjunctions should preferably be indicated with a star \code{*} sign, but this is not necessary when conditions have single letters or when the expression is expressed in multi-value notation. The argument \strong{\code{snames}} is only needed when conjunctions are not indicated by any sign, and the set names have more than one letter each (see function \code{translate()} for more details). The number of levels in \strong{\code{noflevels}} is needed only when negating multivalue conditions, and it should complement the \strong{\code{snames}} argument. If \strong{\code{input}} is an object of class \code{"qca"} (the result of the function \code{minimize()} from package \strong{QCA}), a factorization is performed for each of the minimized solutions. } \examples{ # typical example with redundant conditions factorize(a~b~cd + a~bc~d + a~bcd + abc~d) # results presented in alphabetical order factorize(~one*two*~four + ~one*three + three*~four) # to preserve a certain order of the set names factorize(~one*two*~four + ~one*three + three*~four, snames = c(one, two, three, four)) # using pos - products of sums factorize(~a~c + ~ad + ~b~c + ~bd, pos = TRUE) \dontrun{ # make sure the package QCA is loaded library(QCA) # using an object of class "qca" produced with function minimize() # in package QCA pCVF <- minimize(CVF, outcome = "PROTEST", incl.cut = 0.8, include = "?", use.letters = TRUE) factorize(pCVF) # using an object of class "deMorgan" produced with negate() factorize(negate(pCVF)) } } \references{ Ragin, C.C. (1987) \emph{The Comparative Method. Moving beyond qualitative and quantitative strategies}, Berkeley: University of California Press } \seealso{ \code{\link{translate}} } \author{ Adrian Dusa } \keyword{functions} admisc/man/clipboard.Rd0000644000176200001440000000105115161273642014517 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/scan.clipboard.R \name{scan.clipboard} \alias{scan.clipboard} \alias{write.clipboard} \title{Cross platform scan/write clipboard} \description{ Functions to read and write to the system's clipboard, for copy/paste operations. } \usage{ scan.clipboard(...) write.clipboard(x) } \arguments{ \item{x}{Object to be written to the clipboard} \item{...}{Same arguments that are used in the base function \bold{\code{scan}}} } \author{ Adrian Dusa } \keyword{functions} admisc/man/change.Rd0000644000176200001440000000204215161273642014006 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/change.R \name{change} \alias{change} \title{Generic function to change the structure of an object, function of the (changed) parameters used to create it.} \description{ A generic function that applies different altering methods for different types of objects (of certain classes). } \usage{ change(x, ...) } \arguments{ \item{x}{An object of a particular class.} \item{...}{Arguments to be passed to a specific method.} } \details{ For the time being, this function is designed to change truth table objects (only). Future versions will likely add class methods for different other objects. } \value{ The changed object. } \author{ Adrian Dusa } \examples{ \dontrun{ # An example to change a QCA truth table library(QCA) ttLF <- truthTable(LF, outcome = SURV, incl.cut = 0.8) minimize(ttLF, include = "?") # excluding contradictory simplifying assumptions minimize( change(ttLF, exclude = findRows(type = 2)), include = "?" ) } } \keyword{functions} admisc/man/brackets.Rd0000644000176200001440000000572415161273642014371 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/brackets.R \name{betweenBrackets} \alias{betweenBrackets} \alias{insideBrackets} \alias{outsideBrackets} \alias{curlyBrackets} \alias{squareBrackets} \alias{roundBrackets} \title{Extract information from a multi-value SOP/DNF expression} \arguments{ \item{x}{A DNF/SOP expression.} \item{type}{Brackets type: curly, round or square.} \item{invert}{Logical, if activated returns whatever is not within the brackets.} \item{outside}{Logical, if activated returns the condition names outside the brackets.} \item{regexp}{Optional regular expression to extract information with.} \item{expression}{A DNF/SOP expression.} \item{snames}{A string containing the sets' names, separated by commas.} \item{noflevels}{Numerical vector containing the number of levels for each set.} \item{simplify}{Logical, remove redundant expressions after expansion.} } \description{ Functions to extract information from an expression written in SOP, or in the canonical DNF, for multi-value causal conditions. They extract either the values within brackets, or the causal condition names outside the brackets. } \details{ Expressions written in SOP are used in Boolean logic, signaling a disjunction of conjunctions. These expressions are useful in Qualitative Comparative Analysis, a social science methodology used to search for causal configurations associated with a certain outcome. They are also used to draw Venn diagrams with package \code{venn}, which draws any kind of set intersection based on a custom SOP expression. \code{curlyBrackets()}, \code{squareBrackets()} and \code{roundBrackets()} are special cases of \code{betweenBrackets()} and \code{outsideBrackets()}, using curly, square or round brackets through the \code{type} argument. \code{outsideBrackets()} can also be seen as a special case of \code{betweenBrackets(invert = TRUE)}. SOP expressions are usually written using curly brackets for multi-value conditions but, to allow evaluation of unquoted expressions through R's parser, unquoted expressions should use square brackets and conjunctions should always use the product \code{*} sign. Sufficiency is recognized as \code{"=>"} in quoted expressions but this does not pass over R's parsing system in unquoted expressions. To overcome this problem, it is best to use the single arrow \code{"->"} notation. Necessity is recognized as either \code{"<="} or \code{"<-"}, both being valid in quoted and unquoted expressions. } \examples{ sop <- "A[1] + B[2]*C[0]" betweenBrackets(sop) betweenBrackets(sop, invert = TRUE) # unquoted (valid) SOP expressions are allowed, same result betweenBrackets(A[1] + B[2]*C[0]) # curly brackets are also valid in quoted expressions betweenBrackets("A{1} + B{2}*C{0}", type = "{") curlyBrackets("A{1} + B{2}*C{0}") curlyBrackets("A{1} + B{2}*C{0}", outside = TRUE) squareBrackets(A[1] + B[2]*C[0]) squareBrackets(A[1] + B[2]*C[0], outside = TRUE) } \author{ Adrian Dusa } \keyword{functions} admisc/man/getName.Rd0000644000176200001440000000241015161273642014140 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/getName.R \name{getName} \alias{getName} \title{Get the name of the object being used in a function call} \description{ This is a utility to be used inside a function. } \usage{ getName(x, object = FALSE) } \arguments{ \item{x}{String, expression to be evaluated} \item{object}{Logical, return the object's name} } \details{ Within a function, the argument \code{x} can be anything and it is usually evaluated as an object. This function should be used in conjunction with the base \code{match.call()}, to obtain the original name of the object being served as an input, regardless of how it is being served. A particular use case of this function relates to the cases when a variable within a data.frame is used. The overall name of the object (the data frame) is irrelevant, as the real object of interest is the variable. } \value{ A character vector of length 1. } \author{ Adrian Dusa } \examples{ foo <- function(x) { funargs <- sapply(match.call(), deparse)[-1] return(getName(funargs[1])) } dd <- data.frame(X = 1:5, Y = 1:5, Z = 1:5) foo(dd) # dd foo(dd$X) # X foo(dd[["X"]]) # X foo(dd[[c("X", "Y")]]) # X Y foo(dd[, 1]) # X foo(dd[, 2:3]) # Y Z } \keyword{functions} admisc/man/betweenQuotes.Rd0000644000176200001440000000071015161273642015413 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/betweenQuotes.R \name{betweenQuotes} \alias{betweenQuotes} \title{Extract information between quotes in a string} \description{ Functions to extract the between the (escaped) quotes, in a string. } \usage{ betweenQuotes(x) } \arguments{ \item{x}{A string.} } \author{ Adrian Dusa } \examples{ x <- "An example of \"quoted\" text." betweenQuotes(x) } \keyword{functions} admisc/man/inside.Rd0000644000176200001440000000312615161273642014040 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/inside.R \name{inside} \alias{inside} \alias{inside.list} \title{Evaluate an Expression in a Data Environment} \description{ Evaluate an R expression in an environment constructed from data. } \usage{ inside(data, expr, ...) \S3method{inside}{list}(data, expr, keepAttrs = TRUE, \dots) } \arguments{ \item{data}{Data to use for constructing an environment a \code{data frame} or a \code{list}.} \item{expr}{Expression to evaluate, often a \dQuote{compound} expression, i.e., of the form \preformatted{ { a <- somefun() b <- otherfun() ..... rm(unused1, temp) } }} \item{keepAttrs}{For the \code{\link{list}} method of \code{inside()}, a \code{\link{logical}} specifying if the resulting list should keep the \code{\link{attributes}} from \code{data} and have its \code{\link{names}} in the same order. Often this is unneeded as the result is a \emph{named} list anyway, and then \code{keepAttrs = FALSE} is more efficient.} \item{...}{Arguments to be passed to (future) methods.} } \details{ This is a modified version of the base R function \code{within()}, with exactly the same arguments and functionality but only one fundamental difference: instead of returning a modified copy of the input data, this function alters the data directly. } \author{ Adrian Dusa } \examples{ mt <- mtcars inside(mt, hwratio <- hp/wt) dim(mtcars) dim(mt) } \keyword{functions} admisc/man/SOPexpression.Rd0000644000176200001440000001751215161273642015352 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/SOPexpression.R \name{asSOP} \alias{asSOP} \alias{compute} \alias{expand} \alias{mvSOP} \alias{simplify} \alias{sop} \alias{translate} \title{Functions to interpret and manupulate a SOP/DNF expression} \description{ These functions interpret an expression written in sum of products (SOP) or in canonical disjunctive normal form (DNF), for both crisp and multivalue notations. The function \bold{\code{compute()}} calculates set membership scores based on a SOP expression applied to a calibrated data set (see function \bold{\code{\link[QCA]{calibrate}()}} from package \bold{\pkg{QCA}}), while the function \bold{\code{translate()}} translates a SOP expression into a matrix form. } \usage{ asSOP(expression = "", snames = "", noflevels = NULL) compute(expression = "", data = NULL, separate = FALSE, ...) expand(expression = "", snames = "", noflevels = NULL, partial = FALSE, implicants = FALSE, ...) mvSOP(expression = "", snames = "", data = NULL, keep.tilde = TRUE, ...) simplify(expression = "", snames = "", noflevels = NULL, ...) translate(expression = "", snames = "", noflevels = NULL, data = NULL, ...) } \arguments{ \item{expression}{String, a SOP expression.} \item{data}{A dataset with binary cs, mv and fs data.} \item{separate}{Logical, perform computations on individual, separate paths.} \item{snames}{A string containing the sets' names, separated by commas.} \item{noflevels}{Numerical vector containing the number of levels for each set.} \item{partial}{Logical, perform a partial Quine expansion.} \item{implicants}{Logical, return an expanded matrix in the implicants space.} \item{keep.tilde}{Logical, preserves the tilde sign when coercing a factor level} \item{...}{Other arguments, mainly for backwards compatibility.} } \details{ An expression written in sum of products (SOP), is a "union of intersections", for example \bold{\code{A*B + B*~C}}. The disjunctive normal form (DNF) is also a sum of products, with the restriction that each product has to contain all literals. The equivalent DNF expression is: \bold{\code{A*B*~C + A*B*C + ~A*B*~C}} The same expression can be written in multivalue notation: \bold{\code{A[1]*B[1] + B[1]*C[0]}}. Expressions can contain multiple values for the same condition, separated by a comma. If B was a multivalue causal condition, an expression could be: \bold{\code{A[1] + B[1,2]*C[0]}}. Whether crisp or multivalue, expressions are treated as Boolean. In this last example, all values in B equal to either 1 or 2 will be converted to 1, and the rest of the (multi)values will be converted to 0. Negating a multivalue condition requires a known number of levels (see examples below). Intersections between multiple levels of the same condition are possible. For a causal condition with 3 levels (0, 1 and 2) the following expression \bold{\code{~A[0,2]*A[1,2]}} is equivalent with \bold{\code{A[1]}}, while \bold{\code{A[0]*A[1]}} results in the empty set. The number of levels, as well as the set names can be automatically detected from a dataset via the argument \bold{\code{data}}. When specified, arguments \bold{\code{snames}} and \bold{\code{noflevels}} have precedence over \bold{\code{data}}. The product operator \bold{\code{*}} should always be used, but it can be omitted when the data is multivalue (where product terms are separated by curly brackets), and/or when the set names are single letters (for example \bold{\code{AD + B~C}}), and/or when the set names are provided via the argument \bold{\code{snames}}. When expressions are simplified, their simplest equivalent can result in the empty set, if the conditions cancel each other out. The function \bold{\code{mvSOP()}} assumes binary crisp conditions in the expression, except for categorical data used as multi-value conditions. The factor levels are read directly from the data, and they should be unique accross all conditions. } \value{ For the function \bold{\code{compute()}}, a vector of set membership values. For function \bold{\code{simplify()}}, a character expression. For the function \bold{\code{translate()}}, a matrix containing the implicants on the rows and the set names on the columns, with the following codes: \tabular{rl}{ 0 \tab absence of a causal condition\cr 1 \tab presence of a causal condition\cr -1 \tab causal condition was eliminated } The matrix was also assigned a class "translate", to avoid printing the -1 codes when signaling a minimized condition. The mode of this matrix is character, to allow printing multiple levels in the same cell, such as "1,2". For function \bold{\code{expand()}}, a character expression or a matrix of implicants. } \author{ Adrian Dusa } \references{ Ragin, C.C. (1987) \emph{The Comparative Method: Moving beyond Qualitative and Quantitative Strategies}. Berkeley: University of California Press. } \examples{ \dontrun{ # make sure the package QCA is loaded # ----- # for compute() library(QCA) compute(DEV*~IND + URB*STB, data = LF) # calculating individual paths compute(DEV*~IND + URB*STB, data = LF, separate = TRUE) } # ----- # for simplify() also make sure the package QCA is installed simplify(asSOP("(A + B)(A + ~B)")) # result is "A" # works even without the quotes simplify(asSOP((A + B)(A + ~B))) # result is "A" # but to avoid confusion POS expressions are more clear when quoted # to force a certain order of the set names simplify("(URB + LIT*~DEV)(~LIT + ~DEV)", snames = c(DEV, URB, LIT)) # multilevel conditions can also be specified (and negated) simplify("(A[1] + ~B[0])(B[1] + C[0])", snames = c(A, B, C), noflevels = c(2, 3, 2)) # Ragin's (1987) book presents the equation E = SG + LW as the result # of the Boolean minimization for the ethnic political mobilization. # intersecting the reactive ethnicity perspective (R = ~L~W) # with the equation E (page 144) simplify("~L~W(SG + LW)", snames = c(S, L, W, G)) # [1] "S~L~WG" # resources for size and wealth (C = SW) with E (page 145) simplify("SW(SG + LW)", snames = c(S, L, W, G)) # [1] "SWG + SLW" # and factorized factorize(simplify("SW(SG + LW)", snames = c(S, L, W, G))) # F1: SW(G + L) # developmental perspective (D = Lg) and E (page 146) simplify("L~G(SG + LW)", snames = c(S, L, W, G)) # [1] "LW~G" # subnations that exhibit ethnic political mobilization (E) but were # not hypothesized by any of the three theories (page 147) # ~H = ~(~L~W + SW + L~G) = GL~S + GL~W + G~SW + ~L~SW simplify("(GL~S + GL~W + G~SW + ~L~SW)(SG + LW)", snames = c(S, L, W, G)) # ----- # for translate() translate(A + B*C) # same thing in multivalue notation translate(A[1] + B[1]*C[1]) # tilde as a standard negation (note the condition "b"!) translate(~A + b*C) # and even for multivalue variables # in multivalue notation, the product sign * is redundant translate(C[1] + T[2] + T[1]*V[0] + C[0]) # negation of multivalue sets requires the number of levels translate(~A[1] + ~B[0]*C[1], snames = c(A, B, C), noflevels = c(2, 2, 2)) # multiple values can be specified translate(C[1] + T[1,2] + T[1]*V[0] + C[0]) # or even negated translate(C[1] + ~T[1,2] + T[1]*V[0] + C[0], snames = c(C, T, V), noflevels = c(2,3,2)) # if the expression does not contain the product sign * # snames are required to complete the translation translate(AaBb + ~CcDd, snames = c(Aa, Bb, Cc, Dd)) # to print _all_ codes from the standard output matrix (obj <- translate(A + ~B*C)) print(obj, original = TRUE) # also prints the -1 code # ----- # for expand() expand(~AB + B~C) # S1: ~AB~C + ~ABC + AB~C expand(~AB + B~C, snames = c(A, B, C, D)) # S1: ~AB~C~D + ~AB~CD + ~ABC~D + ~ABCD + AB~C~D + AB~CD # In implicants form: expand(~AB + B~C, snames = c(A, B, C, D), implicants = TRUE) # A B C D # [1,] 1 2 1 1 ~AB~C~D # [2,] 1 2 1 2 ~AB~CD # [3,] 1 2 2 1 ~ABC~D # [4,] 1 2 2 2 ~ABCD # [5,] 2 2 1 1 AB~C~D # [6,] 2 2 1 2 AB~CD } \keyword{functions} admisc/man/recode.Rd0000644000176200001440000001615315161273642014032 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/recode.R \name{recode} \alias{recode} \title{Recode a variable} \description{ Recodes a vector (numeric, character or factor) according to a set of rules. It is similar to the function \bold{\code{recode}()} from package \pkg{car}, but more flexible. It also has similarities with the function \bold{\code{\link[base]{findInterval}()}} from package \bold{\pkg{base}}. } \usage{ recode(x, rules = NULL, cut = NULL, values = NULL, ...) } \arguments{ \item{x}{A vector of mode numeric, character or factor.} \item{rules}{Character string or a vector of character strings for recoding specifications.} \item{cut}{A vector of one or more unique cut points.} \item{values}{A vector of output values.} \item{...}{Other parameters, for compatibility with other functions such as \bold{\code{recode}()} in package \pkg{car} but also \bold{\code{\link[base]{factor}()}} in package \bold{\pkg{base}}} } \details{ Similar to the \bold{\code{recode()}} function in package \pkg{car}, the recoding rules are separated by semicolons, of the form \bold{\code{input = output}}, and allow for: \tabular{rl}{ a single value \tab \bold{\code{1 = 0}}\cr a range of values \tab \bold{\code{2:5 = 1}}\cr a set of values \tab \bold{\code{c(6,7,10) = 2}}\cr \bold{\code{else}} \tab everything that is not covered by the previously specified rules } Contrary to the \bold{\code{recode}()} function in package \pkg{car}, this function allows the \bold{\code{:}} sequence operator (even for factors), so that a rule such as \bold{\code{c(1,3,5:7)}}, or \bold{\code{c(a,d,f:h)}} would be valid. Actually, since all rules are specified in a string, it really doesn't matter if the \bold{\code{c()}} function is used or not. For compatibility reasons it accepts it, but a more simple way to specify a set of rules is \bold{\code{"1,3,5:7=A; else=B"}} Special values \bold{\code{lo}} and \bold{\code{hi}} may also appear in the range of values, while \bold{\code{else}} can be used with \bold{\code{else=copy}} to copy all values which were not specified in the recoding rules. In the package \pkg{car}, a character \bold{\code{output}} would have to be quoted, like \bold{\code{"1:2='A'"}} but that is not mandatory in this function, \bold{\code{"1:2=A"}} would do just as well. Output values such as \bold{\code{"NA"}} or \bold{\code{"missing"}} are converted to \bold{\code{NA}}. Another difference from the \pkg{car} package: the output is \bold{not} automatically converted to a factor even if the original variable is a factor. That option is left to the user's decision to specify \bold{\code{as.factor.result}}, defaulted to \bold{\code{FALSE}}. A capital difference is the treatment of the values not present in the recoding rules. By default, package \pkg{car} copies all those values in the new object, whereas in this package the default values are \bold{\code{NA}} and new values are added only if they are found in the rules. Users can choose to copy all other values not present in the recoding rules, by specifically adding \bold{\code{else=copy}} in the rules. Since the two functions have the same name, it is possible that users loading both packages to use one instead of the other (depending which package is loaded first). In order to preserve functionality and minimize possible namespace collisions with package \pkg{car}, special efforts have been invested to ensure perfect compatibility with the other \bold{\code{recode}()} function (plus more). The argument \bold{\code{...}} allows for more arguments specific to the \pkg{car} package, such as \bold{\code{as.factor.result}}, \bold{\code{as.numeric.result}}. In addition, it also accepts \bold{\code{levels}}, \bold{\code{labels}} and \bold{\code{ordered}} specific to function \bold{\code{\link[base]{factor}()}} in package \bold{\pkg{base}}. When using the arguments \bold{\code{levels}} and / or \bold{\code{labels}}, the output will automatically be coerced to a factor, unless the argument \bold{\code{values}} is used, as indicated below. Blank spaces outside category labels are ignored, see the last example. It is possible to use \bold{\code{recode()}} in a similar way to function \bold{\code{cut()}}, by specifying a vector of cut points. For any number of such \bold{\code{c}} cut ploints, there should be \bold{\code{c + 1}} values. If not otherwise specified, the argument \bold{\code{values}} is automatically constructed as a sequence of numbers from \bold{\code{1}} to \bold{\code{c + 1}}. Unlike the function \bold{\code{cut()}}, arguments such as \bold{\code{include.lowest}} or \bold{\code{right}} are not necessary because the final outcome can be changed by tweaking the cut values. If both arguments \bold{\code{values}} and \bold{\code{labels}} are provided, the labels are going to be stored as an attribute. } \author{ Adrian Dusa } \examples{ x <- rep(1:3, 3) # [1] 1 2 3 1 2 3 1 2 3 recode(x, "1:2 = A; else = B") # [1] "A" "A" "B" "A" "A" "B" "A" "A" "B" recode(x, "1:2 = 0; else = copy") # [1] 0 0 3 0 0 3 0 0 3 set.seed(1234) x <- sample(18:90, 20, replace = TRUE) # [1] 45 39 26 22 55 33 21 87 31 73 79 21 21 38 57 73 84 22 83 64 recode(x, cut = "35, 55") # [1] 2 2 1 1 2 1 1 3 1 3 3 1 1 2 3 3 3 1 3 3 set.seed(1234) x <- factor(sample(letters[1:10], 20, replace = TRUE), levels = letters[1:10]) # [1] j f e i e f d b g f j f d h d d e h d h # Levels: a b c d e f g h i j recode(x, "b:d = 1; g:hi = 2; else = NA") # note the "hi" special value # [1] 2 NA NA 2 NA NA 1 1 2 NA 2 NA 1 2 1 1 NA 2 1 2 recode(x, "a, c:f = A; g:hi = B; else = C", labels = "A, B, C") # [1] B A A B A A A C B A B A A B A A A B A B # Levels: A B C recode(x, "a, c:f = 1; g:hi = 2; else = 3", labels = c("one", "two", "three"), ordered = TRUE) # [1] two one one two one one one three two one # [11] two one one two one one one two one two # Levels: one < two < three set.seed(1234) categories <- c("An", "example", "that has", "spaces") x <- factor(sample(categories, 20, replace = TRUE), levels = categories, ordered = TRUE) sort(x) # [1] An An An example example example example # [8] example example example example that has that has that has # [15] spaces spaces spaces spaces spaces spaces # Levels: An < example < that has < spaces recode(sort(x), "An : that has = 1; spaces = 2") # [1] 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 # single quotes work, but are not necessary recode(sort(x), "An : 'that has' = 1; spaces = 2") # [1] 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 # same using cut values recode(sort(x), cut = "that has") # [1] 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 # modifying the output values recode(sort(x), cut = "that has", values = 0:1) # [1] 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 # more treatment of "else" values x <- 10:20 # recoding rules don't overlap all existing values, the rest are empty recode(x, "8:15 = 1") # [1] 1 1 1 1 1 1 NA NA NA NA NA # all other values copied recode(x, "8:15 = 1; else = copy") # [1] 1 1 1 1 1 1 16 17 18 19 20 } \keyword{functions} admisc/man/permutations.Rd0000644000176200001440000000064015161273642015315 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/permutations.R \name{permutations} \alias{permutations} \title{Calculates the permutations of a vector} \description{ Generates all possible permutations of elements from a vector. } \usage{ permutations(x) } \arguments{ \item{x}{Any kind of vector.} } \author{ Adrian Dusa } \examples{ permutations(1:3) } \keyword{functions} admisc/man/admisc_internal.Rd0000644000176200001440000000211015161273642015711 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/admisc_internal.R \name{admisc_internal} \alias{admisc_internal} \alias{anyTagged} \alias{checkMV} \alias{checkSubset} \alias{classify} \alias{dashes} \alias{doublequotes} \alias{expandBrackets} \alias{getInfo} \alias{getLevels} \alias{getMatrix} \alias{getNonChars} \alias{getTag} \alias{hasTag} \alias{makeTag} \alias{negateLoop} \alias{padLeft} \alias{padRight} \alias{padBoth} \alias{prettyString} \alias{prettyTable} \alias{reload} \alias{removeSingleStars} \alias{splitMainComponents} \alias{splitstr} \alias{splitBrackets} \alias{splitPluses} \alias{splitProducts} \alias{splitStars} \alias{splitTildas} \alias{solveBrackets} \alias{sortExpressions} \alias{simplifyList} \alias{singlequotes} \alias{spaces} \alias{stopError} \alias{tildae} \alias{trimstr} \alias{uninstall} \alias{unload} \alias{checkValid} \alias{validateNames} \alias{verify} \alias{writePIs} \alias{writePrimeimp} \title{admisc internal functions} \description{ Functions to be used internally in package \code{admisc}. } \keyword{internal} admisc/man/equality.Rd0000644000176200001440000000302615161273642014421 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/equality.R \name{agtb} \alias{agtb} \alias{altb} \alias{agteb} \alias{alteb} \alias{aeqb} \alias{aneqb} \title{Check difference and / or (in)equality of numbers} \description{ Check if one number is greater / lower than (or equal to) another. } \usage{ agtb(a, b, bincat) altb(a, b, bincat) agteb(a, b, bincat) alteb(a, b, bincat) aeqb(a, b, bincat) aneqb(a, b, bincat) } \arguments{ \item{a}{Numerical vector} \item{b}{Numerical vector} \item{bincat}{Binary categorization values, an atomic vector of length 2} } \details{ Not all numbers (especially the decimal ones) can be represented exactly in floating point arithmetic, and their arithmetic may not give the normal expected result. This set of functions check for the in(equality) between two numerical vectors a and b, with the following name convention: \bold{\code{gt}} means \dQuote{greater than} \bold{\code{lt}} means a \dQuote{lower than} b \bold{\code{gte}} means a \dQuote{greater than or equal to} b \bold{\code{lte}} means a \dQuote{lower than or equal to} b \bold{\code{eq}} means a \dQuote{equal to} b \bold{\code{neq}} means a \dQuote{not equal to} b The argument \bold{\code{values}} is useful to replace the TRUE / FALSE values with custom categories. } \author{ Adrian Dusa } \references{ Goldberg, David (1991) "What Every Computer Scientist Should Know About Floating-point Arithmetic", ACM Computing Surveys vol.23, no.1, pp.5-48, \doi{10.1145/103162.103163} } \keyword{functions} admisc/man/coerceMode.Rd0000644000176200001440000000104415161273642014627 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/coerceMode.R \name{coerceMode} \alias{coerceMode} \title{Coerce an atomic vector to numeric or integer, if possible} \description{ This function verifies if an R vector is possibly numeric, and further if the numbers inside are whole numbers. } \usage{ coerceMode(x) } \arguments{ \item{x}{An atomic R vector} } \value{ An R vector of coerced mode. } \author{ Adrian Dusa } \examples{ obj <- c("1.0", 2:5) is.integer(coerceMode(obj)) } \keyword{functions} admisc/man/invert.Rd0000644000176200001440000000641315161273642014076 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/invert.R \name{invert} \alias{invert} \alias{negate} \alias{sopos} \alias{deMorgan} \title{Negate Boolean expressions} \description{ Functions to negate a DNF/SOP expression, or to invert a SOP to a negated POS or a POS to a negated SOP. } \usage{ invert(input, snames = "", noflevels, simplify = TRUE, ...) sopos(input, snames = "", noflevels) } \arguments{ \item{input}{A string representing a SOP expression, or a minimization object of class \code{"QCA_min"}.} \item{snames}{A string containing the sets' names, separated by commas.} \item{noflevels}{Numerical vector containing the number of levels for each set.} \item{simplify}{Logical, allow users to choose between the raw negation or its simplest form.} \item{...}{Other arguments (mainly for backwards compatibility).} } \details{ In Boolean algebra, there are two transformation rules named after the British mathematician Augustus De Morgan. These rules state that: 1. The complement of the union of two sets is the intersection of their complements. 2. The complement of the intersection of two sets is the union of their complements. In "normal" language, these would be written as: 1. \code{not (A and B) = (not A) or (not B)} 2. \code{not (A or B) = (not A) and (not B)} Based on these two laws, any Boolean expression written in disjunctive normal form can be transformed into its negation. It is also possible to negate all models and solutions from the result of a Boolean minimization from function \bold{\code{\link[QCA]{minimize}()}} in package \bold{\code{QCA}}. The resulting object, of class \code{"qca"}, is automatically recognised by this function. In a SOP expression, the products should normally be split by using a star \bold{\code{*}} sign, otherwise the sets' names will be considered the individual letters in alphabetical order, unless they are specified via \bold{\code{snames}}. To negate multilevel expressions, the argument \bold{\code{noflevels}} is required. It is entirely possible to obtain multiple negations of a single expression, since the result of the negation is passed to function \bold{\code{\link{simplify}()}}. Function \bold{\code{sopos}()} simply transforms an expression from a sum of products (SOP) to a negated product of sums (POS), and the other way round. } \value{ A character vector when the input is a SOP expresison, or a named list for minimization input objects, each component containing all possible negations of the model(s). } \author{ Adrian Dusa } \references{ Ragin, Charles C. 1987. \emph{The Comparative Method: Moving beyond Qualitative and Quantitative Strategies}. Berkeley: University of California Press. } \seealso{\code{\link[QCA]{minimize}}, \code{\link{simplify}}} \examples{ # example from Ragin (1987, p.99) invert(AC + B~C, simplify = FALSE) # the simplified, logically equivalent negation invert(AC + B~C) # with different intersection operators invert(AB*EF + ~CD*EF) # invert to POS invert(a*b + ~c*d) \dontrun{ # using an object of class "qca" produced with minimize() # from package QCA library(QCA) cLC <- minimize(LC, outcome = SURV) invert(cLC) # parsimonious solution pLC <- minimize(LC, outcome = SURV, include = "?") invert(pLC) } } \keyword{functions} admisc/man/combnk.Rd0000644000176200001440000000225415161273642014037 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/combnk.R \name{combnk} \alias{combnk} \title{Generate all combinations of n numbers, taken k at a time} \description{ A fast function to generate all possible combinations of n numbers, taken k at a time, starting from the first k numbers or starting from a combination that contain a certain number. } \usage{ combnk(n, k, ogte = 0, zerobased = FALSE) } \arguments{ \item{n}{Vector of any kind, or a numerical scalar.} \item{k}{Numeric scalar.} \item{ogte}{At least one value greater than or equal to this number.} \item{zerobased}{Logical, zero or one based.} } \details{ When a scalar, argument \code{n} should be numeric, otherwise when a vector its length should not be less than \code{k}. When the argument \bold{\code{ogte}} is specified, the combinations will sequentially be incremented from those which contain a certain number, or a certain position from \code{n} when specified as a vector. } \value{ A matrix with \code{k} rows and \code{choose(n, k)} columns. } \author{ Adrian Dusa } \examples{ combnk(5, 2) combnk(5, 2, ogte = 3) combnk(letters[1:5], 2) } \keyword{functions} admisc/man/dimnames.Rd0000644000176200001440000000143315161273642014361 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dimnames.R \name{setColnames} \alias{setColnames} \alias{dimnames} \alias{setRownames} \alias{setDimnames} \title{Set matrix row or column names} \description{ Set matrix row or column names without copying, especially useful for (very) large matrices. } \usage{ setColnames(matrix, colnames) setRownames(matrix, rownames) setDimnames(matrix, nameslist) } \arguments{ \item{matrix}{An R matrix} \item{colnames}{Character vector of column names} \item{rownames}{Character vector of row names} \item{nameslist}{A two-component list containing rownames and colnames} } \author{ Adrian Dusa } \examples{ mat <- matrix(1:9, nrow = 3) setDimnames(mat, list(LETTERS[1:3], letters[1:3])) } \keyword{functions} admisc/man/numdec.Rd0000644000176200001440000000135415161273642014041 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/numdec.R \name{numdec} \alias{numdec} \title{Count number of decimals} \description{ Calculates the (maximum) number of decimals in a possibly numeric vector. } \usage{ numdec(x, each = FALSE, na.rm = TRUE, maxdec = 15) } \arguments{ \item{x}{A vector of values} \item{each}{Logical, return the result for each value in the vector} \item{na.rm}{Logical, ignore missing values} \item{maxdec}{Maximal number of decimals to count} } \author{ Adrian Dusa } \examples{ x <- c(12, 12.3, 12.34) numdec(x) # 2 numdec(x, each = TRUE) # 0, 1, 2 x <- c("-.1", " 2.75 ", "12", "B", NA) numdec(x) # 2 numdec(x, each = TRUE) # 1, 2, 0, NA, NA } \keyword{functions} admisc/man/replaceText.Rd0000644000176200001440000000403615161273642015046 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/replaceText.R \name{replaceText} \alias{replaceText} \title{Replace text in a string} \description{ Provides an improved method to replace strings, compared to function \bold{\code{gsub}()} in package \bold{\pkg{base}}. } \usage{ replaceText( expression = "", target = "", replacement = "", protect = "", boolean = FALSE, ...) } \arguments{ \item{expression}{Character string, usually a SOP - sum of products expression.} \item{target}{Character vector or a string containing the text to be replaced.} \item{replacement}{Character vector or a string containing the text to replace with.} \item{protect}{Character vector or a string containing the text to protect.} \item{boolean}{Treat characters in a boolean way, using upper and lower case letters.} \item{...}{Other arguments, from and to other functions.} } \details{ If the input expression is "J*JSR", and the task is to replace "J" with "A" and "JSR" with "B", function \bold{\code{gsub}()} is not very useful since the letter "J" is found in multiple places, including the second target. This function finds the exact location(s) of each target in the input string, starting with those having the largest number of characters, making sure the locations are unique. For instance, the target "JSR" is found on the location from 3 to 5, while the target "J" is is found on two locations 1 and 3, but 3 was already identified in the previously found location for the larger target. In addition, this function can also deal with target strings containing spaces. } \value{ The original string, replacing the target text with its replacement. } \author{ Adrian Dusa } \examples{ replaceText("J*JSR", "J, JSR", "A, B") # same output, on input expresions containing spaces replaceText("J*JS R", "J, JS R", "A, B") # works even with Boolean expressions, where lower case # letters signal the absence of the causal condition replaceText("DEV + urb*LIT", "DEV, URB, LIT", "A, B, C", boolean = TRUE) } \keyword{functions} admisc/DESCRIPTION0000644000176200001440000000312415161417511013222 0ustar liggesusersPackage: admisc Version: 0.40 SystemRequirements: OpenMP (optional) Title: Adrian Dusa's Miscellaneous Authors@R: person( given = "Adrian", family = "Dusa", role = c("aut", "cre", "cph"), email = "dusa.adrian@unibuc.ro", comment = c(ORCID = "0000-0002-3525-9253")) URL: https://github.com/dusadrian/admisc BugReports: https://github.com/dusadrian/admisc/issues Depends: R (>= 3.5.0) Imports: methods Suggests: QCA (>= 3.7) Description: Contains functions used across packages 'DDIwR', 'QCA' and 'venn'. Interprets and translates, factorizes and negates SOP - Sum of Products expressions, for both binary and multi-value crisp sets, and extracts information (set names, set values) from those expressions. Other functions perform various other checks if possibly numeric (even if all numbers reside in a character vector) and coerce to numeric, or check if the numbers are whole. It also offers, among many others, a highly versatile recoding routine and some more flexible alternatives to the base functions 'with()' and 'within()'. SOP simplification functions in this package use related minimization from package 'QCA', which is recommended to be installed despite not being listed in the Imports field, due to circular dependency issues. License: GPL (>= 3) Encoding: UTF-8 RoxygenNote: 7.3.3 NeedsCompilation: yes Packaged: 2026-03-26 18:14:59 UTC; dusadrian Author: Adrian Dusa [aut, cre, cph] (ORCID: ) Maintainer: Adrian Dusa Repository: CRAN Date/Publication: 2026-03-27 06:10:17 UTC