Групповые вычисления, включающие элементы как для отдельных строк, так и для целых групп

Question

У меня небольшая проблема с согласованием логики этой проблемы с логикой dplyr.Обычно, если вы хотите сократить группу до одного числа на группу, вы используете summarise, а если вы хотите рассчитать отдельное число для каждой строки, вы используете mutate.Но что, если вы хотите сделать расчет для группы для каждой строки?

В приведенном ниже примере mloc содержит указатель на pnum, и цель состоит в том, чтобы добавить новый столбец nm_childкоторый для каждой строки подсчитывает количество mloc значений в группе, которые указывают (то есть имеют то же значение, что и) индекс строки в группе в pnum.Это было бы легко сделать с помощью вложенных циклов или с map, если бы я знал, как выполнить итерации 1) для каждой группы, & 2) по каждому элементу, & 3) вернуть вывод карты в виде столбца в группе.

library(tidyverse)

ser    <- c(1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2)
pnum   <- c(1:5, 1:6)
mloc   <- c(0, 2, 2, 0, 3, 1, 1, 0, 0, 3, 4)

tb1 <- tibble(ser,pnum,  mloc)
tb2 <- tb1 %>%
group_by(ser) %>%
mutate(nm_child = sum(pnum == mloc))

Выше указано nm_child всегда = 1. Я понимаю, почему это не работает, но я не понимаю, почему это так.

Я также пытался

mutate(nm_child = count(pnum == mloc))

(который возвращает

no applicable method for 'groups' applied to an object of class "logical")

и другие разные вещи. Я получил одну вещь для работы, добавив несколько столбцов для промежуточных значений и используя кучу вложенных ifelse (), новыполнение моих девяти миллионов строк занимает более 20 минут - в отличие, например, от регрессии и от самых простых операций dplyr, которые варьируются от нескольких секунд и слишком быстро заметны.

Желаемый результат:

tb2$nm_child = c(0, 2, 1, 0, 0, 2, 0, 1, 1, 0, 0)

Answer 1

Это агрегирование по ser + mloc, затем левое присоединение к исходным данным. Не должно быть необходимости перебирать каждое отдельное значение:

tb1 %>%
  group_by(ser, mloc) %>%
  summarise(nm_child=n()) %>%
  left_join(tb1, ., by=c("ser"="ser","pnum"="mloc"))

## A tibble: 11 x 4
#     ser  pnum  mloc nm_child
#   <dbl> <dbl> <dbl>    <int>
# 1  1.00  1.00  0          NA
# 2  1.00  2.00  2.00        2
# 3  1.00  3.00  2.00        1
# 4  1.00  4.00  0          NA
# 5  1.00  5.00  3.00       NA
# 6  2.00  1.00  1.00        2
# 7  2.00  2.00  1.00       NA
# 8  2.00  3.00  0           1
# 9  2.00  4.00  0           1
#10  2.00  5.00  3.00       NA
#11  2.00  6.00  4.00       NA

Это будет намного эффективнее:

# big example
tb1 <- tb1[rep(1:11,5e4),]
tb1$ser <- rep(1:1e5, rep(5:6,5e4))

system.time({
tb1 %>% 
  group_by(ser) %>% 
  mutate(
    nm_child = sapply(pnum, function(x) sum(x == mloc))
  )
})
#   user  system elapsed 
#   8.83    0.06    8.97     

system.time({
tb1 %>%
  group_by(ser, mloc) %>%
  summarise(nm_child=n()) %>%
  left_join(tb1, ., by=c("ser"="ser","pnum"="mloc"))
})
#   user  system elapsed 
#   0.67    0.02    0.69 

В базовой логике R это будет что-то вроде:

tabu <- aggregate(cbind(nm_child=mloc) ~ ser + mloc, tb1, FUN=length)
merge(tb1, tabu, by.x=c("ser","pnum"), by.y=c("ser","mloc"), all.x=TRUE)

И округлить его до data.table, что снова будет на порядок быстрее:

tb1[tb1[, .N, by=.(ser,mloc)], on=c("ser","pnum"="mloc"), nm_child := N]

Answer 2

Вот способ использования sapply -

tb1 %>% 
  group_by(ser) %>% 
  mutate(
    nm_child = sapply(pnum, function(x) sum(x == mloc))
  )

# A tibble: 11 x 4
# Groups:   ser [2]
     ser  pnum  mloc nm_child
   <dbl> <int> <dbl>    <int>
 1  1.00     1  0           0
 2  1.00     2  2.00        2
 3  1.00     3  2.00        1
 4  1.00     4  0           0
 5  1.00     5  3.00        0
 6  2.00     1  1.00        2
 7  2.00     2  1.00        0
 8  2.00     3  0           1
 9  2.00     4  0           1
10  2.00     5  3.00        0
11  2.00     6  4.00        0

Вот еще один способ, благодаря @RonakShah -

tb1 %>% 
  group_by(ser) %>% 
  mutate(
    nm_child = map_int(pnum, ~sum(. == mloc))
  )

Обновление: обзор тестов в других ответах, @thelatemailответ, безусловно, лучший.

Answer 3

Вы можете использовать outer и rowSums

tb1 %>% 
  group_by(ser) %>% 
  mutate(nm_child = rowSums(outer(pnum, mloc, `==`)))

# # A tibble: 11 x 4
# # Groups:   ser [2]
#      ser  pnum  mloc nm_child
#    <dbl> <int> <dbl>    <dbl>
#  1     1     1     0        0
#  2     1     2     2        2
#  3     1     3     2        1
#  4     1     4     0        0
#  5     1     5     3        0
#  6     2     1     1        2
#  7     2     2     1        0
#  8     2     3     0        1
#  9     2     4     0        1
# 10     2     5     3        0
# 11     2     6     4        0

Бенчмарк с примерами thelatemail

tb1 <- tb1[rep(1:11,5e4),]
tb1$ser <- rep(1:1e5, rep(5:6,5e4))

tb2 <- as.data.table(tb1)

library(microbenchmark)

microbenchmark(
  sapply = {
    tb1 %>% 
      group_by(ser) %>% 
      mutate(
        nm_child = sapply(pnum, function(x) sum(x == mloc))
      )
  },
  join = {
    tb1 %>%
      group_by(ser, mloc) %>%
      summarise(nm_child=n()) %>%
      left_join(tb1, ., by=c("ser"="ser","pnum"="mloc"))
  },
  outer1 = {
    tb1 %>% 
      group_by(ser) %>% 
      mutate(nm_child = rowSums(outer(pnum, mloc, `==`)))
  },
  outer2 = {
    tb1 %>% 
      group_by(ser) %>% 
      mutate(nm_child = colSums(outer(mloc, pnum, `==`)))
  },
  data.table = {
    tb2[tb2[, .N, by=.(ser,mloc)], on=c("ser","pnum"="mloc"), nm_child := N][]
    },
  times = 10)

Тест производительности

# Unit: milliseconds
#        expr       min        lq      mean    median        uq        max neval
#      sapply 8233.5740 8297.7331 8939.9369 8647.5935 8956.3364 10706.3362    10
#        join  889.6682  899.0483  935.7493  908.1441  932.2827  1135.8424    10
#      outer1 4551.0428 4631.1605 5184.9359 4986.7327 5160.0109  7563.4190    10
#      outer2 4495.9134 4552.1169 4763.5954 4723.7783 4893.2190  5198.4556    10
#  data.table  108.7449  115.7866  124.4453  120.6742  125.7591   171.8111    10