R - как ускорить за l oop с векторизованными операциями. Практическая проблема

Question

Я пытался создать минимальный пример, извините. Есть ли способ ускорить процесс? Моя таблица procedures имеет 4M строк. Я обрабатываю в течение 15 часов, и он заполнен только 1,5 млн строк. Может быть, используя мутацию, я не знаю.

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

data:

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 миллионов строк?

Answer 3

Вот решение с использованием пакета нечеткого соединения. Первый шаг - это разделение данных и частоты кадров по идентификатору лица. Это делит большую проблему на множество мелких проблем. Я не добавил никакой проверки ошибок, чтобы убедиться, что между person_id между двумя фреймами данных есть соответствующее совпадение.

После разделения фреймов данных l oop через каждый идентификатор человека с использованием 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)