Использование dplyr вместо lapply

Question

У меня есть dataframe с кучей start и end дат, и я перебираю список дат и вижу, сколько строк в моем фрейме данных «открыто» в течение этой даты в списке (т.е. дата начала произошла, но дата окончания не произошла) Термины памяти и скорости (фактический размер данных составляет 1,5 М строк).

      RollingDateRange <- seq(Sys.Date()-15, Sys.Date(), by="days")
      temp <- data.frame(RollingDateRange)

      dat <- data.frame(
        Order = c(1,1,1,2,2,2,3,3,3), 
        Code = c("Green","Yellow","Blue","Yellow","Yellow","Red","Purple","Green","Blue"),
        Start.Date = as.Date(c("2020-02-01","2020-02-02","2020-02-03","2020-02-01","2020-02-02","2020-02-03","2020-02-01","2020-02-02","2020-02-03")),
        End.Date = as.Date(c("2020-02-02","2020-02-08",NA,"2020-02-07","2020-02-06",NA,"2020-02-03","2020-02-08","2020-02-06")),
        Count = c(1,1,1,1,1,1,1,1,1),
        stringsAsFactors = FALSE)

      temp$Count <- lapply(temp$RollingDateRange, function(d){
        b <- dat[((dat$Start.Date <= d) & (dat$End.Date >= d)) | ((dat$Start.Date <= d) & (is.na(dat$End.Date))),]

        total <- sum(b$Count, na.rm = TRUE)
      })

Вывод:

> temp
   RollingDateRange Count
1        2020-01-25     0
2        2020-01-26     0
3        2020-01-27     0
4        2020-01-28     0
5        2020-01-29     0
6        2020-01-30     0
7        2020-01-31     0
8        2020-02-01     3
9        2020-02-02     6
10       2020-02-03     8
11       2020-02-04     7
12       2020-02-05     7
13       2020-02-06     7
14       2020-02-07     5
15       2020-02-08     4
16       2020-02-09     2

Answer 1

Рассмотрим vapply с векторной индексацией, которая может сократить обработку lapply. В частности, в отличие от lapply, который возвращает список, sapply, который по умолчанию возвращает вектор, vapply (аналогично sapply) возвращает указанный c вектор с определенным типом и длиной:

temp$Count <- vapply(temp$RollingDateRange, function(d){
   # LOGICAL INDEXING OF VECTOR (I.E., ONLY "COUNT" COLUMN)
   b <- with(dat, dat$Count[((Start.Date <= d) & (End.Date >= d)) | 
                            ((Start.Date <= d) & (is.na(End.Date)))])

   total <- sum(b, na.rm = TRUE)
}, numeric(1))

Ваш простой пример показывает заметную разницу во времени:

system.time( {
    temp$Count <- lapply(temp$RollingDateRange, function(d){
        # LOGICAL INDEXING OF DATA FRAME RETURNING ALL COLUMNS
        b <- dat[((dat$Start.Date <= d) & (dat$End.Date >= d)) | 
                 ((dat$Start.Date <= d) & (is.na(dat$End.Date))),]

        total <- sum(b$Count, na.rm = TRUE)
    })

})

#    user  system elapsed 
#   0.003   0.000   0.005 

system.time( {
    temp$Count <- vapply(temp$RollingDateRange, function(d){
        # LOGICAL INDEXING OF VECTOR (I.E., ONLY "COUNT" COLUMN)
        b <- with(dat, dat$Count[((Start.Date <= d) & (End.Date >= d)) | 
                                 ((Start.Date <= d) & (is.na(End.Date)))])

        total <- sum(b, na.rm = TRUE)
    }, numeric(1))
})

#    user  system elapsed 
#   0.001   0.000   0.001 

Сравнение других предлагаемых решений, которые могут различаться в зависимости от машины и версии пакета.

# @akrun's SOLUTION
system.time( {
  temp %>% 
    pull(RollingDateRange) %>%
    map_dfr(~ 
              dat %>%
              filter((Start.Date <= .x & End.Date >= .x)|
                     (Start.Date <= .x & is.na(End.Date))) %>% 
              pull(Count) %>% 
              sum %>% 
              tibble(RollingDateRange = .x, Count = .))
})

#    user  system elapsed 
#   0.029   0.000   0.029 


# @RonakShah's SOLUTION
system.time({
  temp %>%
    mutate(Count = purrr::map_dbl(RollingDateRange, ~ with(dat, 
                 sum(Count[(Start.Date <= .x & End.Date >= .x) | 
                           (Start.Date <= .x & is.na(End.Date))], na.rm = TRUE))))

})

#    user  system elapsed 
#   0.002   0.000   0.001 

Answer 2

Мы можем использовать map_dbl из purrr для вычисления суммы Count значений, которые удовлетворяют условию.

library(dplyr)

temp %>%
  mutate(Count = purrr::map_dbl(RollingDateRange, ~ with(dat, 
                 sum(Count[(Start.Date <= .x & End.Date >= .x) | 
                           (Start.Date <= .x & is.na(End.Date))], na.rm = TRUE))))

#   RollingDateRange Count
#1        2020-01-25     0
#2        2020-01-26     0
#3        2020-01-27     0
#4        2020-01-28     0
#5        2020-01-29     0
#6        2020-01-30     0
#7        2020-01-31     0
#8        2020-02-01     3
#9        2020-02-02     6
#10       2020-02-03     8
#11       2020-02-04     7
#12       2020-02-05     7
#13       2020-02-06     7
#14       2020-02-07     5
#15       2020-02-08     4
#16       2020-02-09     2

Answer 3

Если мы хотим приближения по кругу, используйте map

library(dplyr)
library(purrr)
temp %>% 
    pull(RollingDateRange) %>%
    map_dfr(~ 
          dat %>%
              filter((Start.Date <= .x & End.Date >= .x)|
               (Start.Date <= .x & is.na(End.Date))) %>% 
              pull(Count) %>% 
              sum %>% 
              tibble(RollingDateRange = .x, Count = .))
# A tibble: 16 x 2
#   RollingDateRange Count
#   <date>           <dbl>
# 1 2020-01-25           0
# 2 2020-01-26           0
# 3 2020-01-27           0
# 4 2020-01-28           0
# 5 2020-01-29           0
# 6 2020-01-30           0
# 7 2020-01-31           0
# 8 2020-02-01           3
# 9 2020-02-02           6
#10 2020-02-03           8
#11 2020-02-04           7
#12 2020-02-05           7
#13 2020-02-06           7
#14 2020-02-07           5
#15 2020-02-08           4
#16 2020-02-09           2