Dplyr & purrr с динамическими именами столбцов, выберите и скопируйте по группе

Question

У меня есть следующий код, где мне нужно извлечь имена столбцов из переменной, а затем выборочно выполнить операцию со строками, используя указанный столбец в этой операции.Вот мой простой пример: создание столбца res для соответствия столбцу targe t:

library(tidyverse)

tst <- tibble(grp = c("a","a","b","b","c","c"), a = rep(2,6), b = rep(4,6), 
              c = rep(8,6), target = c(2,2,4,4,8,8), res = rep(0,6))

# create list of columns to iterate over
lst <-  unique(tst$grp)

# loop over each column, creating a dummy column with 
# the copied value in the matching rows, zeroes elsewhere
for(g in lst) {

  tst <- tst %>% 
    mutate(!!paste("res", g, sep="_") := ifelse(grp == g, !!rlang::sym(g),0)) %>% 
    select(!!paste("res", g, sep="_")) %>% 
    cbind(tst)
}

# combine the dummy columns by rowSum
res <- tst %>% select(starts_with("res_")) %>% mutate(res = rowSums(.)) %>% 
select(res)

# tidy up the output, result matches the target
tst <- tst %>% select(grp, a, b, c, target) %>% cbind(res)

tst

  grp a b c target res
1   a 2 4 8      2   2
2   a 2 4 8      2   2
3   b 2 4 8      4   4
4   b 2 4 8      4   4
5   c 2 4 8      8   8
6   c 2 4 8      8   8

Я использовал итеративный подход, просматривая уникальные переменные в столбце grp, создавая временныезатем столбцы rowSum(), чтобы получить окончательный результат.Неуклюжий, но добрался до конца.

Я уверен, что есть более элегантный способ сделать это с одним из map семейства purrr.Может кто-нибудь показать мне, как я могу сделать это без цикла, используя purrr?Я действительно изо всех сил пытался заставить динамическое имя столбца работать, используя этот подход.Заранее спасибо.

Answer 1

Это базовое решение R, которое также не длиннее:

# Save all source columns in a matrix. This enables indexing by another matrix
x <- as.matrix(tst[, unique(tst$grp)])
# Matrix of (row, column) pairs to extract from x
i <- cbind(seq_len(nrow(tst)), match(tst$grp, colnames(x)))
tst$res <- x[i]

---

Редактировать: Истекшее время для таблицы большего размера:

tst <- tst[sample(nrow(tst), 50000, TRUE), ]

0,008 с -0.015s

Answer 2

То, что не требует написания цикла

library(tidyverse)

tst <- tibble(grp = c("a","a","b","b","c","c"), a = rep(2,6), b = rep(4,6), 
              c = rep(8,6), target = c(2,2,4,4,8,8), res = rep(0,6))

tst %>% 
  mutate(res = 
           case_when(
             grp == "a" ~ a,
             grp == "b" ~ b,
             grp == "c" ~ c
           ))

# A tibble: 6 x 6
  grp       a     b     c target   res
  <chr> <dbl> <dbl> <dbl>  <dbl> <dbl>
1 a         2     4     8      2     2
2 a         2     4     8      2     2
3 b         2     4     8      4     4
4 b         2     4     8      4     4
5 c         2     4     8      8     8
6 c         2     4     8      8     8

Примечание: вместо ~ a вы можете использовать собственную формулу, если это необходимо.
Для получения дополнительной информации см. ?case_when

Answer 3

Вы можете использовать imap, который перебирает значения столбцов и их имена.Значения столбца - это значения grp, имена - это просто последовательность 1,...,6.

Кроме того, вы должны указать сам фрейм данных в качестве дополнительного аргумента (от df= до imap)., который он пересылает в свой аргумент функции. Всего:

tst %>% 
  mutate(res = purrr::imap_dbl(grp, df = ., 
    .f = function(g, i, df) df[i,g][[1]] # [[1]] turns the result from tibble into a double
  )) 

---

Редактировать: Я рассчитал это решение с помощью таблицы большего размера:

tst <- tst[sample(nrow(tst), 50000, TRUE),]

, и это занимает около 50 с.

Answer 4

Возможно:

tst %>% 
  mutate(res = sapply(seq(nrow(tst)), function(x) tst[x,as.character(tst$grp[x])]))


# A tibble: 6 x 6
    grp     a     b     c target   res
  <chr> <dbl> <dbl> <dbl>  <dbl> <dbl>
1     a     2     4     8      2     2
2     a     2     4     8      2     2
3     b     2     4     8      4     4
4     b     2     4     8      4     4
5     c     2     4     8      8     8
6     c     2     4     8      8     8