Performing `top_n`-like operations on tibbles with intersecting groups

user_2970196 0
Viewed 74

I'm trying to write an R script to perform the following task. I have two tibbles:

library(dplyr); library(magrittr)

(
tibs <- list(
        top = tibble(
                letter = c(rep("A",4),rep("B",4)), 
                number = c(rep(1,2), rep(2,2)) %>% rep(2),
                element = c("x","y","z","w","x","y","z","w"),
                score = 1:8
                ) %>% group_by(letter,number),
        bottom = tibble(
                letter = c(rep("A",2),rep("B",2)),
                element = c("p","q","y","z"),
                score = c(2.5,3.5, 4,5.5)
                ) %>% group_by(letter)
        )
)

# A tibble: 8 x 4
# Groups:   letter, number [4]
  letter number element score
  <chr>   <dbl> <chr>   <int>
1 A           1 x           1
2 A           1 y           2
3 A           2 z           3
4 A           2 w           4
5 B           1 x           5
6 B           1 y           6
7 B           2 z           7
8 B           2 w           8

$bottom
# A tibble: 4 x 3
# Groups:   letter [2]
  letter element score
  <chr>  <chr>   <dbl>
1 A      p         2.5
2 A      q         3.5
3 B      y         4  
4 B      z         5.5

For each group Xn of the top-level tibble, defined by letter (X = "A" or "B") and number (n = 1 or 2), I would like to select the two lowest scoring elements, among those that appear in group Xn of the top-level tibble or in group X of the lower level tibble. If an element appears both in the top- and lower-level tibble, it's score is taken from the top tibble.

So, in this example, I'm expecting to get x,y for group A1, p,z for group A2, x,z for group B1 and y,z for group B2.

I have to perform this kind of operation on (top-level) tibbles having up to a million different groups (at top level), and a few entries in each group. I would like to obtain a fast and possibly readable solution, within dplyr or not.

My solution so far returns the expected output, but is particularly unsatisfying from the efficiency point of view:

summarizer <- function(letter, element, score, bottom){
        bottom %<>% filter(letter == !!letter[1], !(element %in% !!element))
        order(c(score, bottom$score)) %>%
                c(element, bottom$element)[.] %>%
                head(2) %>%
                paste0(collapse = " ")
}


tibs$top %>% summarise(preds = summarizer(letter, element, score, 
                                          tibs$bottom)
                       )


# A tibble: 4 x 3
# Groups:   letter [2]
  letter number preds
  <chr>   <dbl> <chr>
1 A           1 x y  
2 A           2 p z  
3 B           1 x z  
4 B           2 y z

In particular, with a large number of groups, the big bottleneck is the pipe-assignment %<>% in my function summarizer, which however I can't see how to avoid.

I have the following questions related to the above:

  1. dplyr's group_by groups are, by construction, never intersecting. Is there a way (within dplyr or not) to group data.frames in such a way that rows can belong to more than one group?
  2. If not, my task could be solved by creating duplicates of the elements belonging to more groups and labeling them appropriately. How would you do this fastly?
  3. Do you see any other fast (and possibly readable) solution to the above problem?
tibble dplyr greatest-n-per-group grouping r
2 Answers

Here is an option using data.table.

library(data.table)
setDT(top)
setDT(bottom)

#get unique groups
g = unique(top[,.(letter, number)])

#creating duplicates for each letter in bottom for each group using a left join on letter
b = bottom[g, on=.(letter)]

#If an element appears both in the top- and lower-level tibble, it's score is taken from the top tibble.
#use an update join to lookup the scores from top tibble
b[top, on=.(letter, number, element), score := i.score]

#bind_rows and remove identical rows
rowsbind = rbindlist(list(top, b), use.names=TRUE)
both = unique(rowsbind, by=c("letter", "number", "element"))

#order and subset
setorder(both, letter, number, score)
both[rowid(letter, number) <= 2L]

data:

library(data.table)
top = data.table(
    letter = c(rep("A",4),rep("B",4)), 
    number = rep(c(rep(1,2), rep(2,2)), 2),
    element = c("x","y","z","w","x","y","z","w"),
    score = as.double(1:8)
)
bottom = data.table(
    letter = c(rep("A",2),rep("B",2)),
    element = c("p","q","y","z"),
    score = c(2.5,3.5, 4,5.5)
)
user_19894800

Same strategy as in the accepted answer, but using dplyr.

top1 <- bind_rows(bottom %>% left_join(top %>% select(letter, number) %>% unique),
                  top,
                  .id = "id") %>%
        group_by(letter, number, element) %>% top_n(1, wt = id) %>% ungroup %>% 
        group_by(letter, number) %>%
        mutate(rank = rank(score, ties.method = "first")) %>%
        filter(rank <= 2) %>%
        select(letter, number, element, score)
user_29701960
Related