dplyr :: mutate_at () полагается на несколько столбцов с заданным префиксом / суффиксом

Question

dplyr :: mutate_at () можно использовать для применения одной и той же функции к нескольким столбцам. Это также позволяет вам устанавливать результаты в новых столбцах, используя именованный список.

Однако, что если у меня много столбцов в парах (скажем, data1_a, data1_b, data2_a, data2_b ...) а я хочу умножить эти пары вместе? Возможно ли это?

От руки это будет выглядеть так:

suppressPackageStartupMessages({
  library(dplyr)
})

data.frame(data1_a = 1:3, data1_b = 2:4,
           data2_a = 3:5, data2_b = 4:6) %>%
  mutate(
    data1 = data1_a * data1_b,
    data2 = data2_a * data2_b
  )
#>   data1_a data1_b data2_a data2_b data1 data2
#> 1       1       2       3       4     2    12
#> 2       2       3       4       5     6    20
#> 3       3       4       5       6    12    30

Мое текущее решение - написать функцию, которая принимает имя переменной без суффикса (т.е. "data1"), создает суффикс имена, а затем выполняет простой mutate() для этой переменной, используя get(). Затем я вызываю эту функцию для каждого вывода:

foo <- function(df, name) {
  a <- paste0(name, "_a")
  b <- paste0(name, "_b")

  return(
    mutate(
      df,
      !!name := get(a) * get(b)
    )
  )
}

data.frame(data1_a = 1:3, data1_b = 2:4,
           data2_a = 3:5, data2_b = 4:6) %>%
  foo("data1") %>%
  foo("data2")
#>   data1_a data1_b data2_a data2_b data1 data2
#> 1       1       2       3       4     2    12
#> 2       2       3       4       5     6    20
#> 3       3       4       5       6    12    30

(или пишите al oop по всем именам переменных, если их было больше)

Но если возможно использовать mutate_at или что-то в этом роде, это было бы намного чище.

Answer 1

Мы можем использовать pivot_longer/pivot_wider

library(dplyr)
library(tidyr)
df1 %>% 
    mutate(rn = row_number()) %>%
    pivot_longer(cols = -rn, names_to = c('grp', '.value'),
        names_sep = "_") %>% 
    group_by(grp) %>%
    transmute(rn, new = a * b) %>%
    pivot_wider(names_from = grp, values_from = new) %>%
    select(-rn) %>%
    bind_cols(df1, .)
# A tibble: 3 x 6
#  data1_a data1_b data2_a data2_b data1 data2
#    <int>   <int>   <int>   <int> <int> <int>
#1       1       2       3       4     2    12
#2       2       3       4       5     6    20
#3       3       4       5       6    12    30

---

Или другой вариант - split в list на основе имен столбцов и затем сделать *

library(purrr)
library(stringr)
df1 %>%
   split.default(str_remove(names(.), "_.*")) %>% 
   map_dfr(reduce, `*`) %>%
   bind_cols(df1, .)
# A tibble: 3 x 6
#  data1_a data1_b data2_a data2_b data1 data2
#    <int>   <int>   <int>   <int> <int> <int>
#1       1       2       3       4     2    12
#2       2       3       4       5     6    20
#3       3       4       5       6    12    30

---

С mutate это возможно, но это было бы более ручным

df1 %>% 
  mutate(data1 = select(., starts_with('data1')) %>%
                reduce(`*`),
         data2 = select(., starts_with('data2')) %>%
                reduce(`*`))

data

df1 <- data.frame(data1_a = 1:3, data1_b = 2:4,
           data2_a = 3:5, data2_b = 4:6) 

Answer 2

После принятия элегантного решения @ akrun я заметил, что оно, к сожалению, очень неэффективно (поскольку ему приходится воссоздавать два кадра данных), занимая почти секунду для набора данных с 20 000 строк и 11 "группами".

Итак Некоторое время go Я разработал следующую функцию (с небольшой помощью @ user12728748 ... извините, что не публикую здесь раньше), которая принимает имена групп ("data1", " data2 ", et c) и формула, использующая префиксы, допускающие цитирование в стиле bquote для имен констант:

suppressPackageStartupMessages(library(dplyr))

