inum/0000755000176200001440000000000014035062442011222 5ustar liggesusersinum/NAMESPACE0000644000176200001440000000135613200573611012444 0ustar liggesusers importFrom("stats", "quantile", "weights", "xtabs") importFrom("libcoin", "ctabs") export("inum", "interval", "enum") S3method("as.data.frame", "inum") S3method("as.data.frame", "inumtotal") S3method("inum", "data.frame") ## S3method("inum", "Surv") ## S3method("is.numeric", "Surv") S3method("weights", "inumtotal") S3method("print", "interval") S3method("levels", "interval") S3method("nlevels", "interval") S3method("interval", "numeric") S3method("[", "interval") S3method("format", "interval") S3method("print", "enum") S3method("levels", "enum") S3method("nlevels", "enum") S3method("enum", "logical") S3method("enum", "factor") S3method("enum", "integer") S3method("enum", "numeric") S3method("is.na", "enum") S3method("is.na", "interval") inum/man/0000755000176200001440000000000013460100255011771 5ustar liggesusersinum/man/enum.Rd0000644000176200001440000000216112765746600013245 0ustar liggesusers\name{enum} \alias{enum} \title{ Enumeration-type Representation of Vectors } \description{ Elements of a vector are stored as a set of levels and an integer representing the enumeration. } \usage{ enum(x) } \arguments{ \item{x}{ A vector. Currently, methods for factors, logicals, integers, and numeric vectors are implemented. } } \details{ The unique elements of \code{x} are stored as a \code{levels} attribute to an integer representing the enumeration. \code{levels} and \code{nlevels} methods are available. This is essentially the same as \code{factor} where the levels can be arbitrary vectors, not just characters. } \value{ An object of class \code{enum}. A value of \code{0} encodes \code{NA}. } \seealso{ \code{\link{factor}} } \examples{ (ex <- enum(x <- gl(2, 2))) all.equal(levels(ex)[ex], x) (ex <- enum(x <- rep(c(TRUE, FALSE), 2))) all.equal(levels(ex)[ex], x) (ex <- enum(x <- rep(1:5, 2))) all.equal(levels(ex)[ex], x) (ex <- enum(x <- rep(1:5 + .5, 2))) all.equal(levels(ex)[ex], x) (ex <- enum(x <- c(NA, rep(1:5 + .5, 2)))) all.equal(c(NA, levels(ex))[unclass(ex) + 1L], x) } \keyword{data} inum/man/interval.Rd0000644000176200001440000000221112765747032014121 0ustar liggesusers\name{interval} \alias{interval} \alias{interval.numeric} \title{ Cut Numeric Vectors into Intervals } \description{ \code{interval} divides \code{x} into intervals and, unlike \code{cut}, represents these as a numeric vector. } \usage{ interval(x, ...) \method{interval}{numeric}(x, breaks = 50, ...) } \arguments{ \item{x}{ A numeric vector. } \item{breaks}{ Either a numeric vector of two or more unique cut points or a single number (greater than or equal to 2) giving the number of intervals into which \code{x} is to be cut by \code{cut}. } \item{\dots}{ Additional arguments, currently ignored. } } \details{ This is just a wrapper around \code{cut} where the resulting intervals are stored as numeric values for simplified computation. } \value{ An object of class \code{interval}. A value of \code{0} encodes \code{NA}. } \seealso{ \code{\link{cut}} } \examples{ (ix <- interval(x <- 0:100/100, breaks = 0:10/10)) (cx <- cut(x, breaks = 0:10/10)) attr(ix, "levels") levels(ix) levels(cx) diag(table(ix, cx)) (ix <- interval(x <- c(NA, 0:100/100), breaks = 0:10/10)) ix[is.na(x)] unclass(ix)[is.na(x)] } \keyword{data} inum/man/inum.Rd0000644000176200001440000000364013201266222013233 0ustar liggesusers\name{inum} \alias{inum} \alias{inum.data.frame} \title{ Coerse Variables in Data Frames to \code{enum} or \code{interval} } \description{ Represents elements of a data frame as \code{enum} or \code{interval}. } \usage{ inum(object, nmax = 20, ...) \method{inum}{data.frame}(object, nmax = 20, ignore = NULL, total = FALSE, weights = NULL, as.interval = "", complete.cases.only = FALSE, meanlevels = FALSE, ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{object}{ A data frame. } \item{nmax}{ Maximal number of categories for each of the numeric variables. } \item{ignore}{ A character vector of variable names not to be discretised. } \item{total}{ A logical. \code{TRUE} means that a condensed data frame of all variables is returned, \code{FALSE} a list of discretised variables. } \item{weights}{ An optional vector of weights. } \item{as.interval}{ A character vector of variable names to be converted to \code{\link{interval}} instead of \code{\link{enum}}. } \item{complete.cases.only}{ A logical. \code{TRUE} removes all rows with missing values. } \item{meanlevels}{ A logical. \code{TRUE}, the level is the mean of the observations in the corresponding bin. The default \code{FALSE} uses the largest observation in the bin. } \item{\dots}{ Additional arguments, currently ignored. } } \details{ Each variable in \code{object} is converted to \code{\link{enum}} or \code{\link{interval}}. } \value{ An object of class \code{inum}, basically a list of \code{\link{enum}} or \code{\link{interval}} objects. If \code{total = TRUE}, an integer vector with a data frame as \code{levels} attribute is returned. In this case, \code{0} means \code{NA}. } \examples{ data("iris", package = "datasets") iris[1,1] <- NA inum(iris, nmax = 5) inum(iris, nmax = 5, total = TRUE) inum(iris, nmax = 5, total = TRUE, as.interval = "Sepal.Width", complete.cases.only = TRUE) } \keyword{data} inum/DESCRIPTION0000644000176200001440000000122014035062442012723 0ustar liggesusersPackage: inum Title: Interval and Enum-Type Representation of Vectors Date: 2021-04-12 Version: 1.0-4 Authors@R: person("Torsten", "Hothorn", role = c("aut", "cre"), email = "Torsten.Hothorn@R-project.org") Description: Enum-type representation of vectors and representation of intervals, including a method of coercing variables in data frames. Depends: R (>= 3.3.0) Imports: stats, libcoin (>= 1.0-0) License: GPL-2 NeedsCompilation: no Packaged: 2021-04-12 14:44:26 UTC; hothorn Author: Torsten Hothorn [aut, cre] Maintainer: Torsten Hothorn Repository: CRAN Date/Publication: 2021-04-12 15:20:02 UTC inum/tests/0000755000176200001440000000000014035056152012365 5ustar liggesusersinum/tests/bugfixes.Rout.save0000644000176200001440000003301014035056102016001 0ustar liggesusers R version 4.0.5 (2021-03-31) -- "Shake and Throw" Copyright (C) 2021 The R Foundation for Statistical Computing Platform: x86_64-pc-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > library("inum") > set.seed(29) > > ### there was a warning; reported by Fabian Scheipl > x <- 1:2 + .1 > inum(data.frame(x = x)) $x [1] 1.1 2.1 Levels: 1.1 2.1 attr(,"class") [1] "inum" > > > ### by Susanne Dandl > sepallen <- iris[, "Sepal.Length", drop = FALSE] > sepallen$Sepal.Length[c(1, 10)] <- NA > > a <- inum(sepallen, nmax = 5, as.interval = "Sepal.Length") > b <- inum(sepallen, nmax = 5, total = TRUE) > c <- inum(sepallen, nmax = 5, total = TRUE, complete.cases.only = TRUE) > all.equal(length(a), length(b), length(c)) [1] TRUE > > cbind(sepallen, a, as.numeric(b), as.numeric(c)) Sepal.Length Sepal.Length as.numeric(b) as.numeric(c) 1 NA 1 0 2 4.9 (3.84,5] 2 1 3 4.7 (3.84,5] 2 1 4 4.6 (3.84,5] 2 1 5 5.0 (3.84,5] 2 1 6 5.4 (5,5.6] 3 2 7 4.6 (3.84,5] 2 1 8 5.0 (3.84,5] 2 1 9 4.4 (3.84,5] 2 1 10 NA 1 0 11 5.4 (5,5.6] 3 2 12 4.8 (3.84,5] 2 1 13 4.8 (3.84,5] 2 1 14 4.3 (3.84,5] 2 1 15 5.8 (5.6,6.1] 4 3 16 5.7 (5.6,6.1] 4 3 17 5.4 (5,5.6] 3 2 18 5.1 (5,5.6] 3 2 19 5.7 (5.6,6.1] 4 3 20 5.1 (5,5.6] 3 2 21 5.4 (5,5.6] 3 2 22 5.1 (5,5.6] 3 2 23 4.6 (3.84,5] 2 1 24 5.1 (5,5.6] 3 2 25 4.8 (3.84,5] 2 1 26 5.0 (3.84,5] 2 1 27 5.0 (3.84,5] 2 1 28 5.2 (5,5.6] 3 2 29 5.2 (5,5.6] 3 2 30 4.7 (3.84,5] 2 1 31 4.8 (3.84,5] 2 1 32 5.4 (5,5.6] 3 2 33 5.2 (5,5.6] 3 2 34 5.5 (5,5.6] 3 2 35 4.9 (3.84,5] 2 1 36 5.0 (3.84,5] 2 1 37 5.5 (5,5.6] 3 2 38 4.9 (3.84,5] 2 1 39 4.4 (3.84,5] 2 1 40 5.1 (5,5.6] 3 2 41 5.0 (3.84,5] 2 1 42 4.5 (3.84,5] 2 1 43 4.4 (3.84,5] 2 1 44 5.0 (3.84,5] 2 1 45 5.1 (5,5.6] 3 2 46 4.8 (3.84,5] 2 1 47 5.1 (5,5.6] 3 2 48 4.6 (3.84,5] 2 1 49 5.3 (5,5.6] 3 2 50 5.0 (3.84,5] 2 1 51 7.0 (6.56,7.9] 6 5 52 6.4 (6.1,6.56] 5 4 53 6.9 (6.56,7.9] 6 5 54 5.5 (5,5.6] 3 2 55 6.5 (6.1,6.56] 5 4 56 5.7 (5.6,6.1] 4 3 57 6.3 (6.1,6.56] 5 4 58 4.9 (3.84,5] 2 1 59 6.6 (6.56,7.9] 6 5 60 5.2 (5,5.6] 3 2 61 5.0 (3.84,5] 2 1 62 5.9 (5.6,6.1] 4 3 63 6.0 (5.6,6.1] 4 3 64 6.1 (5.6,6.1] 4 3 65 5.6 (5,5.6] 3 2 66 6.7 (6.56,7.9] 6 5 67 5.6 (5,5.6] 3 2 68 5.8 (5.6,6.1] 4 3 69 6.2 (6.1,6.56] 5 4 70 5.6 (5,5.6] 3 2 71 5.9 (5.6,6.1] 4 3 72 6.1 (5.6,6.1] 4 3 73 6.3 (6.1,6.56] 5 4 74 6.1 (5.6,6.1] 4 3 75 6.4 (6.1,6.56] 5 4 76 6.6 (6.56,7.9] 6 5 77 6.8 (6.56,7.9] 6 5 78 6.7 (6.56,7.9] 6 5 79 6.0 (5.6,6.1] 4 3 80 5.7 (5.6,6.1] 4 3 81 5.5 (5,5.6] 3 2 82 5.5 (5,5.6] 3 2 83 5.8 (5.6,6.1] 4 3 84 6.0 (5.6,6.1] 4 3 85 5.4 (5,5.6] 3 2 86 6.0 (5.6,6.1] 4 3 87 6.7 (6.56,7.9] 6 5 88 6.3 (6.1,6.56] 5 4 89 5.6 (5,5.6] 3 2 90 5.5 (5,5.6] 3 2 91 5.5 (5,5.6] 3 2 92 6.1 (5.6,6.1] 4 3 93 5.8 (5.6,6.1] 4 3 94 5.0 (3.84,5] 2 1 95 5.6 (5,5.6] 3 2 96 5.7 (5.6,6.1] 4 3 97 5.7 (5.6,6.1] 4 3 98 6.2 (6.1,6.56] 5 4 99 5.1 (5,5.6] 3 2 100 5.7 (5.6,6.1] 4 3 101 6.3 (6.1,6.56] 5 4 102 5.8 (5.6,6.1] 4 3 103 7.1 (6.56,7.9] 6 5 104 6.3 (6.1,6.56] 5 4 105 6.5 (6.1,6.56] 5 4 106 7.6 (6.56,7.9] 6 5 107 4.9 (3.84,5] 2 1 108 7.3 (6.56,7.9] 6 5 109 6.7 (6.56,7.9] 6 5 110 7.2 (6.56,7.9] 6 5 111 6.5 (6.1,6.56] 5 4 112 6.4 (6.1,6.56] 5 4 113 6.8 (6.56,7.9] 6 5 114 5.7 (5.6,6.1] 4 3 115 5.8 (5.6,6.1] 4 3 116 6.4 (6.1,6.56] 5 4 117 6.5 (6.1,6.56] 5 4 118 7.7 (6.56,7.9] 6 5 119 7.7 (6.56,7.9] 6 5 120 6.0 (5.6,6.1] 4 3 121 6.9 (6.56,7.9] 6 5 122 5.6 (5,5.6] 3 2 123 7.7 (6.56,7.9] 6 5 124 6.3 (6.1,6.56] 5 4 125 6.7 (6.56,7.9] 6 5 126 7.2 (6.56,7.9] 6 5 127 6.2 (6.1,6.56] 5 4 128 6.1 (5.6,6.1] 4 3 129 6.4 (6.1,6.56] 5 4 130 7.2 (6.56,7.9] 6 5 131 7.4 (6.56,7.9] 6 5 132 7.9 (6.56,7.9] 6 5 133 6.4 (6.1,6.56] 5 4 134 6.3 (6.1,6.56] 5 4 135 6.1 (5.6,6.1] 4 3 136 7.7 (6.56,7.9] 6 5 137 6.3 (6.1,6.56] 5 4 138 6.4 (6.1,6.56] 5 4 139 6.0 (5.6,6.1] 4 3 140 6.9 (6.56,7.9] 6 5 141 6.7 (6.56,7.9] 6 5 142 6.9 (6.56,7.9] 6 5 143 5.8 (5.6,6.1] 4 3 144 6.8 (6.56,7.9] 6 5 145 6.7 (6.56,7.9] 6 5 146 6.7 (6.56,7.9] 6 5 147 6.3 (6.1,6.56] 5 4 148 6.5 (6.1,6.56] 5 4 149 6.2 (6.1,6.56] 5 4 150 5.9 (5.6,6.1] 4 3 > > stopifnot(length(attr(b, "levels")[unclass(b),"Sepal.Length"]) == 150) > stopifnot(length(attr(c, "levels")[unclass(c),"Sepal.Length"]) == 148) > > ### by Susanne Dandl > ## mini data frame with some missings > d <- data.frame( + y = rep(1:5, each = 2), + x = factor(rep(0:1, 5), labels = c("a", "b")), + z = 1:10, + w = 0:9/9 + ) > d$y[c(1, 10)] <- NA > > i <- inum(d, total = TRUE, complete = FALSE) > attr(i, "levels")[i,] y x z w (weights) 1 NA a 1 0.0000000 1 2 1 b 2 0.1111111 1 3 2 a 3 0.2222222 1 4 2 b 4 0.3333333 1 5 3 a 5 0.4444444 1 6 3 b 6 0.5555556 1 7 4 a 7 0.6666667 1 8 4 b 8 0.7777778 1 9 5 a 9 0.8888889 1 10 NA b 10 1.0000000 1 > > i <- inum(d, total = TRUE, complete = TRUE) > rbind(NA, attr(i, "levels"))[i + 1,] y x z w (weights) 1 NA NA NA NA 2 1 b 2 0.1111111 1 3 2 a 3 0.2222222 1 4 2 b 4 0.3333333 1 5 3 a 5 0.4444444 1 6 3 b 6 0.5555556 1 7 4 a 7 0.6666667 1 8 4 b 8 0.7777778 1 9 5 a 9 0.8888889 1 1.1 NA NA NA NA > > d <- expand.grid(y = 1:5, z = 1:10) > d$y[c(1, nrow(d))] <- NA > d$w <- rpois(nrow(d), lambda = 3) > > i1 <- inum(d, total = TRUE, complete = FALSE) > attr(i1, "levels")[i1,] y z w (weights) 2 NA 1 1 1 13 2 1 2 1 3 3 1 1 1 14 4 1 2 1 24 5 1 3 1 4 1 2 1 1 39 2 2 5 1 40 3 2 5 1 5 4 2 1 1 15 5 2 2 1 47 1 3 7 1 16 2 3 2 1 17 3 3 2 1 25 4 3 3 1 6 5 3 1 1 41 1 4 5 1 32 2 4 4 1 18 3 4 2 1 42 4 4 5 1 19 5 4 2 1 33 1 5 4 1 26 2 5 3 1 48 3 5 7 1 49 4 5 7 1 27 5 5 3 1 20 1 6 2 1 28 2 6 3 1 43 3 6 5 1 34 4 6 4 1 7 5 6 1 1 21 1 7 2 1 8 2 7 1 1 9 3 7 1 1 35 4 7 4 1 29 5 7 3 1 10 1 8 1 1 45 2 8 6 1 22 3 8 2 1 23 4 8 2 1 11 5 8 1 1 30 1 9 3 1 1 2 9 0 1 50 3 9 7 1 36 4 9 4 1 12 5 9 1 1 44 1 10 5 1 46 2 10 6 1 38 3 10 4 1 31 4 10 3 1 37 NA 10 4 1 > > i2 <- inum(d, total = TRUE, complete = TRUE) > rbind(NA, attr(i2, "levels"))[i2 + 1,] y z w (weights) 1 NA NA NA NA 13 2 1 2 1 3 3 1 1 1 14 4 1 2 1 24 5 1 3 1 4 1 2 1 1 38 2 2 5 1 39 3 2 5 1 5 4 2 1 1 15 5 2 2 1 46 1 3 7 1 16 2 3 2 1 17 3 3 2 1 25 4 3 3 1 6 5 3 1 1 40 1 4 5 1 32 2 4 4 1 18 3 4 2 1 41 4 4 5 1 19 5 4 2 1 33 1 5 4 1 26 2 5 3 1 47 3 5 7 1 48 4 5 7 1 27 5 5 3 1 20 1 6 2 1 28 2 6 3 1 42 3 6 5 1 34 4 6 4 1 7 5 6 1 1 21 1 7 2 1 8 2 7 1 1 9 3 7 1 1 35 4 7 4 1 29 5 7 3 1 10 1 8 1 1 44 2 8 6 1 22 3 8 2 1 23 4 8 2 1 11 5 8 1 1 30 1 9 3 1 2 2 9 0 1 49 3 9 7 1 36 4 9 4 1 12 5 9 1 1 43 1 10 5 1 45 2 10 6 1 37 3 10 4 1 31 4 10 3 1 1.1 NA NA NA NA > > proc.time() user system elapsed 0.176 0.025 0.184 inum/tests/regtest.R0000644000176200001440000000204413460100235014156 0ustar liggesusers library("inum") data("iris") suppressWarnings(RNGversion("3.5.3")) set.seed(29) iris[3, "Sepal.Width"] <- NA iris1 <- inum(iris, nmax = 5, as.interval = "Sepal.Width") iris1a <- inum(iris, nmax = 5, as.interval = c("Sepal.Width", "Sepal.Length")) iris2 <- inum(iris, nmax = 5, total = TRUE, as.interval = "Sepal.Width") iris2cc <- inum(iris, nmax = 5, total = TRUE, as.interval = "Sepal.Width", complete.cases.only = TRUE) x1 <- as.data.frame(iris1) table(x1$Species, iris$Species) tapply(iris$Sepal.Width, x1$Sepal.Width, range) levels(x1$Sepal.Width) as.data.frame(iris2) (w <- weights(iris2)) sum(w) as.data.frame(iris2cc) (w <- weights(iris2cc)) sum(w) x <- runif(100) x[1:3] <- NA ix <- interval(x, breaks = 0:10/10) levels(ix) nlevels(ix) ix table(ix) ix[1:10] enum(gl(3, 3)) enum(gl(3, 3, ordered = TRUE)) enum(c(TRUE, FALSE)) enum(c(1:3, 20L, 30L)) x <- sample(c(1:3, 10L, 20L), 100, replace = TRUE) x[1:3] <- NA ix <- enum(x) levels(ix) nlevels(ix) ix table(ix) is.na(enum(c(NA, 1:3))) is.na(interval(c(NA, runif(100)))) inum/tests/regtest.Rout.save0000644000176200001440000004151014010222006015635 0ustar liggesusers R version 4.0.3 (2020-10-10) -- "Bunny-Wunnies Freak Out" Copyright (C) 2020 The R Foundation for Statistical Computing Platform: x86_64-pc-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > library("inum") > data("iris") > suppressWarnings(RNGversion("3.5.3")) > set.seed(29) > > iris[3, "Sepal.Width"] <- NA > > iris1 <- inum(iris, nmax = 5, as.interval = "Sepal.Width") > > iris1a <- inum(iris, nmax = 5, as.interval = c("Sepal.Width", "Sepal.Length")) > > iris2 <- inum(iris, nmax = 5, total = TRUE, as.interval = "Sepal.Width") > iris2cc <- inum(iris, nmax = 5, total = TRUE, as.interval = "Sepal.Width", complete.cases.only = TRUE) > > x1 <- as.data.frame(iris1) > > table(x1$Species, iris$Species) setosa versicolor virginica setosa 50 0 0 versicolor 0 50 0 virginica 0 0 50 > > tapply(iris$Sepal.Width, x1$Sepal.Width, range) $`0` [1] NA NA $`1` [1] 2.0 2.7 $`2` [1] 2.8 3.0 $`3` [1] 3.1 3.1 $`4` [1] 3.2 3.4 $`5` [1] 3.5 4.4 > levels(x1$Sepal.Width) [1] "(1.9,2.7]" "(2.7,3]" "(3,3.1]" "(3.1,3.4]" "(3.4,4.4]" > > as.data.frame(iris2) Sepal.Length Sepal.Width Petal.Length Petal.Width Species (weights) 1 5.00 1.50 0.20 setosa 1 2 5.00 (2.7,3] 1.50 0.20 setosa 5 3 5.00 (3,3.1] 1.50 0.20 setosa 3 4 5.00 (3.1,3.4] 1.50 0.20 setosa 5 5 5.60 (3.1,3.4] 1.50 0.20 setosa 2 6 5.00 (3.4,4.4] 1.50 0.20 setosa 3 7 5.60 (3.4,4.4] 1.50 0.20 setosa 7 8 6.10 (3.4,4.4] 1.50 0.20 setosa 1 9 5.00 (2.7,3] 3.90 0.20 setosa 1 10 5.00 (3,3.1] 3.90 0.20 setosa 1 11 5.00 (3.1,3.4] 3.90 0.20 setosa 3 12 5.60 (3.1,3.4] 3.90 0.20 setosa 1 13 5.60 (3.4,4.4] 3.90 0.20 setosa 1 14 5.00 (1.9,2.7] 1.50 1.16 setosa 1 15 5.00 (2.7,3] 1.50 1.16 setosa 1 16 5.00 (3.1,3.4] 1.50 1.16 setosa 1 17 5.60 (3.1,3.4] 1.50 1.16 setosa 1 18 5.00 (3.4,4.4] 1.50 1.16 setosa 1 19 5.60 (3.4,4.4] 1.50 1.16 setosa 4 20 6.10 (3.4,4.4] 1.50 1.16 setosa 1 21 5.00 (3.1,3.4] 3.90 1.16 setosa 1 22 5.60 (3.1,3.4] 3.90 1.16 setosa 1 23 5.00 (3.4,4.4] 3.90 1.16 setosa 1 24 5.60 (3.4,4.4] 3.90 1.16 setosa 2 25 6.10 (3.4,4.4] 3.90 1.16 setosa 1 26 5.00 (1.9,2.7] 3.90 1.16 versicolor 3 27 5.60 (1.9,2.7] 3.90 1.16 versicolor 4 28 6.10 (1.9,2.7] 3.90 1.16 versicolor 1 29 6.10 (1.9,2.7] 4.64 1.16 versicolor 2 30 5.60 (1.9,2.7] 3.90 1.50 versicolor 1 31 6.10 (1.9,2.7] 3.90 1.50 versicolor 1 32 5.60 (2.7,3] 3.90 1.50 versicolor 1 33 5.60 (1.9,2.7] 4.64 1.50 versicolor 4 34 6.10 (1.9,2.7] 4.64 1.50 versicolor 1 35 6.52 (1.9,2.7] 4.64 1.50 versicolor 2 36 5.60 (2.7,3] 4.64 1.50 versicolor 3 37 6.10 (2.7,3] 4.64 1.50 versicolor 8 38 6.52 (2.7,3] 4.64 1.50 versicolor 3 39 7.90 (2.7,3] 4.64 1.50 versicolor 2 40 7.90 (3,3.1] 4.64 1.50 versicolor 1 41 6.52 (3.1,3.4] 4.64 1.50 versicolor 1 42 6.52 (1.9,2.7] 5.32 1.50 versicolor 1 43 6.10 (2.7,3] 5.32 1.50 versicolor 2 44 7.90 (2.7,3] 5.32 1.50 versicolor 1 45 7.90 (3,3.1] 5.32 1.50 versicolor 2 46 7.90 (3.1,3.4] 5.32 1.50 versicolor 1 47 6.10 (3.1,3.4] 4.64 1.90 versicolor 1 48 6.10 (1.9,2.7] 5.32 1.90 versicolor 1 49 7.90 (2.7,3] 5.32 1.90 versicolor 1 50 6.10 (3.1,3.4] 5.32 1.90 versicolor 1 51 6.52 (3.1,3.4] 5.32 1.90 versicolor 1 52 6.10 (1.9,2.7] 5.32 1.50 virginica 1 53 6.52 (2.7,3] 5.32 1.50 virginica 1 54 6.10 (1.9,2.7] 6.90 1.50 virginica 1 55 5.00 (1.9,2.7] 4.64 1.90 virginica 1 56 6.10 (1.9,2.7] 5.32 1.90 virginica 2 57 6.52 (1.9,2.7] 5.32 1.90 virginica 3 58 6.10 (2.7,3] 5.32 1.90 virginica 3 59 6.52 (2.7,3] 5.32 1.90 virginica 1 60 7.90 (1.9,2.7] 6.90 1.90 virginica 1 61 6.52 (2.7,3] 6.90 1.90 virginica 2 62 7.90 (2.7,3] 6.90 1.90 virginica 3 63 6.52 (3,3.1] 6.90 1.90 virginica 1 64 7.90 (3.1,3.4] 6.90 1.90 virginica 1 65 6.10 (1.9,2.7] 5.32 2.50 virginica 1 66 5.60 (2.7,3] 5.32 2.50 virginica 1 67 6.10 (2.7,3] 5.32 2.50 virginica 1 68 6.52 (2.7,3] 5.32 2.50 virginica 1 69 7.90 (2.7,3] 5.32 2.50 virginica 1 70 7.90 (3,3.1] 5.32 2.50 virginica 1 71 6.52 (3.1,3.4] 5.32 2.50 virginica 2 72 7.90 (1.9,2.7] 6.90 2.50 virginica 1 73 6.52 (2.7,3] 6.90 2.50 virginica 3 74 7.90 (2.7,3] 6.90 2.50 virginica 5 75 7.90 (3,3.1] 6.90 2.50 virginica 2 76 6.52 (3.1,3.4] 6.90 2.50 virginica 3 77 7.90 (3.1,3.4] 6.90 2.50 virginica 4 78 7.90 (3.4,4.4] 6.90 2.50 virginica 3 > (w <- weights(iris2)) [1] 1 5 3 5 2 3 7 1 1 1 3 1 1 1 1 1 1 1 4 1 1 1 1 2 1 3 4 1 2 1 1 1 4 1 2 3 8 3 [39] 2 1 1 1 2 1 2 1 1 1 1 1 1 1 1 1 1 2 3 3 1 1 2 3 1 1 1 1 1 1 1 1 2 1 3 5 2 3 [77] 4 3 > sum(w) [1] 150 > > as.data.frame(iris2cc) Sepal.Length Sepal.Width Petal.Length Petal.Width Species (weights) 1 5.00 (2.7,3] 1.50 0.20 setosa 5 2 5.00 (3,3.1] 1.50 0.20 setosa 3 3 5.00 (3.1,3.4] 1.50 0.20 setosa 5 4 5.60 (3.1,3.4] 1.50 0.20 setosa 2 5 5.00 (3.4,4.4] 1.50 0.20 setosa 3 6 5.60 (3.4,4.4] 1.50 0.20 setosa 7 7 6.10 (3.4,4.4] 1.50 0.20 setosa 1 8 5.00 (2.7,3] 3.90 0.20 setosa 1 9 5.00 (3,3.1] 3.90 0.20 setosa 1 10 5.00 (3.1,3.4] 3.90 0.20 setosa 3 11 5.60 (3.1,3.4] 3.90 0.20 setosa 1 12 5.60 (3.4,4.4] 3.90 0.20 setosa 1 13 5.00 (1.9,2.7] 1.50 1.16 setosa 1 14 5.00 (2.7,3] 1.50 1.16 setosa 1 15 5.00 (3.1,3.4] 1.50 1.16 setosa 1 16 5.60 (3.1,3.4] 1.50 1.16 setosa 1 17 5.00 (3.4,4.4] 1.50 1.16 setosa 1 18 5.60 (3.4,4.4] 1.50 1.16 setosa 4 19 6.10 (3.4,4.4] 1.50 1.16 setosa 1 20 5.00 (3.1,3.4] 3.90 1.16 setosa 1 21 5.60 (3.1,3.4] 3.90 1.16 setosa 1 22 5.00 (3.4,4.4] 3.90 1.16 setosa 1 23 5.60 (3.4,4.4] 3.90 1.16 setosa 2 24 6.10 (3.4,4.4] 3.90 1.16 setosa 1 25 5.00 (1.9,2.7] 3.90 1.16 versicolor 3 26 5.60 (1.9,2.7] 3.90 1.16 versicolor 4 27 6.10 (1.9,2.7] 3.90 1.16 versicolor 1 28 6.10 (1.9,2.7] 4.64 1.16 versicolor 2 29 5.60 (1.9,2.7] 3.90 1.50 versicolor 1 30 6.10 (1.9,2.7] 3.90 1.50 versicolor 1 31 5.60 (2.7,3] 3.90 1.50 versicolor 1 32 5.60 (1.9,2.7] 4.64 1.50 versicolor 4 33 6.10 (1.9,2.7] 4.64 1.50 versicolor 1 34 6.52 (1.9,2.7] 4.64 1.50 versicolor 2 35 5.60 (2.7,3] 4.64 1.50 versicolor 3 36 6.10 (2.7,3] 4.64 1.50 versicolor 8 37 6.52 (2.7,3] 4.64 1.50 versicolor 3 38 7.90 (2.7,3] 4.64 1.50 versicolor 2 39 7.90 (3,3.1] 4.64 1.50 versicolor 1 40 6.52 (3.1,3.4] 4.64 1.50 versicolor 1 41 6.52 (1.9,2.7] 5.32 1.50 versicolor 1 42 6.10 (2.7,3] 5.32 1.50 versicolor 2 43 7.90 (2.7,3] 5.32 1.50 versicolor 1 44 7.90 (3,3.1] 5.32 1.50 versicolor 2 45 7.90 (3.1,3.4] 5.32 1.50 versicolor 1 46 6.10 (3.1,3.4] 4.64 1.90 versicolor 1 47 6.10 (1.9,2.7] 5.32 1.90 versicolor 1 48 7.90 (2.7,3] 5.32 1.90 versicolor 1 49 6.10 (3.1,3.4] 5.32 1.90 versicolor 1 50 6.52 (3.1,3.4] 5.32 1.90 versicolor 1 51 6.10 (1.9,2.7] 5.32 1.50 virginica 1 52 6.52 (2.7,3] 5.32 1.50 virginica 1 53 6.10 (1.9,2.7] 6.90 1.50 virginica 1 54 5.00 (1.9,2.7] 4.64 1.90 virginica 1 55 6.10 (1.9,2.7] 5.32 1.90 virginica 2 56 6.52 (1.9,2.7] 5.32 1.90 virginica 3 57 6.10 (2.7,3] 5.32 1.90 virginica 3 58 6.52 (2.7,3] 5.32 1.90 virginica 1 59 7.90 (1.9,2.7] 6.90 1.90 virginica 1 60 6.52 (2.7,3] 6.90 1.90 virginica 2 61 7.90 (2.7,3] 6.90 1.90 virginica 3 62 6.52 (3,3.1] 6.90 1.90 virginica 1 63 7.90 (3.1,3.4] 6.90 1.90 virginica 1 64 6.10 (1.9,2.7] 5.32 2.50 virginica 1 65 5.60 (2.7,3] 5.32 2.50 virginica 1 66 6.10 (2.7,3] 5.32 2.50 virginica 1 67 6.52 (2.7,3] 5.32 2.50 virginica 1 68 7.90 (2.7,3] 5.32 2.50 virginica 1 69 7.90 (3,3.1] 5.32 2.50 virginica 1 70 6.52 (3.1,3.4] 5.32 2.50 virginica 2 71 7.90 (1.9,2.7] 6.90 2.50 virginica 1 72 6.52 (2.7,3] 6.90 2.50 virginica 3 73 7.90 (2.7,3] 6.90 2.50 virginica 5 74 7.90 (3,3.1] 6.90 2.50 virginica 2 75 6.52 (3.1,3.4] 6.90 2.50 virginica 3 76 7.90 (3.1,3.4] 6.90 2.50 virginica 4 77 7.90 (3.4,4.4] 6.90 2.50 virginica 3 > (w <- weights(iris2cc)) [1] 5 3 5 2 3 7 1 1 1 3 1 1 1 1 1 1 1 4 1 1 1 1 2 1 3 4 1 2 1 1 1 4 1 2 3 8 3 2 [39] 1 1 1 2 1 2 1 1 1 1 1 1 1 1 1 1 2 3 3 1 1 2 3 1 1 1 1 1 1 1 1 2 1 3 5 2 3 4 [77] 3 > sum(w) [1] 149 > > x <- runif(100) > x[1:3] <- NA > ix <- interval(x, breaks = 0:10/10) > > levels(ix) [1] "(0,0.1]" "(0.1,0.2]" "(0.2,0.3]" "(0.3,0.4]" "(0.4,0.5]" "(0.5,0.6]" [7] "(0.6,0.7]" "(0.7,0.8]" "(0.8,0.9]" "(0.9,1]" > nlevels(ix) [1] 10 > ix [1] (0.3,0.4] (0.5,0.6] (0,0.1] (0.8,0.9] [8] (0.8,0.9] (0.1,0.2] (0.2,0.3] (0.9,1] (0.3,0.4] (0.3,0.4] (0.6,0.7] [15] (0.1,0.2] (0.8,0.9] (0.6,0.7] (0.3,0.4] (0.8,0.9] (0.3,0.4] (0.6,0.7] [22] (0.6,0.7] (0.9,1] (0.9,1] (0.6,0.7] (0.3,0.4] (0.4,0.5] (0.8,0.9] [29] (0.6,0.7] (0.1,0.2] (0.3,0.4] (0.1,0.2] (0,0.1] (0.7,0.8] (0.4,0.5] [36] (0,0.1] (0.9,1] (0.3,0.4] (0.3,0.4] (0,0.1] (0.6,0.7] (0,0.1] [43] (0.9,1] (0.6,0.7] (0,0.1] (0.8,0.9] (0.9,1] (0.7,0.8] (0.5,0.6] [50] (0.6,0.7] (0.4,0.5] (0.7,0.8] (0.2,0.3] (0.6,0.7] (0.5,0.6] (0.4,0.5] [57] (0.5,0.6] (0.8,0.9] (0.5,0.6] (0.1,0.2] (0.4,0.5] (0.1,0.2] (0.5,0.6] [64] (0.3,0.4] (0.5,0.6] (0.7,0.8] (0.5,0.6] (0.6,0.7] (0.4,0.5] (0.2,0.3] [71] (0.1,0.2] (0.8,0.9] (0.2,0.3] (0,0.1] (0,0.1] (0.2,0.3] (0.8,0.9] [78] (0,0.1] (0,0.1] (0.2,0.3] (0.6,0.7] (0,0.1] (0.8,0.9] (0.3,0.4] [85] (0.3,0.4] (0.4,0.5] (0.9,1] (0.7,0.8] (0,0.1] (0.4,0.5] (0.6,0.7] [92] (0.4,0.5] (0.5,0.6] (0.4,0.5] (0.2,0.3] (0.1,0.2] (0.4,0.5] (0.6,0.7] [99] (0.7,0.8] (0.3,0.4] 10 Intervals: (0,0.1] < (0.1,0.2] < (0.2,0.3] < (0.3,0.4] < ... < (0.9,1] > > table(ix) ix 0 1 2 3 4 5 6 7 8 9 10 3 12 8 7 13 11 9 14 6 10 7 > ix[1:10] [1] (0.3,0.4] (0.5,0.6] (0,0.1] (0.8,0.9] [8] (0.8,0.9] (0.1,0.2] (0.2,0.3] 10 Intervals: (0,0.1] < (0.1,0.2] < (0.2,0.3] < (0.3,0.4] < ... < (0.9,1] > > enum(gl(3, 3)) [1] 1 1 1 2 2 2 3 3 3 Levels: 1 2 3 > enum(gl(3, 3, ordered = TRUE)) [1] 1 1 1 2 2 2 3 3 3 Levels: 1 < 2 < 3 > enum(c(TRUE, FALSE)) [1] TRUE FALSE Levels: FALSE TRUE > enum(c(1:3, 20L, 30L)) [1] 1 2 3 20 30 Levels: 1 2 3 20 30 > > x <- sample(c(1:3, 10L, 20L), 100, replace = TRUE) > x[1:3] <- NA > ix <- enum(x) > levels(ix) [1] 1 2 3 10 20 > nlevels(ix) [1] 5 > ix [1] 1 20 20 2 10 3 1 3 2 2 20 1 [16] 2 10 20 3 3 2 1 20 20 2 1 3 3 1 10 [31] 20 20 2 3 3 1 1 3 2 2 20 1 1 10 10 [46] 3 1 20 2 3 1 1 1 1 1 2 2 3 1 10 [61] 1 20 1 20 20 2 3 10 1 1 2 3 3 20 10 [76] 1 10 10 3 3 3 10 3 10 1 10 2 20 20 10 [91] 10 10 20 1 20 20 1 1 3 20 Levels: 1 2 3 10 20 > > table(ix) ix 0 1 2 3 4 5 3 26 15 20 16 20 > > is.na(enum(c(NA, 1:3))) [1] TRUE FALSE FALSE FALSE > is.na(interval(c(NA, runif(100)))) [1] TRUE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE [13] FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE [25] FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE [37] FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE [49] FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE [61] FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE [73] FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE [85] FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE [97] FALSE FALSE FALSE FALSE FALSE > > > proc.time() user system elapsed 0.192 0.028 0.202 inum/tests/bugfixes.R0000644000176200001440000000233414035056003014321 0ustar liggesusers library("inum") set.seed(29) ### there was a warning; reported by Fabian Scheipl x <- 1:2 + .1 inum(data.frame(x = x)) ### by Susanne Dandl sepallen <- iris[, "Sepal.Length", drop = FALSE] sepallen$Sepal.Length[c(1, 10)] <- NA a <- inum(sepallen, nmax = 5, as.interval = "Sepal.Length") b <- inum(sepallen, nmax = 5, total = TRUE) c <- inum(sepallen, nmax = 5, total = TRUE, complete.cases.only = TRUE) all.equal(length(a), length(b), length(c)) cbind(sepallen, a, as.numeric(b), as.numeric(c)) stopifnot(length(attr(b, "levels")[unclass(b),"Sepal.Length"]) == 150) stopifnot(length(attr(c, "levels")[unclass(c),"Sepal.Length"]) == 148) ### by Susanne Dandl ## mini data frame with some missings d <- data.frame( y = rep(1:5, each = 2), x = factor(rep(0:1, 5), labels = c("a", "b")), z = 1:10, w = 0:9/9 ) d$y[c(1, 10)] <- NA i <- inum(d, total = TRUE, complete = FALSE) attr(i, "levels")[i,] i <- inum(d, total = TRUE, complete = TRUE) rbind(NA, attr(i, "levels"))[i + 1,] d <- expand.grid(y = 1:5, z = 1:10) d$y[c(1, nrow(d))] <- NA d$w <- rpois(nrow(d), lambda = 3) i1 <- inum(d, total = TRUE, complete = FALSE) attr(i1, "levels")[i1,] i2 <- inum(d, total = TRUE, complete = TRUE) rbind(NA, attr(i2, "levels"))[i2 + 1,] inum/R/0000755000176200001440000000000014035056152011424 5ustar liggesusersinum/R/enum.R0000644000176200001440000000404713200573050012512 0ustar liggesusers enum <- function(x) UseMethod("enum") enum.default <- function(x) stop("no enum method for class", " ", sQuote(class(x)), " ", "found") enum.factor <- function(x) { ret <- unclass(x) attr(ret, "levels") <- factor(levels(x), levels = levels(x), labels = levels(x), ordered = is.ordered(x)) ret[is.na(x)] <- 0L class(ret) <- c("enum", "integer") ret } enum.logical <- function(x) { ret <- x + 1L attr(ret, "levels") <- c(FALSE, TRUE) ret[is.na(x)] <- 0L class(ret) <- c("enum", "integer") ret } enum.integer <- function(x) { breaks <- sort(unique(x)) ret <- match(x, breaks) ret[is.na(x)] <- 0L attr(ret, "levels") <- breaks class(ret) <- c("enum", "integer") ret } enum.numeric <- function(x) return(enum.integer(x)) levels.enum <- function(x) attr(x, "levels") nlevels.enum <- function(x) length(levels(x)) print.enum <- function(x, quote = FALSE, max.levels = NULL, width = getOption("width"), ...) { print(c("", as.character(levels(x)))[x + 1L], quote = quote) maxl <- if (is.null(max.levels)) TRUE else max.levels if (maxl) { n <- length(lev <- encodeString(as.character(levels(x)), quote = ifelse(quote, "\"", ""))) colsep <- if (is.ordered(levels(x))) " < " else " " T0 <- "Levels: " if (is.logical(maxl)) maxl <- { width <- width - (nchar(T0, "w") + 3L + 1L + 3L) lenl <- cumsum(nchar(lev, "w") + nchar(colsep, "w")) if (n <= 1L || lenl[n] <= width) n else max(1L, which.max(lenl > width) - 1L) } drop <- n > maxl cat(if (drop) paste(format(n), ""), T0, paste(if (drop) c(lev[1L:max(1, maxl - 1)], "...", if (maxl > 1) lev[n]) else lev, collapse = colsep), "\n", sep = "") } return(invisible(x)) } is.na.enum <- function(x) unclass(x) == 0L inum/R/inum.R0000644000176200001440000001406514035055511012523 0ustar liggesusers inum <- function(object, nmax = 20, ...) UseMethod("inum") inum.default <- function(object, nmax = 20, ...) stop("cannot handle objects of class", " ", sQuote(class(object))) inum.data.frame <- function(object, nmax = 20, ignore = NULL, total = FALSE, weights = NULL, as.interval = "", complete.cases.only = FALSE, meanlevels = FALSE, ...) { if (total) { bdr <- inum(object, nmax = nmax, ignore = ignore, total = FALSE, as.interval = as.interval) bdr2 <- lapply(bdr, function(x) factor(x, levels = 0:nlevels(x))) ret <- do.call("interaction", bdr2) if (!is.null(weights)) { tab <- xtabs(weights ~ ret) } else { tab <- table(ret) } tab0 <- which(tab > 0) sDF <- vector(mode = "list", length = length(bdr)) len <- sapply(bdr2, nlevels) ### do.call("expand.grid", bdr), essentially for (j in 1:length(len)) { ix <- 1:len[j] if (j > 1) ix <- rep(ix, each = prod(len[1:(j - 1)])) idx <- rep(ix, length.out = prod(len))[tab0] if (inherits(bdr[[j]], "interval")) { sDF[[j]] <- (0:nlevels(bdr[[j]]))[idx] attr(sDF[[j]], "levels") <- attr(bdr[[j]], "levels") class(sDF[[j]]) <- class(bdr[[j]]) } else { lev <- attr(bdr[[j]], "levels") lev <- lev[c(1, 1:length(lev))] lev[1] <- NA sDF[[j]] <- lev[idx, drop = FALSE] } } ### note: sDF contains missings and ### ret is always > 0 (is, no missings) ### this is different from enum/integer types ### should we handle this here? sDF <- as.data.frame(sDF) colnames(sDF) <- names(bdr) sDF[["(weights)"]] <- as.numeric(tab[tab0]) rownames(sDF) <- NULL ret <- unclass(ret[, drop = TRUE]) if (complete.cases.only) { cc <- rowSums(sapply(sDF[colnames(sDF) != "(weights)"], function(x) is.na(x))) == 0 cc[is.na(cc)] <- TRUE if (any(!cc)) { sDF <- sDF[cc,,drop = FALSE] rownames(sDF) <- 1:nrow(sDF) i <- rep.int(1L, length(cc)) i[!cc] <- 0 i <- cumsum(i) i[!cc] <- 0 ret <- i[ret] } } attr(ret, "levels") <- sDF class(ret) <- "inumtotal" return(ret) } ret <- vector(mode = "list", length = ncol(object)) names(ret) <- cn <- colnames(object) if (!is.null(ignore)) { if (is.integer(ignore)) cn <- cn[-ignore] if (is.character(ignore)) cn <- cn[!(cn %in% ignore)] } if (any(as.interval != "")) { if (!is.character(as.interval)) stop(sQuote("as.interval"), " ", "is not a character") } for (v in cn) { x <- object[[v]] if (is.logical(x) || is.factor(x) || is.integer(x)) { ix <- enum(x) } else if (is.numeric(x)) { ux <- oux <- sort(unique(x)) xmin <- ux[1] xmax <- ux[length(ux)] if (length(ux) > nmax) ux <- unique(quantile(x, prob = 1:(nmax - 1L) / nmax, na.rm = TRUE)) ux <- ux[ux < xmax] if (length(ux) > 1L) { tol <- max(min(diff(sort(ux))), sqrt(.Machine$double.eps)) } else { tol <- sqrt(.Machine$double.eps) } ix <- interval(x, breaks = c(xmin - tol, ux, xmax)) if (all(as.interval != v)) { if (length(oux) <= nmax) { ### assign sorted unique values attr(ix, "levels") <- as.double(oux) } else { if (meanlevels) { ### compute mean of x-values for each level ### and assign; first element corresponds to NAs w <- x w[is.na(w)] <- 0 ### does not count ix2 <- unclass(ix) ### is of length + 1 attr(ix2, "levels") <- NULL sx <- libcoin::ctabs(ix = ix2, weights = w)[-1] ### w/o NAs cn <- libcoin::ctabs(ix = ix2)[-1] lev <- sx / cn attr(ix, "levels") <- lev } else { ### this maximises distances to original ### measurements but leads to correct cutpoints nux <- c(ux, xmax) attr(ix, "levels") <- as.double(nux) } } class(ix) <- c("enum", "integer") } } else if (is.data.frame(x)) { ix <- inum(x, nmax = nmax, ignore = ignore, total = TRUE, as.interval = as.interval) } else { ix <- inum(x, nmax = nmax, ...) ### nothing as of now } ret[[v]] <- ix } class(ret) <- "inum" ret } ### only useful for checks as.data.frame.inum <- function(x, ...) { ret <- lapply(x, function(x) { if (inherits(x, "interval")) return(x) lev <- attr(x, "levels") lev <- lev[c(1, 1:length(lev))] lev[1] <- NA return(lev[x + 1]) }) class(ret) <- "data.frame" attr(ret, "row.names") <- 1:NROW(ret[[1]]) ret } as.data.frame.inumtotal <- function(x, ...) attr(x, "levels") weights.inumtotal <- function(object, ...) attr(object, "levels")[["(weights)"]] ### does not make sense # is.numeric.Surv <- function(x, ...) # return(FALSE) # inum.Surv <- function(object, nmax = 20, ...) { # x <- inum(as.data.frame(unclass(object)), nmax = nmax, total = TRUE) # lev <- as.matrix(attr(x, "levels")) # atr <- attributes(object) # atr$dim <- dim(lev) # atr$dimnames <- dimnames(lev) # attributes(lev) <- atr # attr(x, "levels") <- lev # x # } inum/R/interval.R0000644000176200001440000000541413055027457013406 0ustar liggesusers interval <- function(x, ...) UseMethod("interval") interval.default <- function(x, ...) stop("no interval method for class", " ", sQuote(class(x)), " ", "found") interval.numeric <- function(x, breaks = 50, ...) { ### from cut.default() if (length(breaks) == 1L) { if (is.na(breaks) || breaks < 2L) stop("invalid number of intervals") nb <- as.integer(breaks + 1) dx <- diff(rx <- range(x, na.rm = TRUE)) if (dx == 0) { dx <- abs(rx[1L]) breaks <- seq.int(rx[1L] - dx/1000, rx[2L] + dx/1000, length.out = nb) } else { breaks <- seq.int(rx[1L], rx[2L], length.out = nb) breaks[c(1L, nb)] <- c(rx[1L] - dx/1000, rx[2L] + dx/1000) } } else { breaks <- sort(as.double(breaks)) } if (anyDuplicated(breaks)) stop("'breaks' are not unique") ret <- cut.default(x, breaks = breaks, labels = FALSE) ret[is.na(x)] <- 0L attr(ret, "levels") <- breaks class(ret) <- c("interval", "integer") ret } levels.interval <- function(x) { breaks <- attr(x, "levels") return(paste("(", breaks[-length(breaks)], ",", breaks[-1], "]", sep = "")) } nlevels.interval <- function(x) length(attr(x, "levels")) - 1L print.interval <- function(x, quote = FALSE, max.levels = NULL, width = getOption("width"), ...) { print(c("", levels(x))[x + 1L], quote = quote) maxl <- if (is.null(max.levels)) TRUE else max.levels if (maxl) { n <- length(lev <- encodeString(levels(x), quote = ifelse(quote, "\"", ""))) colsep <- " < " T0 <- "Intervals: " if (is.logical(maxl)) maxl <- { width <- width - (nchar(T0, "w") + 3L + 1L + 3L) lenl <- cumsum(nchar(lev, "w") + nchar(colsep, "w")) if (n <= 1L || lenl[n] <= width) n else max(1L, which.max(lenl > width) - 1L) } drop <- n > maxl cat(if (drop) paste(format(n), ""), T0, paste(if (drop) c(lev[1L:max(1, maxl - 1)], "...", if (maxl > 1) lev[n]) else lev, collapse = colsep), "\n", sep = "") } return(invisible(x)) } "[.interval" <- function(x, i, ..., drop = FALSE) { ix <- unclass(x) ret <- ix[i] lev <- attr(x, "levels") if (drop) stop(sQuote("drop = TRUE"), " ", "not implemented in", " ", sQuote("[.interval")) attr(ret, "levels") <- lev class(ret) <- class(x) ret } format.interval <- function(x, ...) c("", levels(x))[x + 1L] is.na.interval <- function(x) unclass(x) == 0L inum/MD50000644000176200001440000000124014035062442011527 0ustar liggesusers106906ddbf9808b532dd78825d0ef9a2 *DESCRIPTION 328d1e76276ad8a4019e5a1746cd5e6a *NAMESPACE 7ceb471fb19e5b0645ecf0bf34222feb *R/enum.R dd22dd4311f59d57ffc0b7b6cc98b62b *R/interval.R 3e352aa371f0ec73a226fd857b8eb9b3 *R/inum.R 339c2c619522533780dc2ab641fef27d *cleanup 1dfa5d9358a2c930bb113bd68a8fa42c *inst/NEWS.Rd 26c4e331027b064acf4b32ab14b2acdd *man/enum.Rd 060c4485f8a056cc3908272e5a3100c3 *man/interval.Rd be4783f35d143567f86120f7048ac0be *man/inum.Rd e41e5a6cd49867f22e14a607e92b788b *tests/bugfixes.R 68a84e01e3ea79d20e380b4598062198 *tests/bugfixes.Rout.save 0cee5abe8427209bc56357c87a9fb435 *tests/regtest.R d6cf7ab50a02d539bfa87877c0279742 *tests/regtest.Rout.save inum/inst/0000755000176200001440000000000014035056312012176 5ustar liggesusersinum/inst/NEWS.Rd0000644000176200001440000000251614035056264013253 0ustar liggesusers \name{NEWS} \encoding{UTF-8} \title{News for Package \pkg{inum}} \section{Changes in version 1.0-4 (2021-04-12)}{ \itemize{ \item{\code{complete.cases.only = TRUE} did not work with all patterns of missings; bug spotted by Susanne Dandl.} } } \section{Changes in version 1.0-3 (2021-02-08)}{ \itemize{ \item{Update reference output.} } } \section{Changes in version 1.0-2 (2021-02-03)}{ \itemize{ \item{\code{complete.cases.only} returned nonsense.} } } \section{Changes in version 1.0-1 (2019-01-23)}{ \itemize{ \item{Differences must be larger than \code{sqrt(.Machine$double.eps)}.} \item{Handle numeric vectors with only two distinct values.} } } \section{Changes in version 1.0-0 (2017-12-12)}{ \itemize{ \item{Allow multiple variables in \code{as.interval}.} \item{When \code{nmax} is smaller than the number of unique values, optionally use the means of the observations in each bin as level (and not the corresponding quantiles as in earlier version) to minimise bias.} } } \section{Changes in version 0.9-2 (2017-02-27)}{ \itemize{ \item{Introduce \code{is.na} methods.} } } \section{Changes in version 0.9-1 (2017-02-01)}{ \itemize{ \item{Make sure all NAs are coded as 0.} } } \section{Changes in version 0.9-0 (2016-12-09)}{ \itemize{ \item{ \pkg{inum} published on CRAN.} } } inum/cleanup0000755000176200001440000000141014035056312012572 0ustar liggesusers#!/bin/sh for f in ./src/*.*o; do rm -f $f done for f in ./src/*~; do rm -f $f done for f in ./R/*~; do rm -f $f done for f in ./man/*~; do rm -f $f done for f in *~; do rm -f $f done for f in .*~; do rm -f $f done for f in ./tests/*~; do rm -f $f done for f in ./tests/*.ps; do rm -f $f done for f in ./inst/doc/*~; do rm -f $f done for f in ./inst/doc/coin.tex; do rm -f $f done for f in ./inst/doc/*.log; do rm -f $f done for f in ./inst/doc/*.out; do rm -f $f done for f in ./inst/doc/*.bbl; do rm -f $f done for f in ./inst/doc/*.blg; do rm -f $f done for f in ./inst/doc/*.brf; do rm -f $f done for f in ./inst/doc/*.aux; do rm -f $f done find . -name "DEADJOE" -exec rm -f {} \; exit 0