Using case_when and between with a correspondance threshold table

user_11636794 0
Viewed 267

Good morning,

I have 2 dataframes : (25000,66) and a thershold table (10,2) containing 10 groups and the last id of each group.

In the big dataset I have one variable called id. It's just id = row_number()

id
1
2
3
4
5
...
25000

EDIT : Lots of answers, thank you for all your ideas. Reading I realized that I forgot an important step in my data description and I apologized.

I'm using synthetic sampling on the original bigdataset to genereate new points. So after sampling the id column looks like this :

id
1
2
2.1
3
3.8
4.74
5.12
6
...
25000

This is why I used the between clause with the last_id to reassign the id to their group.

Threshold table :

last_id   group_name
50        grp1
1500      grp2
8900      grp3
...
25000     grp10

I would like to add new column to the big dataset in order to have the id and the group name, based only on the condition that the id falls in the group specified range by the threshold table.

For now I wrote this :

df <- df %>%
    dplyr::mutate(group_name = case_when(id < last_id[1,1] ~ last_id[1,2],
                                                between(id, last_id[1,1], last_id[2,1]) ~ last_id[2,2],
                                                between(id, last_id[2,1], last_id[3,1]) ~ last_id[3,2],
                                                between(id, last_id[3,1], last_id[4,1]) ~ last_id[4,2],
                                                between(id, last_id[4,1], last_id[5,1]) ~ last_id[5,2],
                                                between(id, last_id[5,1], last_id[6,1]) ~ last_id[6,2],
                                                between(id, last_id[6,1], last_id[7,1]) ~ last_id[7,2],
                                                between(id, last_id[7,1], last_id[8,1]) ~ last_id[8,2],
                                                between(id, last_id[8,1], last_id[9,1]) ~ last_id[9,2],
                                                id > last_id[9,1] ~ last_id[10,2]))
    )

But it doesn't work, I get this error :

Error in FUN(left, right) : comparaison (5) ony possible for types list and atomic

Moreover this code looks terrible, there must be another way using apply or another dplyr function?

Thank you for reading.

dplyr r
5 Answers

Two options with the data.table-package:

1) use the rolling join functionality

dt <- dt2[dt1, on = .(last_id = id), roll = -Inf]

which gives:

> dt
      last_id group_name
   1:       1       grp1
   2:       2       grp1
   3:       3       grp1
   4:       4       grp1
   5:       5       grp1
  ---                   
8896:    8896       grp3
8897:    8897       grp3
8898:    8898       grp3
8899:    8899       grp3
8900:    8900       grp3

2) use the non-equi join functionality

# create a 'first_id'
dt2[, first_id := shift(last_id, fill = 0)]
# perform the non-equi join
dt1[dt2, on = .(id > first_id, id <= last_id), group := group_name]

This method will update dt1 instead of creating a new data.table and is therefor more memory efficient:

> dt1
        id group
   1:    1  grp1
   2:    2  grp1
   3:    3  grp1
   4:    4  grp1
   5:    5  grp1
  ---           
8896: 8896  grp3
8897: 8897  grp3
8898: 8898  grp3
8899: 8899  grp3
8900: 8900  grp3

Options using base R:

Pure base R with findInterval (which is comparable to the cut-method from @ Otto Kässi):

df1$group_name <- df2$group_name[findInterval(df1$id, c(0, df2$last_id), left.open = TRUE)]

Or with base R's merge and zoo::na.locf:

df <- merge(df1, df2, by.x = "id", by.y = "last_id", all.x = TRUE)
df$group_name <- zoo::na.locf(df$group_name, fromLast = TRUE)

Used data:

