Collapsing levels of a variable by another variable with certain conditions - r

Question

I have the following example data table:
library(data.table)
exdt <- structure(list(domain = c(1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L,
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L),
L1 = c(1L, 1L, 2L, 2L, 3L, 3L, 4L, 4L, 5L, 5L, 5L, 5L, 6L, 7L, 8L, 8L, 9L, 9L, 10L,
10L, 11L, 12L, 12L, 13L, 13L, 14L, 15L, 15L, 16L, 16L, 17L, 17L,
18L, 18L, 19L, 19L, 20L, 21L, 22L, 22L, 23L, 23L, 23L, 24L, 25L,
25L, 25L, 25L, 26L, 26L, 26L),
L2 = c(1L, 1L, 1L, 1L, 2L, 2L, 3L, 3L, 4L, 4L, 4L, 4L, 4L, 5L, 5L, 5L, 6L, 6L, 6L, 6L, 7L, 7L,
7L, 8L, 8L, 8L, 9L, 9L, 9L, 9L, 10L, 10L, 10L, 10L, 11L, 11L,
11L, 12L, 12L, 12L, 13L, 13L, 13L, 13L, 14L, 14L, 14L, 14L, 14L,
14L, 14L)),
row.names = c(NA, -51L), class = c("data.table", "data.frame"))
I'd like to create a new variable L2, which is a grouping of two consecutive, unique levels of L1 within levels of domain. However, when I get to the end of a domain, I sometimes have a level of L1 that is stand-alone. In that case, I'd like to merge it with the two unique levels before it. This means that at the end of a domain, I may have merged together 3 consecutive, unique levels of L1 instead of 2 unique levels. The desired output is shown below.
exdt_L2_desired <- structure(list(domain = c(1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L,
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L),
L1 = c(1L, 1L, 2L, 2L, 3L, 3L, 4L, 4L, 5L, 5L, 5L, 5L, 6L, 7L, 8L, 8L, 9L, 9L, 10L,
10L, 11L, 12L, 12L, 13L, 13L, 14L, 15L, 15L, 16L, 16L, 17L, 17L,
18L, 18L, 19L, 19L, 20L, 21L, 22L, 22L, 23L, 23L, 23L, 24L, 25L,
25L, 25L, 25L, 26L, 26L, 26L),
L2 = c(1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 3L,3L, 4L, 4L, 4L, 4L, 5L, 5L, 5L, 6L,
6L, 6L, 6L, 7L, 7L, 7L, 8L, 8L, 8L, 8L, 9L, 9L, 9L, 9L, 10L, 10L, 11L, 11L,
11L, 11L, 11L, 12L, 12L, 12L, 12L, 12L, 12L, 12L, 12L)), row.names = c(NA, -51L),
class = c("data.table","data.frame"))
domain L1 L2
1 1 1
1 1 1
1 2 1
1 2 1
1 3 1
1 3 1
2 4 2
2 4 2
2 5 2
2 5 2
2 5 2
2 5 2
2 6 3
2 7 3
2 8 4
2 8 4
2 9 4
2 9 4
2 10 5
2 10 5
2 11 5
2 12 6
2 12 6
2 13 6
2 13 6
2 14 7
2 15 7
2 15 7
2 16 8
2 16 8
2 17 8
2 17 8
2 18 9
2 18 9
2 19 9
2 19 9
2 20 10
2 21 10
2 22 11
2 22 11
2 23 11
2 23 11
2 23 11
2 24 12
2 25 12
2 25 12
2 25 12
2 25 12
2 26 12
2 26 12
2 26 12
You can check that this has the right grouping L2 by:
#Check
exdt_L2_desired[, .(numL1_lev = uniqueN(L1)), by = list(domain,L2)]
domain L2 numL1_lev
1: 1 1 3
2: 2 2 2
3: 2 3 2
4: 2 4 2
5: 2 5 2
6: 2 6 2
7: 2 7 2
8: 2 8 2
9: 2 9 2
10: 2 10 2
11: 2 11 2
12: 2 12 3
As you can see each level of L2 has 2 or 3 levels of L1. For domain=1, numL1_lev=3 because there were only 3 unique L1 values, which were lumped into a single group. For domain=2, only the last level of L2 had the numL1_lev=3.
Attempt
I tried the following, but I seem to still have trouble getting the stand-alone levels of L1 within a given domain:
exdt_L2 <- exdt[, L2 :=
exdt[, {x <- ceiling(L1/2) #Group 2 consecutive, unique L1 levels by domain
#If the number of unique L1 levels at the end is stand-alone, then replace with previous group
if (length(unique(L1[x==x[.N]])) == 1) x[x==x[.N]] <- x[.N]-1
x
}, domain][, rleid(domain, V1)]
]
domain L1 L2
1 1 1
1 1 1
1 2 1
1 2 1
1 3 1
1 3 1
2 4 2
2 4 2
2 5 3
2 5 3
2 5 3
2 5 3
2 6 3
2 7 4
2 8 4
2 8 4
2 9 5
2 9 5
2 10 5
2 10 5
2 11 6
2 12 6
2 12 6
2 13 7
2 13 7
2 14 7
2 15 8
2 15 8
2 16 8
2 16 8
2 17 9
2 17 9
2 18 9
2 18 9
2 19 10
2 19 10
2 20 10
2 21 11
2 22 11
2 22 11
2 23 12
2 23 12
2 23 12
2 24 12
2 25 13
2 25 13
2 25 13
2 25 13
2 26 13
2 26 13
2 26 13

Answer 1

Using just ceiling(L1 / 2) will not work, as this assigns e.g. L1 = 4 and L1 = 5 to different bins, which should be added to the same L2 bin. Below is an updated version in the same spirit as OP's attempt instead using ceiling(rleid(L1) / 2):
library(data.table)
exdt[, L2 := {
## modify rle values
x <- ceiling(rleid(L1) / 2)
n <- length(unique(L1))
## if n is odd update last bin values
if(n > 1 && n %% 2 == 1) {
x[x == x[.N]] <- x[.N] - 1
}
x
}, by = "domain"][, L2 := rleid(domain, L2)]
all.equal(exdt, exdt_L2_desired)
#> [1] TRUE