/
id.r
70 lines (61 loc) · 1.77 KB
/
id.r
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
#' A unique numeric id for each unique row in a data frame.
#'
#' Properties:
#' \itemize{
#' \item \code{order(id)} is equivalent to \code{do.call(order, df)}
#' \item rows containing the same data have the same value
#' \item if \code{drop = FALSE} then room for all possibilites
#' }
#'
#' @param .variables list of variables
#' @param drop drop unusued factor levels?
#' @return a numeric vector with attribute n, giving total number of
#' possibilities
#' @keywords internal
#' @seealso \code{\link{id_var}}
#' @aliases id ninteraction
#' @export
id <- function(.variables, drop = FALSE) {
if (length(.variables) == 0) {
return(structure(1L, n = 1))
}
# Special case for single variable
if (length(.variables) == 1) {
return(id_var(.variables[[1]], drop = drop))
}
# Calculate individual ids
ids <- rev(lapply(.variables, id_var, drop = drop))
# Calculate dimensions
ndistinct <- unlist(lapply(ids, attr, "n"))
n <- prod(ndistinct)
p <- length(ids)
combs <- c(1, cumprod(ndistinct[-p]))
mat <- do.call("cbind", ids)
res <- c((mat - 1L) %*% combs + 1L)
attr(res, "n") <- n
# vdf <- data.frame(.variables)
# names(vdf) <- paste("X", 1:ncol(vdf), sep="")
# vdf$i <- res
# browser()
if (drop) {
id_var(res, drop = TRUE)
} else {
structure(as.integer(res), n = attr(res, "n"))
}
}
ninteraction <- id
#' Numeric id for a vector.
#' @keywords internal
id_var <- function(x, drop = FALSE) {
if (length(x) == 0) return(structure(integer(), n = 0))
if (!is.null(attr(x, "n")) && !drop) return(x)
if (is.factor(x) && !drop) {
id <- as.integer(addNA(x, ifany = TRUE))
n <- length(levels(x))
} else {
levels <- sort(unique(x), na.last = TRUE)
id <- match(x, levels)
n <- max(id)
}
structure(id, n = n)
}