admisc/0000755000176200001440000000000014573537262011530 5ustar liggesusersadmisc/NAMESPACE0000755000176200001440000000464714573533725012765 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, outsideBrackets, roundBrackets, squareBrackets, expandBrackets, change, checkMV, checkSubset, classify, coerceMode, combnk, compute, mvSOP, dashes, doublequotes, expand, export, factorize, finvert, 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, unlockEnvironment, 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(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(using, default) S3method(using, data.frame) admisc/man/0000755000176200001440000000000014573533725012303 5ustar liggesusersadmisc/man/numdec.Rd0000644000176200001440000000123114573533725014042 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/rdaFunctions.Rd0000644000176200001440000000206214573533725015231 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/numerics.Rd0000644000176200001440000000456514573533725014431 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/tilde.Rd0000644000176200001440000000226314573533725013676 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/negate.Rd0000644000176200001440000000646214573533725014045 0ustar liggesusers\name{Negate DNF/SOP expressions} \alias{negate} \alias{invert} \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{ negate(input, snames = "", noflevels, simplify = TRUE, ...) invert(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{invert}()} 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) negate(AC + B~C, simplify = FALSE) # the simplified, logically equivalent negation negate(AC + B~C) # with different intersection operators negate(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) negate(cLC) # parsimonious solution pLC <- minimize(LC, outcome = SURV, include = "?") negate(pLC) } } \keyword{functions} admisc/man/hclr.Rd0000644000176200001440000000221214573533725013517 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/intersection.Rd0000644000176200001440000000674214573533725015311 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/dimnames.Rd0000644000176200001440000000126214573533725014370 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/coerceMode.Rd0000644000176200001440000000071514573533725014642 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/admisc_internal.Rd0000644000176200001440000000212714573533725015730 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{unlockEnvironment} \alias{checkValid} \alias{validateNames} \alias{verify} \alias{writePrimeimp} \alias{unlockEnvironment} \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/finvert.Rd0000755000176200001440000000123414573533725014252 0ustar liggesusers\name{finvert} \alias{finvert} \title{Inverts the values of a factor} \description{ Useful function to invert the values from a categorical variable, for instance a Likert response scale.} \usage{ finvert(x, levels = FALSE) } \arguments{ \item{x}{A categorical variable (a factor)} \item{levels}{Logical, invert the levels as well} } \value{A factor of the same length as the original one.} \author{Adrian Dusa} \examples{ words <- c("ini", "mini", "miny", "moe") variable <- factor(words, levels = words) # inverts the value, preserving the levels finvert(variable) # inverts both values and levels finvert(variable, levels = TRUE) } \keyword{misc} admisc/man/equality.Rd0000644000176200001440000000271414573533725014433 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/tryCatchWEM.Rd0000644000176200001440000000227614573533725014733 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/recode.Rd0000644000176200001440000001630614573533725014041 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, cut, 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/combnk.Rd0000644000176200001440000000213114573533725014040 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/brackets.Rd0000644000176200001440000000651214573533725014374 0ustar liggesusers\name{Brackets} \alias{insideBrackets} \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{ insideBrackets(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{insideBrackets}} 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{insideBrackets}}, 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]" insideBrackets(sop) # 1, 2, 0 insideBrackets(sop, invert = TRUE) # A, B, C # unquoted (valid) SOP expressions are allowed, same result insideBrackets(A[1] + B[2]*C[0]) # the default type is "[" # curly brackets are also valid in quoted expressions insideBrackets("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/change.Rd0000644000176200001440000000172114573533725014020 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/SOPexpression.Rd0000644000176200001440000002157314573533725015363 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/replaceText.Rd0000644000176200001440000000370614573533725015060 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/man/using.Rd0000644000176200001440000000307214573533725013721 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/inside.Rd0000644000176200001440000000307714573533725014054 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/admisc_package.Rd0000644000176200001440000000245214573533725015510 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.35\cr Date: \tab 2024-03-11\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/clipboard.Rd0000644000176200001440000000075114573533725014534 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/permutations.Rd0000644000176200001440000000054514573533725015330 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/frelevel.Rd0000755000176200001440000000147414573533725014407 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/factorize.Rd0000644000176200001440000000631614573533725014566 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/overwrite.Rd0000644000176200001440000000136614573533725014626 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/export.Rd0000644000176200001440000000353114573533725014115 0ustar liggesusers\name{export} \alias{export} \title{Export a dataframe to a file or a connection} \description{ This function is a wrapper to \bold{\code{\link[utils]{write.table}()}}, to overcome possible issues with the row names. } \usage{ export(x, file = "", ...) } \arguments{ \item{x}{The object to be written (matrix or dataframe)} \item{file}{A character string containing the path to the file to be created} \item{...}{Same arguments that are used in \bold{\code{\link[utils]{write.table}()}}} } \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/recreate.Rd0000644000176200001440000000426414573533725014372 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/getName.Rd0000644000176200001440000000226414573533725014156 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/DESCRIPTION0000644000176200001440000000304514573537262013240 0ustar liggesusersPackage: admisc Version: 0.35 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: 2024-03-11 07:50:45 UTC; dusadrian Author: Adrian Dusa [aut, cre, cph] () Maintainer: Adrian Dusa Repository: CRAN Date/Publication: 2024-03-11 08:20:02 UTC admisc/build/0000755000176200001440000000000014573533725012627 5ustar liggesusersadmisc/build/partial.rdb0000644000176200001440000000007514573533725014756 0ustar liggesusers‹‹àb```b`afb`b1…À€… H02°0piÖ¼ÄÜÔb C"Éð§%!ˆ7admisc/src/0000755000176200001440000000000014573533725012317 5ustar liggesusersadmisc/src/registerDynamicSymbol.c0000644000176200001440000000030114573533725016774 0ustar liggesusers#include #include #include void R_init_admisc(DllInfo* info) { R_registerRoutines(info, NULL, NULL, NULL, NULL); R_useDynamicSymbols(info, TRUE); } admisc/src/admisc.c0000644000176200001440000001525714573533725013735 0ustar liggesusers#include #include #include #include // copied from: https://gist.github.com/wch/3280369#file-unlockenvironment-r #define FRAME_LOCK_MASK (1<<14) #define FRAME_IS_LOCKED(e) (ENVFLAGS(e) & FRAME_LOCK_MASK) #define UNLOCK_FRAME(e) SET_ENVFLAGS(e, ENVFLAGS(e) & (~ FRAME_LOCK_MASK)) SEXP _unlockEnvironment(SEXP env) { UNLOCK_FRAME(env); SEXP result = PROTECT( Rf_allocVector(LGLSXP, 1) ); LOGICAL(result)[0] = FRAME_IS_LOCKED(env) == 0; UNPROTECT(1); return result; } 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/R/0000755000176200001440000000000014573533725011731 5ustar liggesusersadmisc/R/write.clipboard.R0000644000176200001440000000344714573533725015154 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/print.R0000755000176200001440000002405014573533725013214 0ustar liggesusers# Copyright (c) 2019 - 2024, 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)) { nms <- apply(attr(x, "split", exact = TRUE), 1, function(x) { paste(x, collapse = ", ") }) 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/getName.R0000644000176200001440000000772014573533725013442 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/writePrimeimp.R0000755000176200001440000000653014573533725014720 0ustar liggesusers# Copyright (c) 2019 - 2024, 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. `writePrimeimp` <- 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 ) ) ) ) } admisc/R/wholeNumeric.R0000644000176200001440000000417714573533725014526 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/checkValid.R0000644000176200001440000000474614573533725014124 0ustar liggesusers# Copyright (c) 2019 - 2024, 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))) } expression <- replaceText( expression, allnames, rep("", length(allnames)) ) 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/pad.R0000644000176200001440000000347114573533725012625 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/export.R0000644000176200001440000000522014573533725013374 0ustar liggesusers# Copyright (c) 2019 - 2024, Adrian Dusa # All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, in whole or in part, are permitted provided that the # following conditions are met: # * Redistributions of source code must retain the above copyright # notice, this list of conditions and the following disclaimer. # * Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in the # documentation and/or other materials provided with the distribution. # * The names of its contributors may NOT be used to endorse or promote # products derived from this software without specific prior written # permission. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE # ARE DISCLAIMED. IN NO EVENT SHALL ADRIAN DUSA BE LIABLE FOR ANY # DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES # (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; # LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND # ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS # SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. `export` <- function(x, file = "", ...) { export.args <- list(...) Call <- as.list(match.call(expand.dots = TRUE))[-1] caseid <- "cases" if (any(names(export.args) == "caseid")) { caseid <- export.args[["caseid"]] Call[["caseid"]] <- NULL } if (!missing(x)) { if (is.data.frame(x) | is.matrix(x)) { if (any(rownames(x) != seq(nrow(x)))) { if (all(colnames(x) != caseid)) { x <- cbind("cases" = rownames(x), x) names(x)[1] <- caseid } } } } Call[["x"]] <- x if (any(names(export.args) == "sep")) { if (export.args[["sep"]] == "tab") { export.args[["sep"]] <- "\t" } Call[["sep"]] <- export.args[["sep"]] } else { Call[["sep"]] <- "," } if (any(names(export.args) == "col.names")) { Call[["col.names"]] <- export.args[["col.names"]] } if (any(names(export.args) == "row.names")) { message("The argument 'row.names' is always set to FALSE, by default.") } Call[["row.names"]] <- FALSE do.call("write.table", Call) } admisc/R/unload.R0000644000176200001440000000370514573533725013343 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/uninstall.R0000644000176200001440000000334014573533725014065 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/getLevels.R0000644000176200001440000000476114573533725014016 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/finvert.R0000755000176200001440000000337214573533725013541 0ustar liggesusers# Copyright (c) 2019 - 2024, 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. `finvert` <- function(x, levels = 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 + !levels]], labels = flist[[1 + levels]])) } admisc/R/permutations.R0000644000176200001440000000334514573533725014613 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/asSOP.R0000644000176200001440000000407014573533725013042 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/compute.R0000644000176200001440000001207314573533725013533 0ustar liggesusers# Copyright (c) 2019 - 2024, 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)) 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)) { syscalls <- as.character(sys.calls()) usingwith <- "admisc::using\\(|using\\(|with\\(" if (any(usingdata <- grepl(usingwith, syscalls))) { dataname <- unlist(strsplit(gsub(usingwith, "", syscalls), split = ","))[1] data <- eval.parent(parse(text = dataname, n = 1)) } else { 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(unlist(lapply(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/unlockEnvironment.R0000644000176200001440000000313614573533725015577 0ustar liggesusers# Copyright (c) 2019 - 2024, 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. `unlockEnvironment` <- function(env) { .Call("_unlockEnvironment", env, PACKAGE = "admisc") } admisc/R/negate.R0000644000176200001440000001566514573533725013334 0ustar liggesusers# Copyright (c) 2019 - 2024, Adrian Dusa # All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, in whole or in part, are permitted provided that the # following conditions are met: # * Redistributions of source code must retain the above copyright # notice, this list of conditions and the following disclaimer. # * Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in the # documentation and/or other materials provided with the distribution. # * The names of its contributors may NOT be used to endorse or promote # products derived from this software without specific prior written # permission. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE # ARE DISCLAIMED. IN NO EVENT SHALL ADRIAN DUSA BE LIABLE FOR ANY # DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES # (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; # LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND # ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS # SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. `negate` <- 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 negate() instead.\n") negate(...) } admisc/R/verify.R0000755000176200001440000001056714573533725013374 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/change.R0000644000176200001440000000665014573533725013310 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/invert.R0000644000176200001440000001211514573533725013363 0ustar liggesusers# Copyright (c) 2019 - 2024, 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) { 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/replaceText.R0000644000176200001440000001727414573533725014347 0ustar liggesusers# Copyright (c) 2019 - 2024, 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 (length(target) == 1) 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, tuplow, ruplow = NULL, protect = NULL) { if (identical(tuplow, "")) { return(NULL) } positions <- vector(mode = "list", length = 0) pos <- 0 for (i in seq(length(tuplow))) { etuplow <- gsub("\\[", "\\\\[", tuplow[i]) etuplow <- gsub("\\]", "\\\\]", etuplow) etuplow <- gsub("\\{", "\\\\{", etuplow) etuplow <- gsub("\\}", "\\\\}", etuplow) etuplow <- gsub("\\*", "\\\\*", etuplow) etuplow <- gsub("\\.", "\\\\.", etuplow) locations <- gregexpr(etuplow, expression)[[1]] if (any(locations > 0)) { diffs <- c() for (l in seq(length(locations))) { tempd <- seq(locations[l], locations[l] + nchar(tuplow[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] <- ruplow[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(ruplow)) { names(positions)[pos] <- ruplow[i] } start <- diffs[v] } } pos <- pos + 1 positions[[pos]] <- seq(start, diffs[length(diffs)]) if (!is.null(ruplow)) { names(positions)[pos] <- ruplow[i] } } } } } return(positions) } posprotect <- NULL if (!identical(protect, "")) { larger <- tuplow[nchar(tuplow) > max(nchar(protect))] posprotect <- getPositions(expression, larger) } posprotect <- getPositions(expression, protect, protect = posprotect) positions <- getPositions(expression, tuplow, ruplow, 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/coerceMode.R0000644000176200001440000000360314573533725014123 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/R/mvSOP.R0000644000176200001440000001040514573533725013060 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/prettyTable.R0000755000176200001440000000440114573533725014355 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/tagged.R0000644000176200001440000000517614573533725013320 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/classify.R0000644000176200001440000000315014573533725013670 0ustar liggesusers# Copyright (c) 2019 - 2024, 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") { class(x) <- c("character", class) return(x) } admisc/R/overwrite.R0000644000176200001440000000365314573533725014111 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/possibleNumeric.R0000644000176200001440000000536614573533725015231 0ustar liggesusers# Copyright (c) 2019 - 2024, 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)) isna <- is.na(x) if (all(isna)) { if (each) { return(result) } return(FALSE) } if (is.logical(x)) { if (each) { result <- logical(length(x)) result[isna] <- 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[!isna] <- TRUE return(result) } return(TRUE) } if (is.factor(x)) { x <- as.character(x) } x <- gsub("\u00a0", " ", x) multibyte <- grepl("[^!-~ ]", x) if (any(multibyte)) { isna[multibyte] <- TRUE result[multibyte] <- FALSE x[multibyte] <- NA } if (each) { x <- suppressWarnings(as.numeric(na.omit(x))) result[!isna] <- !is.na(x) return(result) } return(!any(is.na(suppressWarnings(as.numeric(na.omit(x)))))) } admisc/R/simplify.R0000644000176200001440000001131714573533725013713 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/numdec.R0000644000176200001440000000464014573533725013333 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/prettyString.R0000755000176200001440000000731114573533725014577 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/unicode.R0000644000176200001440000000352414573533725013506 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/objRDA.R0000644000176200001440000000346714573533725013167 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/checkMV.R0000644000176200001440000001122414573533725013374 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/tryCatchWEM.R0000644000176200001440000000461614573533725014215 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/scan.clipboard.R0000644000176200001440000000413214573533725014736 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/asNumeric.R0000644000176200001440000000446414573533725014012 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/using.R0000644000176200001440000001774314573533725013215 0ustar liggesusers# Copyright (c) 2019 - 2024, 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 = "<-")) } eval(substitute(expr), data, enclos = parent.frame()) } `using.data.frame` <- function(data, expr, split.by = NULL, ...) { if (nrow(data) == 0) { stopError("There are no rows in the data.") } split.by <- substitute(split.by) 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 = "<-")) } expr <- substitute(expr) vexpr <- all.vars(expr) vexpr <- vexpr[is.element(vexpr, names(data))] if (any(vexpr == ".")) { vexpr <- colnames(data) } if (length(sby) == 0) { return(eval(expr = expr, envir = data, enclos = parent.frame())) } csby <- setdiff(as.character(split.by), c("c", "+", "&")) test <- unlist(lapply(seq(length(csby)), function(i) { tryCatchWEM(eval(parse(text = csby[i]), envir = data, enclos = parent.frame())) })) if (length(test) > 0) { stopError(test[1]) } sbylist <- lapply( lapply(csby, 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 } labels <- labels[!is.element(labels, na_values)] uniques <- sort(unique(c(undeclareit(x, drop = TRUE), labels))) names(uniques) <- 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) <- csby 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) { if (inherits(x, "declared") | inherits(x, "haven_labelled_spss")) { na_values <- attr(x, "na_values", exact = TRUE) labels <- attr(x, "labels", exact = TRUE) attributes(x) <- NULL x <- sort(unique(x)) x <- x[!is.element(x, na_values)] if (!is.null(labels)) { havelabels <- is.element(x, labels) x[havelabels] <- names(labels)[match(x[havelabels], labels)] } return(as.character(x)) } return(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() ) } } any_w_table <- any( sapply(res, function(x) class(x)[1] == "w_table") ) if (all(unlist(lapply(res, is.atomic))) & !any_w_table) { classes <- unique(unlist(lapply(res, class))) classes <- setdiff(classes, c("integer", "double", "character", "numeric", "complex")) lengths <- unlist(lapply(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)) rownames(result) <- apply(slexp, 1, function(x) paste(x, collapse = ", ")) if (max(lengths) == 1) { colnames(result) <- as.character(as.list(expr)[[1]]) } else { colnames(result) <- names(res[[which.max(lengths)]]) } res <- result class(res) <- c("admisc_fobject", "matrix") } else { attr(res, "split") <- slexp class(res) <- c("admisc_fobject", class(res)) } return(res) } admisc/R/combnk.R0000644000176200001440000000724314573533725013333 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/validateNames.R0000644000176200001440000000354214573533725014635 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/intersection.R0000644000176200001440000001244414573533725014567 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/equality.R0000644000176200001440000001216714573533725013720 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/dimnames.R0000644000176200001440000000346514573533725013661 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/getInfo.R0000644000176200001440000001137314573533725013454 0ustar liggesusers# Copyright (c) 2019 - 2024, 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"))])) } }))) if (!isTRUE(dots$no_column_info)) { if (length(dc.code) > 1) { stopError("Multiple \"don't care\" codes found.") } } 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]) { if (min(cc) != 0 && !fuzzy.cc[i]) { cc <- recode(cc, paste(sort(labels), seq(noflevels[i]) - 1, sep = "=", collapse = ";")) } 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 (is.null(labels)) { stopError("Declared columns should have labels.") } else { if (noflevels[i] == 2) { if (length(labels) == 1) { stopError("Binary crisp columns should have labels for both presence and absence.") } } else { if (length(labels) != noflevels[i]) { stopError("All multi-values should have declared labels.") } } } 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/string.R0000644000176200001440000003223314573533725013365 0ustar liggesusers# Copyright (c) 2019 - 2024, 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(x, oldv, newv) } y <- unlist(strsplit(x, split = ",")) if (!is.null(oldv)) { for (i in seq(length(y))) { y[i] <- replaceText(y[i], newv, oldv) } } y <- trimstr(y) if (length(y) == 1) { y <- gsub("\\n", "", unlist(strsplit(gsub("[[:space:]]", "", y), split = ";"))) } 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/recode.R0000644000176200001440000002632514573533725013325 0ustar liggesusers# Copyright (c) 2019 - 2024, 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, cut, values = NULL, ...) { UseMethod("recode") } `recode.declared` <- function(x, rules, cut, values = NULL, ..., na_values = TRUE) { na_index <- attr(x, "na_index") attributes(x) <- NULL if (!is.null(na_index) & isTRUE(na_values)) { nms <- names(na_index) if (possibleNumeric(nms)) { nms <- asNumeric(nms) } x[na_index] <- nms } NextMethod() } `recode.default` <- function(x, rules, cut, 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 declared <- inherits(x, "declared") 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(values) && (!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 (missing(cut)) { 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 <- unlist(lapply(lapply(rulsplit, trimstr), "[", 1)) newval <- unlist(lapply(lapply(rulsplit, trimstr), "[", 2)) 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[x %in% 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.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 { sx <- sort(x) minx <- sx[1] maxx <- sx[length(x)] if (is.character(x) & is.numeric(cut)) { insidex <- FALSE } else { insidex <- logical(length(cut)) for (i in seq(length(cut))) { insidex[i] <- cut[i] >= minx & cut[i] <= maxx } } } if (!all(insidex)) { message <- "Cut value(s) outside the input vector." if (declared) { message <- paste(message, "Consider using undeclare() before recoding.") } 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 { temp <- rep(values[1], length(x)) for (i in seq(length(cut))) { temp[x > cut[i]] = values[i + 1] } } 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/onLoad.R0000644000176200001440000000330514573533725013271 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/frelevel.R0000755000176200001440000000361114573533725013664 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/checkSubset.R0000644000176200001440000000336214573533725014323 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/hclr.R0000644000176200001440000000352114573533725013005 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/getMatrix.R0000755000176200001440000000456114573533725014031 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/reload.R0000644000176200001440000000360214573533725013323 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/translate.R0000644000176200001440000003347214573533725014062 0ustar liggesusers# Copyright (c) 2019 - 2024, 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)) 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 { 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, no_column_info = TRUE) 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/factorize.R0000755000176200001440000003172714573533725014057 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/sortExpressions.R0000644000176200001440000000400714573533725015307 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/listRDA.R0000644000176200001440000000312714573533725013361 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/brackets.R0000644000176200001440000002101714573533725013653 0ustar liggesusers# Copyright (c) 2019 - 2024, 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. `insideBrackets` <- 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 != ""]) } `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/inside.R0000644000176200001440000000714314573533725013334 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/recreate.R0000644000176200001440000001207214573533725013650 0ustar liggesusers# Copyright (c) 2019 - 2024, 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)) 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]) & which(found) == 1) { x[i] <- paste(rev(xs), collapse = "->") } } } } return(x) } typev <- typel <- FALSE callx <- identical(class(x), "call") dx <- deparse(x) 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)) } x <- tryCatch( eval( x, envir = parent.frame(n = 2) ), error = function(e) withinobj(dx) ) if (identical(class(x), "formula")) { return(withinobj(dx)) } return(x) } admisc/R/tilde.R0000644000176200001440000000400414573533725013153 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/expand.R0000644000176200001440000002021214573533725013330 0ustar liggesusers# Copyright (c) 2019 - 2024, 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 <- writePrimeimp(expression, multivalue, collapse = ifelse(scollapse, "*", "")) expression <- paste(expression, collapse = " + ") return(classify(expression, "admisc_simplify")) } admisc/R/stopError.R0000644000176200001440000000423714573533725014061 0ustar liggesusers# Copyright (c) 2019 - 2024, 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/MD50000644000176200001440000001122014573537262012034 0ustar liggesusers439959f8952315ef56c6a74735c06f7d *DESCRIPTION e2aba153c2d78960b1f7903c61ba9960 *NAMESPACE 81864613b7adf1eca1c8f9d068c876f6 *R/asNumeric.R a47e35ccfb1f291d03bca8eb0ad8ce0b *R/asSOP.R ea6103d8912b0ea1a66a3cbfae70c3a4 *R/brackets.R 22d9004ff8f2e4684e0c35a0cc379edf *R/change.R 2b5b0174c70b48542cd1795d46898059 *R/checkMV.R 07f141199a28f97c8712e5aa489e5cc2 *R/checkSubset.R 42f14bc7d8d917bc9ff9d847e92582db *R/checkValid.R 36387b6aedefc25535400d4e0f4d2cce *R/classify.R 3e656ec4d3898a845111b6cfc5d5af53 *R/coerceMode.R 862101c339cee60d87ed4f52b6465601 *R/combnk.R 0ba873abaa0138f641ba6986e90cc43d *R/compute.R 3d61523f7ae2aa206e7fa978edbbd21e *R/dimnames.R c86258914abf4b5f3467c053613feea5 *R/equality.R a88d53843088c4e8d0af85a69119bd81 *R/expand.R 8c2861298fe4b81538143bfda64d1104 *R/export.R 252acfefb614af1fa76f9865522170f2 *R/factorize.R 339f95eb75e2f7016470ef77ee95f463 *R/finvert.R 6a4858cb307565715a0ebd02fd3619bf *R/frelevel.R 03b8d17fed821109878cbb69938b3f20 *R/getInfo.R 7b608eacb3160c0bda8d648edc9b8d69 *R/getLevels.R de6ff0ea2fde703f1eec65a54d8670b7 *R/getMatrix.R b5da521ed58ce3df9d90bceb9946a13e *R/getName.R 4c55401d24084c1c1838688f13901893 *R/hclr.R 13c28fd08a94d3a6f5c5f14799aefaf3 *R/inside.R 801ee8d457ce5b177dcfd90e32d2f492 *R/intersection.R fbe4df52f53791a8447d1c6a259065a8 *R/invert.R fbb1c86428b3e3848ba1d8ab999bfa7f *R/listRDA.R 878c81eb91f95f7e5225311f66fd6e4b *R/mvSOP.R 910612186f0317e05398b4fc8f856be2 *R/negate.R 860cc69fc6315d8e4c6340147d9b515e *R/numdec.R 368d7c813725d3af5fd725d7d62c5b8a *R/objRDA.R 398b03e0afe371bad1d0a70cf4b74a99 *R/onLoad.R 3055ef7b9208c9ad3084cb82c3b8ada8 *R/overwrite.R 7dad2bbe2034b742db301daa8a13a257 *R/pad.R 25e66628f73ed171237cbe2a47cb0b90 *R/permutations.R 1530b257d9e40ab54084c16206c4e95c *R/possibleNumeric.R 43b1ee616321804b2f9dac08018c6128 *R/prettyString.R d86c6a39195ecdf741a632959f39ae13 *R/prettyTable.R b0a0847fa7cbdc2c5cfc76d5bc8099f1 *R/print.R a2def9d943ba5834bd2008e42eecb4b5 *R/recode.R 335da72e14c6059435adc8b9fda3f17b *R/recreate.R 1d1b4e80d21e76088443a20d304ba9fb *R/reload.R 46a24b8749bd4f5928cabac0e3af5a1f *R/replaceText.R 5fd5408d1d8e90e9ba0d272b33600721 *R/scan.clipboard.R 8d4b1251095f0f897970cc57a9b42adb *R/simplify.R a3256d3544207c009946330f78d627d8 *R/sortExpressions.R 1291fa6c0c105effa7437addaf6c91d2 *R/stopError.R 247419ace86ca1175456abd474624911 *R/string.R b9156f70dd01771f92c259cb87be8396 *R/tagged.R 367df7c90c542724d0f0a985f37759d0 *R/tilde.R 4e34ae929ee675a5a5554bc4d1cb3fe0 *R/translate.R d2838754e7c58375ef64a253eb6a08a7 *R/tryCatchWEM.R 10807b33ce40db7954b016fea31d463c *R/unicode.R 38db0716f118e94d7b07ce5f00c14ed9 *R/uninstall.R ffed1b8d2bd4d90cadfdcec69f7bb7cf *R/unload.R daeb34243e0eddd744001d3d839d8862 *R/unlockEnvironment.R 5771342d0cded3f7c808633136ebf84d *R/using.R 91a74ade765ebb79ac1546fc6b205362 *R/validateNames.R 70605c52e060a65afcaed0438de7a293 *R/verify.R 3d932274ce2f5af23d8d221e306e7f67 *R/wholeNumeric.R 1bd3f2428f404781019948d178176f39 *R/write.clipboard.R 3f0b18ddc87ec5e6a5aa6750f8973920 *R/writePrimeimp.R 8faf250d78a120ba4c7ea2186efddd24 *build/partial.rdb 0ac9a3373d147fc494776bbcf47d99ae *inst/ChangeLog 210724e3bcdc7f5a6339a175e8c430d3 *man/SOPexpression.Rd dbdf5e1b6b760600a2c718819c9aacd9 *man/admisc_internal.Rd 96e2b8b6d8ff0742be0f2da1d123e850 *man/admisc_package.Rd 9f627319f85a2c1b9cef397ea4cf4dfc *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 598be67ba886af5af778a761f56f54d9 *man/export.Rd 2a6a41d16a8350f315eab35d329d679e *man/factorize.Rd b88eafdc4fa0297b3ea509ef5def0f19 *man/finvert.Rd aa29f9722645a38b9cdc2ed88cfbe0a9 *man/frelevel.Rd 75989985fb8801054e27721b385e3264 *man/getName.Rd 5e9d411c2b8392f00b025c0b66356b93 *man/hclr.Rd b22cd24b5de9ac8a685c4d1223ad33c3 *man/inside.Rd a518151e751acbb73712e0c6f3b397e8 *man/intersection.Rd 626eafe7997b2facf89289c602fb6c8a *man/negate.Rd e3ab2ae5163ad71856cf66453459a9de *man/numdec.Rd 8518107d9379eb475fefe71f869ca6eb *man/numerics.Rd 56e3fd7225f59e14f0446ccbce438f55 *man/overwrite.Rd 427bb8c7134df056ec054e7469ae9547 *man/permutations.Rd c6d08db7c59e5f02461c5883742e643c *man/rdaFunctions.Rd 83d540cbadbfcade3ec80357cf53ab2f *man/recode.Rd 42d75e7c37d33becbd2072b55fa180db *man/recreate.Rd 40e4109decf2b76c543b0b624cdaad88 *man/replaceText.Rd b388bee93bbdcdbae7a0852ec236cf99 *man/tilde.Rd 98cd7dcd7d0294db9fdce960076fe640 *man/tryCatchWEM.Rd d96ee1b3a789493a5a442ae47e71e03e *man/using.Rd 8289996b878c81f8a0c13fcfb7d8bdad *src/admisc.c a465e0a34bee356620d28124a58ca43e *src/registerDynamicSymbol.c admisc/inst/0000755000176200001440000000000014573533725012505 5ustar liggesusersadmisc/inst/ChangeLog0000644000176200001440000002120014573533725014252 0ustar liggesusersVersion 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