admisc/0000755000176200001440000000000015101572761011517 5ustar liggesusersadmisc/MD50000644000176200001440000001134415101572761012032 0ustar liggesusersa01b838490e30c84598f7e7ce439da60 *DESCRIPTION 2093e173e8bab930970c36a475c0a3ff *NAMESPACE e05afd167a6110ba9ca82fd3a7897521 *R/asNumeric.R cc654a05178cf2e24710b27d53d31be4 *R/asSOP.R c54e585914b27a8a4a0baf80a523fe78 *R/betweenQuotes.R cb9276ed411c64f28f269f8a821f6ef0 *R/brackets.R 3fd459fb8c32de84e21629e738d593d5 *R/change.R c9dbd419577f6d8f50a221bbe1e6c1ee *R/checkMV.R 9f842594d143406dbb4b511a3b3db46f *R/checkSubset.R dd225d13a9dde98f4e0fb88c4d4d0efe *R/checkValid.R c5533a25b6dbe4294a26a16c42222ced *R/classify.R 9bd267d26f115d3589c3b043c0e14b48 *R/coerceMode.R 634f37e5619f22146c0639f08acc3e08 *R/combnk.R 84f5a135c0c49d323edb8ace0eb8dac8 *R/compute.R af1f2a9a5dd5a2db9777ebb076d73bcb *R/dimnames.R 4dcfe910af9d6c0761ecdb2b3f0ff290 *R/equality.R a8374c600df82bfb644255a0d1b33cf5 *R/expand.R 5d0c2e6d6f01338f5dee9066e07a8ac9 *R/export.R 4e6ba83ce4cc5428891a70720d4c04e7 *R/factorize.R 1b682109e6536f69a672c6e7dad25334 *R/frelevel.R 9368369d5405d02a2783eb09418938a3 *R/frev.R 847324b4054162cbece9a3b7d8a82252 *R/getInfo.R bbfa134c3d68f703e57432c768f5dfa9 *R/getLevels.R d7fe64591bcabed0d0b879d372739eb7 *R/getMatrix.R 3c83e74bfc9409cc9171b6240c3a06d2 *R/getName.R ab481444da4199ffeb30edae6eb252d2 *R/hclr.R 87f3b79919b781b72776b1e192162ca5 *R/inside.R d7721e194eb5e791e9c9908f630539fb *R/intersection.R 3beb51dafbc26330170ef2f38494ba5b *R/invert.R 5e44d5945f9a26b7a530e241c542a66c *R/listRDA.R c5ca6c95383e76a43be5fa8a81cba1aa *R/mvSOP.R 56d231b2a103d37cb5bbe580f0711a59 *R/numdec.R cbf7ff7c1ae50c0a99a7279f96e8cd4b *R/objRDA.R 3e588bd8c8902bebceaab792be6876c4 *R/onLoad.R 85ff972493f76ae1cd081847fa53fa5d *R/overwrite.R 9c8dc302ff064dbeeda23932267200fd *R/pad.R 11456904a8b3616f0cdcd4b30ca749c8 *R/permutations.R 9b5f9c1f73a696d455865924f21393a1 *R/possibleNumeric.R 32d64b0c03b06877aa24414c9243b017 *R/prettyString.R 050e01bdf5db427539853442aeec1d84 *R/prettyTable.R be455c6bce5e7fbc46d0f0f95b5d293a *R/print.R 943f044e02c6b7ea9f421a703f1bfb75 *R/recode.R 2b4c96fc92ac22eaf7308013f3f5251f *R/recreate.R 178e101d12f817d7aafa0a46acbae248 *R/reload.R 7d8c53f8198b410b175d783e306b9d80 *R/replaceText.R a15ce8bde629f6a7211da19da4df004e *R/scan.clipboard.R 97bad3bfa8c28ebb333276b525ceff28 *R/simplify.R 66c2f17f30990fbf688c88a5d04f49a9 *R/sopos.R ad690f69acb772334edb141582a717ef *R/sortExpressions.R 1d2f3b92ddd3724dd579d6182721f40e *R/stopError.R 2801b5f0b8198394abf998bfe831acc1 *R/string.R fe93d9c75c66545bb2994338ff8f037c *R/tagged.R edafa671eec5cb9b64be899330ed303f *R/tilde.R b716453be37315e175e1cc33a50d9244 *R/translate.R bea433e38fcc89c8578d64488be1486b *R/tryCatchWEM.R 69089a6950afe48283e16746402a191e *R/unicode.R 9dbd45f3a6666e57642bba8029f68f1a *R/uninstall.R 5dffa57192b340e69821430a5a87e0e6 *R/unload.R 4570d78595f1a3dddb733542eb3b66a1 *R/update.R fe0af95bd2469141955de57216845211 *R/using.R d5c14a823bea93808150c3137e8b1ee8 *R/validateNames.R 516a466ea232521aab79054ced6ff1a2 *R/verify.R 424d380e5dc7ed29fcdce25dced8961d *R/wholeNumeric.R c3ee2542680e39ebbd4f2989296821b7 *R/write.clipboard.R e16f61b224b5b102d43e87c12906211c *R/writePIs.R 1bf18d9c216b8d95033f0bd2fe2906b2 *build/partial.rdb 78f0678492d2a0963c09bdf98046969b *inst/ChangeLog 210724e3bcdc7f5a6339a175e8c430d3 *man/SOPexpression.Rd 691e9049ebd8e9e22d5c76316f8240e8 *man/admisc_internal.Rd c6216da6811338fc6d30ea1d2bcaa936 *man/admisc_package.Rd 28e4541fe439f29aeb37f125c9eb5143 *man/betweenQuotes.Rd 45ec3088e511a3a625499372ceda0f87 *man/brackets.Rd 783dfe5e8a810643efd8707a84b00ccd *man/change.Rd 2e2d468d88a4bac7461d5b571019cdf3 *man/clipboard.Rd e1dc81ec1f3e307e9a2ba4cb424767b7 *man/coerceMode.Rd 6d29a4eb6fd2b09b29ea90ddf24ab41e *man/combnk.Rd c3b4de7519e0d58bdad64159a433f25b *man/dimnames.Rd 3d9602f21fd943df480e8f1139c17d3d *man/equality.Rd debcc8a43de4884732ef45f4a9afa255 *man/export.Rd 2a6a41d16a8350f315eab35d329d679e *man/factorize.Rd aa29f9722645a38b9cdc2ed88cfbe0a9 *man/frelevel.Rd 2fb7a023c7b1de7f3456ecfffb21d7c2 *man/frev.Rd 75989985fb8801054e27721b385e3264 *man/getName.Rd 5e9d411c2b8392f00b025c0b66356b93 *man/hclr.Rd b22cd24b5de9ac8a685c4d1223ad33c3 *man/inside.Rd a518151e751acbb73712e0c6f3b397e8 *man/intersection.Rd 27921e5b9673f1cbb343677df2300f06 *man/invert.Rd e3ab2ae5163ad71856cf66453459a9de *man/numdec.Rd 8518107d9379eb475fefe71f869ca6eb *man/numerics.Rd 56e3fd7225f59e14f0446ccbce438f55 *man/overwrite.Rd 427bb8c7134df056ec054e7469ae9547 *man/permutations.Rd c6d08db7c59e5f02461c5883742e643c *man/rdaFunctions.Rd ad5e5f7ebe481105b990c25dfa5db7a6 *man/recode.Rd 42d75e7c37d33becbd2072b55fa180db *man/recreate.Rd 40e4109decf2b76c543b0b624cdaad88 *man/replaceText.Rd b388bee93bbdcdbae7a0852ec236cf99 *man/tilde.Rd 98cd7dcd7d0294db9fdce960076fe640 *man/tryCatchWEM.Rd d96ee1b3a789493a5a442ae47e71e03e *man/using.Rd 844f1cc4cb60f4bfca1b616905738ca0 *src/admisc.c c5acd23a77d5cdb57861b64395d37c31 *src/registerDynamicSymbol.c admisc/R/0000755000176200001440000000000015101164537011716 5ustar liggesusersadmisc/R/using.R0000644000176200001440000002346415101164540013171 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `using` <- function(data, expr, split.by = NULL, ...) { UseMethod("using") } `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 = "<-")) } test <- tryCatchWEM( result <- eval(substitute(expr), envir = data, enclos = parent.frame()) ) if (is.null(test$error)) { return(result) } stopError(test$error) } `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, ... = ...) ) } `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) { test <- tryCatchWEM( result <- eval(expr, envir = data, enclos = parent.frame()) ) if (is.null(test$error)) { return(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)) 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) { res[[r]] <- eval( expr = expr, envir = subset(data, selection), enclos = parent.frame() ) } } 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)) } return(res) } admisc/R/invert.R0000644000176200001440000001574315101164537013362 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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")) } `deMorgan` <- function(...) { .Deprecated(msg = "Function deMorgan() is deprecated. Use function invert() instead.\n") negate(...) } `negate` <- function(...) { invert(...) } admisc/R/equality.R0000644000176200001440000001216715101164537013705 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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) } `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)) } `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)) } `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)) } `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)) } `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)) } `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.R0000644000176200001440000000446415101164537013777 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `asNumeric` <- function(x, ...) { UseMethod("asNumeric") } `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() } `asNumeric.factor` <- function(x, ..., levels = TRUE) { if (isTRUE(levels)) { return(suppressWarnings(as.numeric(levels(x)))[x]) } return(as.numeric(x)) } `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.R0000755000176200001440000002425215101164540013177 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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") } } } } `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") } `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") } `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") } } } } `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") } `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.R0000644000176200001440000000551115101164537015206 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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.R0000755000176200001440000001056715101164540013353 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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.R0000644000176200001440000001131715101164540013672 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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)) } version <- -1 if (requireNamespace("QCA", quietly = TRUE)) { version <- compareVersion( packageDescription("QCA")$Version, "3.7" ) } if (version < 0) { message(paste(enter, "Error: Package QCA (>= 3.7) is needed to make this work, please install it.", 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("") } } } 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")) } `sop` <- function(...) { .Deprecated(msg = "Function sop() is deprecated, and has been renamed to simplify()\n") simplify(...) } admisc/R/mvSOP.R0000644000176200001440000001040515101164537013045 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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.R0000644000176200001440000000714315101164537013321 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `inside` <- function(data, expr, ...) { UseMethod("inside") } `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 ) } } `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.R0000644000176200001440000000346715101164537013154 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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.R0000644000176200001440000000347115101164537012612 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `padLeft` <- function(x, n) { paste(c(rep(" ", n), x), collapse = "", sep = "") } `padRight` <- function(x, n) { paste(c(x, rep(" ", n)), collapse = "", sep = "") } `padBoth` <- function(x, n) { n1 <- ceiling(n/2) n2 <- floor(n/2) paste(c(rep(" ", n1), x, rep(" ", n2)), collapse = "", sep = "") } admisc/R/expand.R0000644000176200001440000002033215101164537013320 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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.R0000644000176200001440000000346515101164537013646 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `setColnames` <- function(matrix, colnames) { invisible(.Call("C_setColnames", matrix, colnames)) } `setRownames` <- function(matrix, rownames) { invisible(.Call("C_setRownames", matrix, rownames)) } `setDimnames` <- function(matrix, nameslist) { invisible(.Call("C_setDimnames", matrix, nameslist)) } admisc/R/checkSubset.R0000644000176200001440000000336215101164537014310 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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/tilde.R0000644000176200001440000000400415101164540013132 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `tilde1st` <- function(x) { is.element( substring( gsub( paste0("[[:space:]|", "\u00a0", "]"), "", x ), 1, 1 ), tildae() ) } `hastilde` <- function(x) { grepl(paste(tildae(), collapse = "|"), x) } `notilde` <- function(x) { gsub( paste(tildae(), collapse = "|"), "", gsub( paste0("[[:space:]|", "\u00a0", "]"), "", x ) ) } admisc/R/hclr.R0000644000176200001440000000352115101164537012772 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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.R0000644000176200001440000000372015101164540013317 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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.R0000644000176200001440000000476115101164537014003 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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.R0000644000176200001440000000365315101164537014076 0ustar liggesusers# Copyright (c) 2019 - 2025, 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` <- 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.R0000644000176200001440000000352415101164540013465 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `dashes` <- function() { return(c("\u002d", "\u2013")) } `tildae` <- function() { return(c("\u007e", "\u223c", "\u00ac", "\u223d")) } `singlequotes` <- function() { return(c("\u00b4", "\u0060", "\u2018", "\u2019")) } `doublequotes` <- function() { return(c("\u201c", "\u201d")) } `spaces` <- function() { return("\u00a0") } admisc/R/string.R0000644000176200001440000003257515101164540013355 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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) } `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) } } `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) } `splitBrackets` <- function(big.list) { return(lapply(big.list, function(x) { as.list(unlist(strsplit(unlist(strsplit(x, split="\\(")), split="\\)"))) })) } `removeSingleStars` <- function(big.list) { return(lapply(big.list, function(x) { single.stars <- unlist(lapply(x, function(y) { return(y == "*") })) return(x[!single.stars]) })) } `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 != ""])) }) })) } `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 != ""])) }) }) })) } `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) } }) }) }) })) } `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) } `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)))))])) } `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.R0000644000176200001440000001122415101164537013361 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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.R0000644000176200001440000000334515101164537014600 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. 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.R0000644000176200001440000000370515101164540013322 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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.R0000644000176200001440000001311715101164537013520 0ustar liggesusers# Copyright (c) 2019 - 2025, Adrian Dusa # All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, in whole or in part, are permitted provided that the # following conditions are met: # * Redistributions of source code must retain the above copyright # notice, this list of conditions and the following disclaimer. # * Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in the # documentation and/or other materials provided with the distribution. # * The names of its contributors may NOT be used to endorse or promote # products derived from this software without specific prior written # permission. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE # ARE DISCLAIMED. IN NO EVENT SHALL ADRIAN DUSA BE LIABLE FOR ANY # DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES # (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; # LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND # ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS # SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. `compute` <- function(expression = "", data = NULL, separate = FALSE, ...) { expression <- 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.R0000644000176200001440000000724315101164537013320 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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 } if (requireNamespace("QCA", quietly = TRUE)) { resmat <- QCA::combint(n = n, k = k, ogte = ogte, zerobased = zerobased) } else { e <- 0L ncols <- choose(n, k) h <- k - ncols == 1 out <- vector(mode = "list", length = ncols) comb <- seq.int(k) - zerobased comb[k] <- comb[k] - 1L last <- n == k i <- 1 while (comb[1] != n - k + 1 || last) { last <- FALSE if (e < n - h) { h <- 1L e <- comb[k] + zerobased comb[k] <- comb[k] + 1L if (comb[k] < ogte) { comb[k] <- ogte e <- ogte - 1 } } else { e <- comb[k - h] + zerobased h <- h + 1L under <- logical(h) for (j in seq(h)) { under[j] <- (e + j - zerobased < ogte) comb[k - h + j] <- e + j - zerobased } if (all(under)) { comb[k] <- ogte e <- ogte - 1 h <- 1L } } out[[i]] <- comb i <- i + 1 } resmat <- do.call("cbind", out[!unlist(lapply(out, is.null))]) } if (lngt1) { resmat <- matrix(copyn[resmat], nrow = nrow(resmat)) } return(resmat) } admisc/R/sortExpressions.R0000644000176200001440000000400715101164540015266 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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.R0000644000176200001440000001244415101164537014554 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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.R0000644000176200001440000000501315101164537014075 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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.R0000644000176200001440000000464015101164537013320 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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.R0000644000176200001440000000461615101164540014174 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `tryCatchWEM` <- function(expr, capture = FALSE) { #' modified version of http://stackoverflow.com/questions/4948361/how-do-i-save-warnings-and-errors-as-output-from-a-function 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.R0000755000176200001440000000361115101164537013651 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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.R0000644000176200001440000001211415101164540013175 0ustar liggesusers# Copyright (c) 2019 - 2025, 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.R0000644000176200001440000000423715101164540014040 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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.R0000644000176200001440000000360215101164540013302 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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.R0000755000176200001440000000661215101164540013611 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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 ) ) ) ) } `writePrimeimp` <- function(...) { writePIs(...) } admisc/R/frev.R0000755000176200001440000000355515101164537013016 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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.R0000644000176200001440000003120515101164540013275 0ustar liggesusers# Copyright (c) 2019 - 2025, 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` <- function(x, rules = NULL, cut = NULL, values = NULL, ...) { UseMethod("recode") } `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) } `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/tagged.R0000644000176200001440000000517615101164540013277 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `makeTag` <- function(...) { x <- as.character(c(...)) x <- .Call("_tag", x, PACKAGE = "admisc") class(x) <- "double" return(x) } `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")) } `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))) } } `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/getMatrix.R0000755000176200001440000000456115101164537014016 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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.R0000644000176200001440000000413215101164540014715 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. 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.R0000644000176200001440000001364415101164540013635 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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.R0000644000176200001440000000407015101164537013027 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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.R0000644000176200001440000000344615101164540015132 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. 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.R0000755000176200001440000003172715101164537014044 0ustar liggesusers# Copyright (c) 2019 - 2025, Adrian Dusa # All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, in whole or in part, are permitted provided that the # following conditions are met: # * Redistributions of source code must retain the above copyright # notice, this list of conditions and the following disclaimer. # * Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in the # documentation and/or other materials provided with the distribution. # * The names of its contributors may NOT be used to endorse or promote # products derived from this software without specific prior written # permission. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE # ARE DISCLAIMED. IN NO EVENT SHALL ADRIAN DUSA BE LIABLE FOR ANY # DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES # (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; # LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND # ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS # SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. `factorize` <- function(input, snames = "", noflevels = NULL, pos = FALSE, ...) { 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.R0000644000176200001440000001024215101164537013433 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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.R0000644000176200001440000000772015101164537013427 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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.R0000644000176200001440000000330515101164537013256 0ustar liggesusers# Copyright (c) 2019 - 2025, 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.R0000644000176200001440000000354215101164540014614 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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.R0000644000176200001440000000604015101164537013362 0ustar liggesusers# Copyright (c) 2019 - 2025, Adrian Dusa # All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, in whole or in part, are permitted provided that the # following conditions are met: # * Redistributions of source code must retain the above copyright # notice, this list of conditions and the following disclaimer. # * Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in the # documentation and/or other materials provided with the distribution. # * The names of its contributors may NOT be used to endorse or promote # products derived from this software without specific prior written # permission. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE # ARE DISCLAIMED. IN NO EVENT SHALL ADRIAN DUSA BE LIABLE FOR ANY # DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES # (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; # LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND # ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS # SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. export <- function (what, ...) { UseMethod ("export") } `export.default` <- function (what, ...) { return(NULL) } `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.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.R0000755000176200001440000000440115101164540014334 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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.R0000644000176200001440000000324115101164537013656 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `classify` <- function(x, class = "admisc_simplify") { attrx <- attributes(x) attrx$class <- c("character", class) attributes(x) <- attrx return(x) } admisc/R/translate.R0000644000176200001440000003362715101164540014043 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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) } if (length(noflevels) == 1 && is.numeric(noflevels) && length(snames) > 1) { noflevels <- rep(noflevels, length(snames)) } } 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.R0000644000176200001440000000334015101164540014044 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `uninstall` <- function(package) { package <- gsub("\\\"", "", deparse(substitute(package))) admisc::unload(package) if (is.element(package, rownames(installed.packages()))) { remove.packages(package) } } admisc/R/brackets.R0000644000176200001440000002143415101164537013643 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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 != ""]) } `insideBrackets` <- function(...) { .Deprecated(msg = "Function insideBrackets() is deprecated, use betweenBrackets().\n") betweenBrackets(...) } `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 != ""]) } `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)) } } `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)) } } `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)) } } `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.R0000644000176200001440000000312715101164537013346 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `listRDA` <- function(.filename) { load(.filename) return(as.list(environment())) } admisc/R/wholeNumeric.R0000644000176200001440000000417715101164540014505 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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.R0000755000176200001440000000731115101164540014556 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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.R0000644000176200001440000001767315101164540014331 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. 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.R0000644000176200001440000000367315101164537014704 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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.R0000644000176200001440000000665015101164537013275 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `change` <- function(x, ...) { UseMethod("change") } `change.default` <- function(x, ...) { return(x) } `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.R0000644000176200001440000000360315101164537014110 0ustar liggesusers# Copyright (c) 2019 - 2025, 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. `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/0000755000176200001440000000000015101164540012276 5ustar liggesusersadmisc/src/admisc.c0000644000176200001440000001375615101164537013724 0ustar liggesusers#include #include #include #include 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/registerDynamicSymbol.c0000644000176200001440000000027615101164537016774 0ustar liggesusers#include #include #include void R_init_admisc(DllInfo *dll) { R_registerRoutines(dll, NULL, NULL, NULL, NULL); R_useDynamicSymbols(dll, TRUE); } admisc/NAMESPACE0000755000176200001440000000512015101164537012735 0ustar liggesusersimportFrom("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) export( altb, alteb, agtb, agteb, aeqb, aneqb, anyTagged, asNumeric, curlyBrackets, insideBrackets, betweenBrackets, outsideBrackets, roundBrackets, squareBrackets, expandBrackets, betweenQuotes, change, checkMV, checkSubset, classify, coerceMode, combnk, compute, mvSOP, dashes, doublequotes, expand, export, factorize, frev, frelevel, getInfo, getLevels, getMatrix, getName, getTag, hasTag, hclr, intersection, inside, invert, listRDA, makeTag, padLeft, padRight, padBoth, permutations, asSOP, possibleNumeric, prettyString, prettyTable, deMorgan, objRDA, overwrite, negate, numdec, recode, hastilde, notilde, tildae, tilde1st, recreate, reload, replaceText, scan.clipboard, setColnames, setDimnames, setRownames, simplify, singlequotes, sop, spaces, splitstr, sortExpressions, stopError, translate, trimstr, tryCatchWEM, uninstall, unload, checkValid, validateNames, verify, wholeNumeric, write.clipboard, writePrimeimp, writePIs, splitMainComponents, splitBrackets, removeSingleStars, splitPluses, splitStars, splitTildas, solveBrackets, simplifyList, getNonChars, using ) S3method(print, "admisc_factorize") S3method(print, "admisc_intersection") S3method(print, "admisc_translate") S3method(print, "admisc_deMorgan") S3method(print, "admisc_simplify") S3method(print, "admisc_fobject") S3method(export, default) S3method(export, data.frame) S3method(export, list) S3method(change, default) S3method(change, QCA_tt) S3method(recode, default) S3method(recode, declared) S3method(asNumeric, default) S3method(asNumeric, factor) S3method(asNumeric, declared) S3method(inside, data.frame) S3method(inside, list) S3method(update, character) S3method(using, default) S3method(using, data.frame) S3method(using, matrix) admisc/inst/0000755000176200001440000000000015101164537012472 5ustar liggesusersadmisc/inst/ChangeLog0000644000176200001440000002557415101164537014261 0ustar liggesusersVersion 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/0000755000176200001440000000000015101164540012606 5ustar liggesusersadmisc/build/partial.rdb0000644000176200001440000000007515101164540014735 0ustar liggesusers‹‹àb```b`aed`b1…À€… H02°0piÖ¼ÄÜÔb C"Éð ´¤7admisc/man/0000755000176200001440000000000015101164537012270 5ustar liggesusersadmisc/man/export.Rd0000644000176200001440000000327515101164537014107 0ustar liggesusers\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.Rd0000644000176200001440000000136615101164537014613 0ustar liggesusers\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.} } \value{ This function does not return anything. } \author{ Adrian Dusa } \examples{ foo <- function(object, x) { objname <- deparse(substitute(object)) object <- x overwrite(objname, object, parent.frame()) } bar <- 1 foo(bar, 2) bar # [1] 2 bar <- list(A = bar) foo(bar$A, 3) bar } \keyword{functions} admisc/man/tilde.Rd0000644000176200001440000000226315101164537013663 0ustar liggesusers\name{Tilde operations} \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.Rd0000644000176200001440000000456515101164537014416 0ustar liggesusers\name{Numeric testing and coercion} \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.Rd0000644000176200001440000000674215101164537015276 0ustar liggesusers\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.Rd0000755000176200001440000000147415101164537014374 0ustar liggesusers\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.Rd0000644000176200001440000000426415101164537014357 0ustar liggesusers\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.Rd0000644000176200001440000000206215101164537015216 0ustar liggesusers\name{.rda functions: listRDA, objRDA} \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.Rd0000644000176200001440000000227615101164537014720 0ustar liggesusers\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.Rd0000755000176200001440000000133715101164537013530 0ustar liggesusers\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.Rd0000644000176200001440000000245215101164537015475 0ustar liggesusers\name{About the admisc package} \alias{admisc-package} \docType{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 \bold{\pkg{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.39\cr Date: \tab 2025-10-31\cr License: \tab GPL (>= 2)\cr } } \author{ \bold{Authors}:\cr Adrian Dusa\cr Department of Sociology\cr University of Bucharest\cr \email{dusa.adrian@unibuc.ro} \bold{Maintainer}:\cr Adrian Dusa } \keyword{package} admisc/man/using.Rd0000644000176200001440000000307215101164537013706 0ustar liggesusers\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.Rd0000644000176200001440000000221215101164537013504 0ustar liggesusers\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.Rd0000644000176200001440000000631615101164537014553 0ustar liggesusers\name{factorize} \alias{factorize} \title{Factorize Boolean expressions} \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). } \usage{ factorize(input, snames = "", noflevels = NULL, pos = FALSE, ...) } \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).} } \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 \bold{\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 \bold{\code{\link{translate}()}} for more details). The number of levels in \bold{\code{noflevels}} is needed only when negating multivalue conditions, and it should complement the \bold{\code{snames}} argument. If \bold{\code{input}} is an object of class \code{"qca"} (the result of the function \bold{\code{\link[QCA]{minimize}()}} from package \bold{\pkg{QCA}}), a factorization is performed for each of the minimized solutions. } \value{ 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) \emph{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)) } } \keyword{functions} admisc/man/clipboard.Rd0000644000176200001440000000075115101164537014521 0ustar liggesusers\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.Rd0000644000176200001440000000172115101164537014005 0ustar liggesusers\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.Rd0000644000176200001440000000655115101164537014364 0ustar liggesusers\name{Brackets} \alias{insideBrackets} \alias{betweenBrackets} \alias{outsideBrackets} \alias{curlyBrackets} \alias{squareBrackets} \alias{roundBrackets} \title{Extract information from a multi-value SOP/DNF expression} \description{ Functions to extract information from an expression written in SOP - sum of products form, (or from the canonical DNF - disjunctive normal form) for multi-value causal conditions. It extracts either the values within brackets, or the causal conditions' names outside the brackets. } \usage{ betweenBrackets(x, type = "[", invert = FALSE, regexp = NULL) outsideBrackets(x, type = "[", regexp = NULL) curlyBrackets(x, outside = FALSE, regexp = NULL) squareBrackets(x, outside = FALSE, regexp = NULL) roundBrackets(x, outside = FALSE, regexp = NULL) } \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 conditions' names outside the brackets.} \item{regexp}{Optional regular expression to extract information with.} } \details{ Expressions written in SOP - sum of products are used in Boolean logic, signaling a disjunction of conjunctions. These expressions are useful in Qualitative Comparative Analysis, a social science methodology that is employed in the context of searching for causal configurations that are associated with a certain outcome. They are also used to draw Venn diagrams with the package \bold{\code{venn}}, which draws any kind of set intersection (conjunction) based on a custom SOP expression. The functions \bold{\code{curlyBrackets}}, \bold{\code{squareBrackets}} and \bold{\code{roundBrackets}} are just special cases of the functions \bold{\code{betweenBrackets}} and \bold{\code{outsideBrackets}}, using the argument \bold{\code{type}} as either \code{"{"}, \code{"["} or \code{"("}. The function \bold{\code{outsideBrackets}} itself can be considered a special case of the function \bold{\code{betweenBrackets}}, when it uses the argument \bold{\code{invert = TRUE}}. SOP expressions are usually written using curly brackets for multi-value conditions but to allow the evaluation of unquoted expressions, they first needs to get past R's internal parsing system. For this reason, multi-value conditions in unquoted expresions should use the square brackets notation, 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. } \author{ Adrian Dusa } \examples{ sop <- "A[1] + B[2]*C[0]" betweenBrackets(sop) # 1, 2, 0 betweenBrackets(sop, invert = TRUE) # A, B, C # unquoted (valid) SOP expressions are allowed, same result betweenBrackets(A[1] + B[2]*C[0]) # the default type is "[" # curly brackets are also valid in quoted expressions betweenBrackets("A{1} + B{2}*C{0}", type = "{") # or curlyBrackets("A{1} + B{2}*C{0}") # and the condition names curlyBrackets("A{1} + B{2}*C{0}", outside = TRUE) squareBrackets(A[1] + B[2]*C[0]) # 1, 2, 0 squareBrackets(A[1] + B[2]*C[0], outside = TRUE) # A, B, C } \keyword{functions} admisc/man/getName.Rd0000644000176200001440000000226415101164537014143 0ustar liggesusers\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.Rd0000644000176200001440000000055615101164537015417 0ustar liggesusers\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.Rd0000644000176200001440000000307715101164537014041 0ustar liggesusers\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.Rd0000644000176200001440000002157315101164537015350 0ustar liggesusers\name{Interpret DNF/SOP expressions: compute, simplify, expand, translate} \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. The function \bold{\code{simplify()}} transforms a SOP expression into a simpler equivalent, through a process of Boolean minimization. The package uses the function \bold{\code{\link[QCA]{minimize}()}} from package \bold{\pkg{QCA}}), so users are highly encouraged to install and load that package, despite not being present in the Imports field (due to circular dependency issues). Function \bold{\code{expand()}} performs a Quine expansion to the complete DNF, or a partial expansion to a SOP expression with equally complex terms. Function \bold{\code{asSOP()}} returns a SOP expression from a POS (product of sums) expression. This function is different from the function \bold{\code{invert()}}, which also negates each causal condition. Function \bold{\code{mvSOP()}} coerces an expression from crisp set notation to multi-value notation. } \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{ # ----- # for compute() \dontrun{ # make sure the package QCA is loaded 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 loaded 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.Rd0000644000176200001440000001631315101164537014024 0ustar liggesusers\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.Rd0000644000176200001440000000054515101164537015315 0ustar liggesusers\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.Rd0000644000176200001440000000206415101164537015715 0ustar liggesusers\name{admisc internal functions} \alias{anyTagged} \alias{checkMV} \alias{checkSubset} \alias{classify} \alias{dashes} \alias{doublequotes} \alias{expandBrackets} \alias{getInfo} \alias{getLevels} \alias{getMatrix} \alias{getNonChars} \alias{getInfo} \alias{getLevels} \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{writePrimeimp} \alias{writePIs} \title{Internal Functions} \description{ The above functions are internal in the admisc package which are not designed to be called directly by the user. } \keyword{internal} admisc/man/equality.Rd0000644000176200001440000000271415101164537014420 0ustar liggesusers\name{Number equality} \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.Rd0000644000176200001440000000071515101164537014627 0ustar liggesusers\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.Rd0000644000176200001440000000647615101164537014103 0ustar liggesusers\name{Negate DNF/SOP expressions} \alias{negate} \alias{invert} \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.Rd0000644000176200001440000000213115101164537014025 0ustar liggesusers\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.Rd0000644000176200001440000000126215101164537014355 0ustar liggesusers\name{dimnames} \alias{setColnames} \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.Rd0000644000176200001440000000123115101164537014027 0ustar liggesusers\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.Rd0000644000176200001440000000370615101164537015045 0ustar liggesusers\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/DESCRIPTION0000644000176200001440000000301315101572761013222 0ustar liggesusersPackage: admisc Version: 0.39 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")) 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) URL: https://github.com/dusadrian/admisc BugReports: https://github.com/dusadrian/admisc/issues NeedsCompilation: yes Packaged: 2025-10-31 16:52:48 UTC; dusadrian Author: Adrian Dusa [aut, cre, cph] (ORCID: ) Maintainer: Adrian Dusa Repository: CRAN Date/Publication: 2025-11-02 06:10:57 UTC