inum/0000755000176200001440000000000014402347362011227 5ustar liggesusersinum/NAMESPACE0000644000176200001440000000150614402334207012442 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") S3method("enum", "default") S3method("interval", "default") S3method("inum", "default") inum/man/0000755000176200001440000000000014172231234011774 5ustar liggesusersinum/man/enum.Rd0000644000176200001440000000216114172231234013227 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.Rd0000644000176200001440000000221114172231234014103 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.Rd0000644000176200001440000000364014172231234013236 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/DESCRIPTION0000644000176200001440000000122014402347362012730 0ustar liggesusersPackage: inum Title: Interval and Enum-Type Representation of Vectors Date: 2023-03-09 Version: 1.0-5 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: 2023-03-09 10:45:13 UTC; hothorn Author: Torsten Hothorn [aut, cre] Maintainer: Torsten Hothorn Repository: CRAN Date/Publication: 2023-03-09 12:20:02 UTC inum/tests/0000755000176200001440000000000014172231234012363 5ustar liggesusersinum/tests/bugfixes.Rout.save0000644000176200001440000003301014172231234016004 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.R0000644000176200001440000000204414172231234014163 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.save0000644000176200001440000004151014172231234015651 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.R0000644000176200001440000000233414172231234014324 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/0000755000176200001440000000000014172231234011422 5ustar liggesusersinum/R/enum.R0000644000176200001440000000404714172231234012516 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.R0000644000176200001440000001406514172231234012523 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.R0000644000176200001440000000541414172231234013375 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/MD50000644000176200001440000000124014402347362011534 0ustar liggesusersf165deac454536b3800574da01764d79 *DESCRIPTION dbd40af676178d0f0410cbbf77cd5218 *NAMESPACE 7ceb471fb19e5b0645ecf0bf34222feb *R/enum.R dd22dd4311f59d57ffc0b7b6cc98b62b *R/interval.R 3e352aa371f0ec73a226fd857b8eb9b3 *R/inum.R 339c2c619522533780dc2ab641fef27d *cleanup 6e48d7f5e76ff3cac72a57773f217250 *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/0000755000176200001440000000000014402334271012177 5ustar liggesusersinum/inst/NEWS.Rd0000644000176200001440000000266414402334265013255 0ustar liggesusers \name{NEWS} \encoding{UTF-8} \title{News for Package \pkg{inum}} \section{Changes in version 1.0-5 (2023-03-09)}{ \itemize{ \item{Register default methods.} } } \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/cleanup0000755000176200001440000000141014402334271012573 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