1id <- function(.variables, drop = FALSE) { 2 if (length(.variables) == 0) { 3 n <- nrow(.variables) %||% 0L 4 return(structure(seq_len(n), n = n)) 5 } 6 7 # Special case for single variable 8 if (length(.variables) == 1) { 9 return(id_var(.variables[[1]], drop = drop)) 10 } 11 12 # Calculate individual ids 13 ids <- rev(map(.variables, id_var, drop = drop)) 14 p <- length(ids) 15 16 # Calculate dimensions 17 ndistinct <- map_dbl(ids, attr, "n") 18 n <- prod(ndistinct) 19 if (n > 2 ^ 31) { 20 # Too big for integers, have to use strings, which will be much slower :( 21 22 char_id <- do.call("paste", c(ids, sep = "\r")) 23 res <- match(char_id, unique(char_id)) 24 } else { 25 combs <- c(1, cumprod(ndistinct[-p])) 26 27 mat <- do.call("cbind", ids) 28 res <- c((mat - 1L) %*% combs + 1L) 29 } 30 attr(res, "n") <- n 31 32 33 if (drop) { 34 id_var(res, drop = TRUE) 35 } else { 36 structure(as.integer(res), n = attr(res, "n")) 37 } 38} 39 40id_var <- function(x, drop = FALSE) { 41 if (!is_null(attr(x, "n", exact = TRUE)) && !drop) return(x) 42 43 if (is.factor(x) && !drop) { 44 x_na <- addNA(x, ifany = TRUE) 45 id <- as.integer(x_na) 46 n <- length(levels(x_na)) 47 } else if (length(x) == 0) { 48 id <- integer() 49 n <- 0L 50 } else if (is_list(x)) { 51 # Sorting lists isn't supported 52 levels <- unique(x) 53 id <- match(x, levels) 54 n <- max(id) 55 } else { 56 levels <- sort(unique(x), na.last = TRUE) 57 id <- match(x, levels) 58 n <- max(id) 59 } 60 structure(id, n = n) 61} 62