Удалить вложенный для l oop с условием if в R

Question

Я пытаюсь оптимизировать мой код R, удаляя вложенные для l oop с векторизацией. Мой вложенный для l oop включает rbind в зависимости от условия if. Вложенный для l oop код работает, однако, при запуске векторизованного кода с использованием rbind не заполняет новый фрейм данных.

Для фона у меня есть два dataframes-'ip ',' ip_error '. Фрейм данных 'ip' с измерением '469 5'. Фрейм данных 'ip_error' имеет размерность '9 11'. После сравнения двух фреймов данных в указанных столбцах c начала и конца задачи с началом и концом сеанса мои выходные данные представляют собой выбранные строки из фрейма данных 'ip'.

Это мой рабочий код с вложенным для l oop

for(j in 1:length(ip$RUID_KEY)){
 for(i in 1:length(ip_error$RUID_KEY)){
  if(isTRUE(ip_error$RUID_KEY[i]==ip$RUID_KEY[j]&&ip_error$TASK_START[i]>=ip$sess_start[j]&&ip_error$TASK_END[i]<ip$sess_end[j])){
    ev_ip_error<-rbind(ev_ip_error,ip[j,])
  }
}
}

Мой код с векторизацией выглядит следующим образом, который не работает

al<-1:length(ip$RUID_KEY)
bl<-1:length(ip_error$RUID_KEY)

f<- function(i,j){
  if(isTRUE(ip_error$RUID_KEY[i]==ip$RUID_KEY[j]&&ip_error$TASK_START[i]>=ip$sess_start[j]&&ip_error$TASK_END[i]<ip$sess_end[j])){
    ev_ip_error<-rbind(ev_ip_error,ip[j,])
  }
}

mapply(f,al,bl)

Вот пример моих фреймов данных, где для строк 1 и 3 в 'ip_error' удовлетворяет условию if

No.     RUID_KEY    sess_start  sess_end
1   101 2018-12-01 22:48:18.827 2018-12-01 22:55:18.900
2   201 2018-12-01 13:10:20.100 2018-12-01 13:50:10.000
3   201 2018-12-12 11:10:10.100 2018-12-12 11:20:00.100

фрейм данных 'ip_error'

No. RUID_KEY    TASK_START  TASK_END    TASK_NAME
1   101 2018-12-01 22:50:18.827 2018-12-01 22:50:18.827 ERROR1
2   101 2018-12-01 15:10:20.100 2018-12-01 15:10:20.100 ERROR2
3   201 2018-12-01 13:40:10.100 2018-12-01 13:40:10.100 ERROR1

ev_ip_error<-data.frame(matrix(ncol=5,nrow=0))
x<-c("RUID_KEY", "sess_start", "sess_end")
colnames(ev_ip_error)<-x

Answer 1

Я бы предложил использовать пакет data.table и использовать внутреннее соединение с условиями неравенства. Это быстро и просто использовать, как только вы привыкнете к синтаксису.

Вот настройка:

Шаг 1: создайте пример набора данных:

ip <- data.table::data.table(
  ruid_key = c(101, 201, 201),
  sess_start = as.POSIXct(c(
    '2018-12-01 22:48:18.827',
    '2018-12-01 13:10:20.100',
    '2018-12-12 11:10:10.100'
    )),
  sess_end = as.POSIXct(c(
    '2018-12-01 22:55:18.900',
    '2018-12-01 13:50:10.000',
    '2018-12-12 11:20:00.100')))


ip_error <- data.table::data.table(
  ruid_key = c(101,101,201),
  task_start = as.POSIXct(c(
    '2018-12-01 22:50:18.827',
    '2018-12-01 15:10:20.100',
    '2018-12-01 13:40:10.100'
  )),
  task_end = as.POSIXct(c(
    '2018-12-01 22:50:18.827',
    '2018-12-01 15:10:20.100',
    '2018-12-01 13:40:10.100'
  ))
)

Шаг 2. сделать внутреннее объединение, добавить неравенства непосредственно к условию on в соединении

ip[ip_error, 
   on = c('ruid_key', 'sess_start<=task_start', 'sess_end>task_end'),
   .(sess_start = x.sess_start, sess_end = x.sess_end),
   nomatch = NULL
   ]

Answer 2

Рассмотрим merge из двух фреймов данных, а затем subset по времени:

ev_ip_error <- subset(merge(ip, ip_error, by="RUID_KEY", suffixes=c("", "_")),
                      TASK_START >= sess_start & TASK_END < sess_end)[names(ip)]

ev_ip_error

#   No. RUID_KEY          sess_start            sess_end
# 1   1      101 2018-12-01 22:48:18 2018-12-01 22:55:18
# 3   2      201 2018-12-01 13:10:20 2018-12-01 13:50:10

Что эквивалентно нескорректированным for l oop и исправленный подход mapply (или Map), который создает список фреймов данных с expand.grid (для всех возможных комбинаций между значениями RUID_KEY). Поскольку решения семейства применений не сохраняют переменные области действия, вам необходимо построить объект вне его l oop или вызвать rbind один раз вне l oop. Это было бы более эффективно, чем for l oop. См. Ниже:

prms <- expand.grid(al = 1:length(ip$RUID_KEY),
                    bl = 1:length(ip_error$RUID_KEY))

f <- function(i,j){
  if(isTRUE(ip_error$RUID_KEY[i]==ip$RUID_KEY[j] && ip_error$TASK_START[i]>=ip$sess_start[j] && ip_error$TASK_END[i]<ip$sess_end[j])){
     return(ip[j,])
  }
}

df_list <- mapply(f, prms$al, prms$bl, SIMPLIFY = FALSE)
#df_list <- Map(f, prms$al, prms$bl)   # EQUIVALENT

ev_ip_error <- do.call(rbind, df_list)

См. Сравнение всех трех подходов в Онлайн-демонстрация .