R - 如何使用矢量化操作加速 for 循环。实际问题

Question

我试图创建一个最小的示例，抱歉。 有没有办法加快这个过程？ 我的 procedures 表有 4M 行。我正在处理 15 个小时，它只填充了 150 万行。 可能是用mutate，我不知道。

library(tidyverse)
library(lubridate)

frequencies <- tibble(
  id = 1:3,
  date_hour_initial = c(
    dmy_hms('01/01/2020 13:00:00'),
    dmy_hms('01/01/2020 15:00:00'),
    dmy_hms('02/01/2020 20:00:00')
  ),
  date_hour_final= c(
    dmy_hms('01/01/2020 18:00:00'),
    dmy_hms('01/01/2020 22:00:00'),
    dmy_hms('03/01/2020 05:00:00')
  ),
  id_person = c("1", "2", "2"),
  type_service = c("1", "3", "4")
) %>%
  mutate(
    intervalo = interval(
      date_hour_initial,
      date_hour_final
    )
  )


procedures <- tibble(
  id = 1:3,
  date_hour = c(
    dmy_hms('01/01/2020 17:00:00'),
    dmy_hms('01/01/2020 22:00:00'),
    dmy_hms('03/01/2020 03:00:00')
  ),
  id_person = c("1", "1", "2")
)

procedures$type_service <- vector(
  "character",
  nrow(procedures)
  )


for(i in 1:nrow(procedures)) {

frequencies %>%
    filter(
      procedures$date_hour[i] %within% intervalo,
      id_person == procedures$id_person[i]
    ) %>% pull(type_service) %>% unique() -> response

  if(length(response) == 1){
    procedures$type_service[i] <- response
  } else {
    procedures$type_service[i] <- NA_character_
  }

}

Answer 1

这是一个不使用循环的 dplyr 解决方案：

library(tidyverse)

 left_join(frequencies, procedures, by = "id_person") %>%
  mutate(type_service = ifelse(date_hour %within% intervalo, type_service.x, NA)) %>% 
  select(id = id.y, date_hour, id_person, type_service) %>% 
  group_by(id) %>%
  arrange(type_service) %>%
  filter(!duplicated(id)) %>%
  ungroup() %>%
  arrange(id)
#> # A tibble: 3 x 4
#>      id date_hour           id_person type_service
#>   <int> <dttm>              <chr>     <chr>       
#> 1     1 2020-01-01 17:00:00 1         1           
#> 2     2 2020-01-01 22:00:00 1         NA          
#> 3     3 2020-01-03 03:00:00 2         4    

Answer 2

这是在data.table 中使用非等连接的选项：

procedures[, type_service := 
    frequencies[procedures, on=.(id_person, date_hour_initial<=date_hour, date_hour_final>=date_hour),
        by=.EACHI, if (length(x.type_service) == 1L) x.type_service]$V1
]

输出：

   id           date_hour id_person type_service
1:  1 2020-01-01 17:00:00         1            1
2:  2 2020-01-01 22:00:00         1         <NA>
3:  3 2020-01-03 03:00:00         2            4

数据：

library(data.table)
frequencies <- data.table(id = 1:3,
    date_hour_initial = as.POSIXct(c('01/01/2020 13:00:00','01/01/2020 15:00:00','02/01/2020 20:00:00'), format="%d/%m/%Y %T"),
    date_hour_final= as.POSIXct(c('01/01/2020 18:00:00','01/01/2020 22:00:00','03/01/2020 05:00:00'), format="%d/%m/%Y %T"),
    id_person = c("1", "2", "2"),
    type_service = c("1", "3", "4"))

procedures <- data.table(id = 1:3, 
    date_hour = as.POSIXct(c('01/01/2020 17:00:00','01/01/2020 22:00:00','03/01/2020 03:00:00'), format="%d/%m/%Y %T"),
    id_person = c("1", "1", "2"))

我的猜测是 4 mio 行大约需要一分钟？

Answer 3

这是一个使用模糊连接包的解决方案。第一步是按人员 ID 拆分频率和程序数据帧。这是把大问题分解成许多小问题。我没有添加任何错误检查以确保两个数据帧之间的 person_id 之间存在相应的匹配。

一旦数据帧被拆分，循环遍历每个人的 id 并使用left_fuzzy_join 函数来匹配过程中的“data_hour”和频率中的“间隔”

library(lubridate)
library(dplyr)
#divide and conquer
#split the data frame down to list by person_id
sfreq<-split(frequencies, frequencies$id_person)
sprocedures <- split(procedures, procedures$id_person)

library(fuzzyjoin)
#define function for the matching
matfun<-function(x, y){
  x %within% y
}

#define empty answer list
answer<-list()
#loop thru all of the split groups
for (id in names(sfreq)) {
  print(id)
  #perfrom a fuzzy join with data_hour in procedures and the interval in frequencies
  answer[[id]]<-fuzzy_left_join(sprocedures[[id]], sfreq[[id]],  by= c("date_hour" ="intervalo"), match_fun=matfun)
}

#Combine all of the subsets into the final answer
finalanswer<-bind_rows(answer)