Как обработать оценку списка функций в R - PullRequest
Новая
       64

Как обработать оценку списка функций в R

1 голос
/ 27 мая 2019

Я пытаюсь понять, как работать с пользовательской функцией агрегирования, которая будет работать с принципами оценки dplyr. Я хотел бы создать функцию формы: 

custom_aggregation <- function (data, stat_funs = list(mean, median), agg_col, ...)

, где data - это data.frame, stat_funs - список применяемых функций, agg_col указывает, к какому столбцу будут применены функции, ... - это столбцы для группировки.

Для одной функции агрегации я использую такой код: 

custom_aggregation <- function (data, stat_fun, agg_col, ...) {

  groups <- enquos(...) 
  agg_col <- enquo(agg_col) 
  stat_fun_enq <- enquo(stat_fun) 
  agg_name <- paste0(quo_name(agg_col), '', quo_name(stat_fun_enq))

  data %>% 
    group_by(!!!groups) %>% 
    summarise(!!agg_name := stat_fun(!!agg_col)) 
}

# I can try to call the function on mtcars data.frame:
custom_aggregation(mtcars, stat_fun = mean, agg_col = qsec, cyl, am)

Понятия не имею, как обращаться со списком функций (аргумент stat_fun).

Я пытался: 

map(stat_fun, enquo) # and the basic lapply equivalent with variants

lapply(stat_fun, function(i) {
  stat_fun_enq <- enquo(i)
})


lapply(seq_along(stat_fun), function(i) {
  stat_fun_enq <- enquo(stat_fun[[i]])
})

Может кто-нибудь подсказать мне, что я делаю не так?

1 Ответ

0 голосов
/ 27 мая 2019

В качестве опции можно передать функции в виде списка запросов и затем map через list, оценить (!!), чтобы применить функцию 

library(tidyverse)
custom_aggregation <- function (data, stat_fun, agg_col, ...) {

  groups <- enquos(...) 
  agg_col <- enquo(agg_col) 
  agg_name <- rlang::as_name(stat_fun)
  data %>%
        group_by(!!! groups) %>%
         summarise((!!agg_name) := (!!stat_fun)(!!agg_col))



}

Не ясно, ожидаемый формат вывода 

quos(mean, median)  %>%
      map(~ custom_aggregation(mtcars, stat_fun = .x, agg_col = qsec, cyl, am))
#[[1]]
# A tibble: 6 x 3
# Groups:   cyl [3]
#    cyl    am  mean
#  <dbl> <dbl> <dbl>
#1     4     0  21.0
#2     4     1  18.4
#3     6     0  19.2
#4     6     1  16.3
#5     8     0  17.1
#6     8     1  14.6

#[[2]]
# A tibble: 6 x 3
# Groups:   cyl [3]
#    cyl    am median
#  <dbl> <dbl>  <dbl>
#1     4     0   20.0
#2     4     1   18.6
#3     6     0   19.2
#4     6     1   16.5
#5     8     0   17.4
#6     8     1   14.6

Обновление

Если нам нужно в одном наборе данных 

library(rlang)
custom_aggregation <- function (data, stat_fun, agg_col, ...) {

  groups <- enquos(...) 
  agg_col <- enquo(agg_col) 

  nm1 <- str_c(rlang::as_name(agg_col),
       map_chr(rlang::call_args(rlang::enexpr(stat_fun)),
             rlang::as_name), sep="_") 

  data %>%
         group_by(!!! groups) %>%
         summarise_at(vars(rlang::as_name(agg_col)), stat_fun) %>%
         rename_at(vars(starts_with('fn')), ~ nm1)





}

-тестирование 

custom_aggregation(mtcars, stat_fun = list(sum), agg_col = qsec, cyl, am)    # A tibble: 6 x 3
# Groups:   cyl [3]
#    cyl    am  qsec
#  <dbl> <dbl> <dbl>
#1     4     0  62.9
#2     4     1 148. 
#3     6     0  76.9
#4     6     1  49.0
#5     8     0 206. 
#6     8     1  29.1




custom_aggregation(mtcars, stat_fun = list(sum, max), agg_col = qsec, cyl, am)
# A tibble: 6 x 4
# Groups:   cyl [3]
#    cyl    am qsec_sum qsec_max
#  <dbl> <dbl>    <dbl>    <dbl>
#1     4     0     62.9     22.9
#2     4     1    148.      19.9
#3     6     0     76.9     20.2
#4     6     1     49.0     17.0
#5     8     0    206.      18  
#6     8     1     29.1     14.6


custom_aggregation(mtcars, stat_fun = list(sum, min, max), agg_col = qsec, cyl, am)
# A tibble: 6 x 5
# Groups:   cyl [3]
#    cyl    am qsec_sum qsec_min qsec_max
#  <dbl> <dbl>    <dbl>    <dbl>    <dbl>
#1     4     0     62.9     20       22.9
#2     4     1    148.      16.7     19.9
#3     6     0     76.9     18.3     20.2
#4     6     1     49.0     15.5     17.0
#5     8     0    206.      15.4     18  
#6     8     1     29.1     14.5     14.6
...