r - 在 R 中从一个函数创建多列(然后对它们进行平均)

Question

开始于:

dates <- yday(ceiling_date(dmy(sapply(1:11, function(x) paste0("01/", x, "/2009"))), "month") %m-% days(1))

foo <- data.frame(id = 1:1000000) %>%
  mutate(
    datdeb = round(runif(n(), 1, 365)),
    datfin = round(runif(n(), datdeb, 365)),
    etp = runif(n()),
    group = round(runif(n(), 1, 1000))
  )

我想做的最基本的版本是:

for(i in 1:11){
  foo <- foo %>%
    group_by(group) %>%
    mutate(
      test = sum((dates[i] >= datdeb & dates[i] <= datfin))
    ) %>%
    rename(!!paste0("size_date", dates[i]) := "test")
}

res1 <- foo %>%
  mutate(
    m_size = rowMeans(across(starts_with("size_date")))
  ) %>%
  group_by(group) %>%
  summarise(
    m_size = mean(m_size)
  )

现在我想以尽可能快的方式执行此操作，因为我要应用它的最终数据集非常庞大。

首先，我想到的替代方案是:

foo <- bind_cols(foo, map_dfc(1:11, ~ foo %>%
                          group_by(group) %>%
                          transmute(!!paste0("size_date", dates[.x]) := sum((dates[.x] >= datdeb & dates[.x] <= datfin)))
                          ) %>% select(starts_with("size_date")))

但令我有些惊讶的是，当使用 tictoc 进行基准测试时，这最终变慢了。

对于第二部分，我提出了另外两个选项:

res2 <- foo %>%
  mutate(
    m_size = rowMeans(across(starts_with("size_date")))
  ) %>%
  group_by(group) %>%
  summarise(
    m_size = m_size[1]
  )

res3 <- foo %>%
  group_by(group) %>%
  slice(1) %>%
  mutate(
    m_size = rowMeans(across(starts_with("size_date")))
  )

不出所料，最后一个选项要快得多。

我想知道是否有更快(更优雅？)的方法来完成这项工作？特别是，有可能以智能方式将这两个步骤与增量累积均值结合起来？谢谢!

Answer 1

我有一个更优雅的方法，但我怀疑它是否真的高效。一种方法是使用 purrr::map_dfc并遍历 dates矢量。

library(tidyverse)
library(lubridate)

dates <- yday(ceiling_date(dmy(sapply(1:11, function(x) paste0("01/", x, "/2009"))), "month") %m-% days(1))

foo <- data.frame(id = 1:1000000) %>%
  mutate(
    datdeb = round(runif(n(), 1, 365)),
    datfin = round(runif(n(), datdeb, 365)),
    etp = runif(n()),
    group = round(runif(n(), 1, 1000))
  )

foo %>% 
  group_by(group) %>% 
  mutate(m_size = rowMeans(
    map_dfc(set_names(dates, dates),
            ~ sum(.x >= datdeb & .x <= datfin))
    )
  ) %>% 
  summarise(m_size = mean(m_size))
#> # A tibble: 1,000 x 2
#>    group m_size
#>    <dbl>  <dbl>
#>  1     1   141.
#>  2     2   258.
#>  3     3   298.
#>  4     4   283.
#>  5     5   286.
#>  6     6   274.
#>  7     7   263.
#>  8     8   273 
#>  9     9   272.
#> 10    10   261.
#> # … with 990 more rows

^{由 reprex package 创建于 2021-04-28 (v0.3.0)}

如果您对中间列感兴趣，我在 Github 上有一个名为 {dplyover} 的包，它可以遍历向量以创建命名良好的列。它的性能不是很好，但从基准测试来看，它的性能似乎还不错(参见下面的基准测试)。

library(dplyover) # https://timteafan.github.io/dplyover/

 foo %>% 
    group_by(group) %>% 
    mutate(over(dates,
                ~ sum(.x >= datdeb & .x <= datfin),
                .names = "size_date{x}"))

#> # A tibble: 1,000,000 x 16
#> # Groups:   group [1,000]
#>       id datdeb datfin    etp group size_date31 size_date59 size_date90
#>    <int>  <dbl>  <dbl>  <dbl> <dbl>       <int>       <int>       <int>
#>  1     1    233    234 0.0322   581          82         154         218
#>  2     2    185    305 0.452    956          97         171         221
#>  3     3    237    281 0.0410   735          90         162         232
#>  4     4    255    290 0.290    646          86         159         222
#>  5     5     57    215 0.762    748          78         156         245
#>  6     6     42    218 0.343    243          80         154         215
#>  7     7     52     66 0.329    238          75         145         215
#>  8     8    138    158 0.724    681          81         150         221
#>  9     9     19    135 0.285    542          87         172         235
#> 10    10    300    330 0.0665    61          79         151         212
#> # … with 999,990 more rows, and 8 more variables: size_date120 <int>,
#> #   size_date151 <int>, size_date181 <int>, size_date212 <int>,
#> #   size_date243 <int>, size_date273 <int>, size_date304 <int>,
#> #   size_date334 <int>