df1 <- data.frame(id = 1:8900)
df2 <- read.table(text="last_id   group_name
50        grp1
1500      grp2
8900      grp3
", header=TRUE, stringsAsFactors=FALSE)

library(data.table)
dt1 <- as.data.table(df1)
dt2 <- as.data.table(df2)
user_22044100

Here is an approach that uses dplyr::mutate() to create ranges of the index variable, along with sqldf() and the BETWEEN command to join the data.

df <- data.frame(matrix(runif(10000,max=100),1000,10))
df$id <- 1:nrow(df)
library(dplyr)
grptbl <- data.frame(maxIndex = c(250,500,750,1000),groupID = c("one","two","three","four"))
grptbl <- mutate(grptbl,minIndex = if_else(is.na(lag(maxIndex)),1,lag(maxIndex)+1))

library(sqldf)
joinedData <- sqldf("select df.*, grptbl.groupID 
                    from df LEFT JOIN grptbl ON (df.id BETWEEN grptbl.minIndex AND grptbl.maxIndex)")
# print first and last rows of each group
joinedData[c(1,250,251,500,501,750,751,1000),c("group_name","X1","X2")]

...and the output:

> # print first and last rows of each group
> joinedData[c(1,250,251,500,501,750,751,1000),c("group_name","X1","X2")]
     group_name        X1        X2
1           one 53.807611 15.134119
250         one 53.016958 50.554198
251         two 36.921168  3.984325
500         two  5.974273 33.079079
501       three 75.851652 24.039047
750       three 98.233083 26.500973
751        four 14.788170 10.312172
1000       four 11.106466 41.666359

Another alternative with sqldf() is to complete the merge via the WHERE clause instead of LEFT JOIN:

joinedData <- sqldf("select df.*, grptbl.groupID 
                    from df, grptbl
                    WHERE df.id BETWEEN grptbl.minIndex AND grptbl.maxIndex")
user_84719310

cut in base R can do this relatively easily:

bigdataset <- data.frame(seq(1, 25000,1))
names(bigdataset) <- 'id'
thresholds <- data.frame(
                       c(50, 1500, 8900, 10000, 12000, 13000, 14000, 15000, 16000, 25000), 
                       c('grp1','grp2','grp3','grp4', 'grp5','grp6', 'grp7','grp8','grp9','grp10'))
names(thresholds) <- c('last_id','group_name')

cut(bigdataset$id, breaks=breaks=c(min(bigdataset$id),thresholds$last_id + 1), labels=thresholds$group_name[1:10], right=FALSE) -> bigdataset$group_name

Output:

> bigdataset
         id group_name
1         1       grp1
2         2       grp1
3         3       grp1
4         4       grp1
5         5       grp1
6         6       grp1
7         7       grp1
8         8       grp1
9         9       grp1
10       10       grp1
11       11       grp1
12       12       grp1
13       13       grp1
14       14       grp1
15       15       grp1
16       16       grp1
17       17       grp1
18       18       grp1
19       19       grp1
20       20       grp1
21       21       grp1
22       22       grp1
23       23       grp1
24       24       grp1
25       25       grp1
26       26       grp1
27       27       grp1
28       28       grp1
29       29       grp1
30       30       grp1
31       31       grp1
32       32       grp1
33       33       grp1
34       34       grp1
35       35       grp1
36       36       grp1
37       37       grp1
38       38       grp1
39       39       grp1
40       40       grp1
41       41       grp1
42       42       grp1
43       43       grp1
44       44       grp1
45       45       grp1
46       46       grp1
47       47       grp1
48       48       grp1
49       49       grp1
50       50       grp2
51       51       grp2
52       52       grp2
53       53       grp2
54       54       grp2
55       55       grp2
56       56       grp2
57       57       grp2
58       58       grp2
59       59       grp2
60       60       grp2

Note that you need to pad your thresholds with min(bigdataset$id); that way you have 11 cutpoints for 10 classes.

user_86845510

You can do a join instead and then use "last observation carried forward" (na.locf from the zoo package) as a workaround to fill up the missing values:

# some sample data
df <- data.frame(id = 1:50, val = LETTERS[1:10])
threshold <- data.frame(last_id = c(5, 15, 34, 45),
                        group_name = paste0("group_", 1:4))

df %>% 
  dplyr::left_join(threshold, by = c("id" = "last_id")) %>% 
  zoo::na.locf(fromLast = TRUE)

#>    id val group_name
#> 1   1   A    group_1
#> 2   2   B    group_1
#> 3   3   C    group_1
#> 4   4   D    group_1
#> 5   5   E    group_1
#> 6   6   F    group_2
#> 7   7   G    group_2
#> 8   8   H    group_2
#> 9   9   I    group_2
#> 10 10   J    group_2

Technically, by setting fromLast = TRUE, this actually corresponds to NOCB (next observation carried backward).

user_135340600

Here's a tidyverse solution. Since you're joining at the max value for each group, you can specify .direction = 'up' to fill in all of the missing values.

library(tidyverse)
df <- left_join(df1,df2,by = c('id' = 'last_id')) %>% 
  fill(group_name, .direction = 'up')

df1:

df1 <- data.frame(id = rep(1:25000))

df2:

structure(list(last_id = c(50, 1500, 8900, 10500, 16900, 25000
), group_name = c("grp1", "grp2", "grp3", "grp4", "grp5", "grp6"
)), row.names = c(NA, -6L), class = c("tbl_df", "tbl", "data.frame"
))
user_129679380
Related