mutateSet <- function(df, colNames, formula,
                      isPrefix = TRUE,
                      separator = "_") {
  vars <- all.vars(formula)

  # extracts names wrapped in `.()`
  escapedNames <- function (expr)
  {
    unquote <- function(e) {
      if (is.pairlist(e) || length(e) <= 1L) NULL
      else if (e[[1L]] == as.name("."))      deparse(e[[2L]])
      else                                   unlist(sapply(e, unquote))
    }
    unquote(substitute(expr))
  }

  escapedVars <- eval(rlang::expr(escapedNames(!!formula)))

  # remove escaped names from mapping variables
  vars <- setdiff(vars, escapedVars)

  # get output prefix/suffix as string
  lhs <- rlang::f_lhs(formula) %>%
    all.vars()

  # get operation as string
  # deparse() can have line breaks; paste0() brings it back to one line
  rhs <- rlang::f_rhs(formula) %>%
    deparse() %>%
    paste0(collapse = "")

  # dummy function to cover for bquote escaping
  . <- function(x) x

  for (i in colNames) {
    if (isPrefix) {
      aliases <- paste0(vars, separator, i)
      newCol  <- paste0(lhs,  separator, i)
    } else {
      aliases <- paste0(i, separator, vars)
      newCol  <- paste0(i, separator, lhs)
    }

    if (length(lhs) == 0) newCol <- i

    mapping <- rlang::list2(!!!aliases)
    names(mapping) <- vars
    mapping <- do.call(wrapr::qc, mapping)

    df <- rlang::expr(wrapr::let(
      mapping,
      df %>% dplyr::mutate(!!newCol := ...RHS...)
    )) %>%
      deparse() %>%
      gsub(
        pattern = "...RHS...",
        replacement = rhs
      ) %>%
      {eval(parse(text = .))}
  }

  return(df)
}

df <- data.frame(a_data1 = 1:3, b_data1 = 2:4,
                a_data2 = 3:5, b_data2 = 4:6,
                static = 5:7)

mutateSet(df, "data1", ~ a + b)
#>   a_data1 b_data1 a_data2 b_data2 static data1
#> 1       1       2       3       4      5     3
#> 2       2       3       4       5      6     5
#> 3       3       4       5       6      7     7
mutateSet(df, c("data1", "data2"), x ~ sqrt(a) + b)
#>   a_data1 b_data1 a_data2 b_data2 static  x_data1  x_data2
#> 1       1       2       3       4      5 3.000000 5.732051
#> 2       2       3       4       5      6 4.414214 7.000000
#> 3       3       4       5       6      7 5.732051 8.236068
mutateSet(df, c("data1", "data2"), ~ a + b + .(static))
#>   a_data1 b_data1 a_data2 b_data2 static data1 data2
#> 1       1       2       3       4      5     8    12
#> 2       2       3       4       5      6    11    15
#> 3       3       4       5       6      7    14    18

^{Создано в 2020-04-28 представьте пакет (v0.3.0)}

Возможно, это можно исправить (особенно это отвратительно для -l oop), но пока работает.

Повторяя тест производительности @ user12728748, мы видим, что это в ~ 100 раз быстрее:

suppressPackageStartupMessages({
    invisible(lapply(c("dplyr", "tidyr", "rlang", "wrapr", "microbenchmark"),
                     require, character.only = TRUE))
})

polymutate <- function(df, formula) {
    form <- rlang::f_rhs(formula)

    df %>% 
        mutate(rn = row_number()) %>%
        pivot_longer(cols = -rn, names_to = c('.value', 'grp'),
                     names_sep = "_") %>%
        group_by(grp) %>%
        transmute(rn, new = eval(form)) %>%
        pivot_wider(names_from = grp, values_from = new) %>%
        select(-rn) %>%
        bind_cols(df, .)
}

set.seed(1)                 
df <- setNames(data.frame(matrix(sample(1:12, 6E6, replace=TRUE), ncol=6)),
               c("a_data1", "b_data1", "a_data2", "b_data2", "a_data3", "b_data3"))

pd <- polymutate(df, ~ a + b)
pd2 <- mutateSet(df, c("data1", "data2", "data3"), ~ a + b)

all.equal(pd, pd2)
#> [1] TRUE

microbenchmark(polymutate(df, ~ a + b), 
               mutateSet(df, c("data1", "data2", "data3"), ~ a + b),
               times=10L)
#> Unit: milliseconds
#>        expr      min        lq       mean     median        uq       max neval
#>  polymutate 1612.306 1628.9776 1690.78586 1670.15600 1741.3490 1806.1412    10
#>  mutateSet     8.757    9.6302   13.27135   10.45965   19.2976   20.4657    10