^{由 reprex package 创建于 2021-04-28 (v0.3.0)}

这将是我的 data.table方法，但我认为，有更好的方法来做到这一点，也许其他用户会在这里提出意见。

foo_dat <- as.data.table(foo)

foo_dt[, paste0("size_date", 1:11) := lapply(dates,
                                             function(x) {
                                               sum(x >= datdeb & x <= datfin)
                                       }),
       by = group
       ][,
         .(m_size = rowMeans(.SD)),
         by = group,
         .SDcols = paste0("size_date", 1:11)
       ][,
         .(m_size = mean(m_size)),
         by = group
       ]

基准

以下是上述四种方法的一些基准:原始 loop , map , over和 data.table .我在循环中遇到了一些问题，因此我包括了 foo <- foo2撤消更改。公平地说，我在其他三种方法中添加了类似的行，但不是必需的。 over出人意料地比预期的要快，但离真正的性能还很远。不可否认，我的data.table方法不是很有效。在 data.table 中肯定有更好的方法来做到这一点这应该快得多。

library(tidyverse)
library(lubridate)
library(dplyover) # https://github.com/TimTeaFan/dplyover
library(data.table)


dates <- yday(ceiling_date(dmy(sapply(1:11, function(x) paste0("01/", x, "/2009"))), "month") %m-% days(1))

foo <- data.frame(id = 1:1000000) %>%
  mutate(
    datdeb = round(runif(n(), 1, 365)),
    datfin = round(runif(n(), datdeb, 365)),
    etp = runif(n()),
    group = round(runif(n(), 1, 1000))
  )

foo_dt <- as.data.table(foo)
foo2 <- foo

test <- bench::mark(iterations = 50L, check = FALSE,
            
            "loop" = {

              for(i in 1:11){
                foo <- foo %>%
                  group_by(group) %>%
                  mutate(
                    "size_date{i}" := sum((.env$dates[i] >= datdeb & .env$dates[i] <= datfin))
                  )
              }

              foo %>%
                mutate(
                  m_size = rowMeans(across(starts_with("size_date")))
                ) %>%
                group_by(group) %>%
                summarise(
                  m_size = mean(m_size)
                )

              foo <- foo2
            },

            "map" = {

              foo2 %>%
                group_by(group) %>%
                mutate(m_size = rowMeans(
                  map_dfc(set_names(dates, dates),
                          ~ sum(.x >= datdeb & .x <= datfin))
                )
                ) %>%
                summarise(m_size = mean(m_size))
              foo <- foo2
            },

            "over" = {

              foo2 %>%
                group_by(group) %>%
                mutate(m_size = rowMeans(
                  over(dates,
                       ~ sum(.x >= datdeb & .x <= datfin),
                       .names = "size_date{x}")
                )
                ) %>%
                summarise(m_size = mean(m_size))
              foo <- foo2
            },
            
            "datatable" = {
              foo_dt[, paste0("size_date", 1:11) := lapply(dates, function(x) sum(x >= datdeb & x <= datfin)),
                         by = group
              ][,
                .(m_size = rowMeans(.SD)),
                by = group,
                .SDcols = paste0("size_date", 1:11)
              ][,
                .(m_size = mean(m_size)),
                by = group
              ]
              
              foo <- foo2
            })

#> Warning: Some expressions had a GC in every iteration; so filtering is disabled.
  
test
#> # A tibble: 4 x 6
#>   expression      min   median `itr/sec` mem_alloc `gc/sec`
#>   <bch:expr> <bch:tm> <bch:tm>     <dbl> <bch:byt>    <dbl>
#> 1 loop          1.45s    1.61s     0.627     727MB     3.95
#> 2 map        916.06ms 998.53ms     0.985     186MB     5.24
#> 3 over       649.82ms 701.65ms     1.37      186MB     4.29
#> 4 datatable  856.88ms 921.75ms     1.06      271MB     1.80

^{由 reprex package 创建于 2021-04-28 (v0.3.0)}