Смешайте значения из двух информационных фреймов в функции преобразования с условиями - PullRequest
Новая
       39

Смешайте значения из двух информационных фреймов в функции преобразования с условиями

2 голосов
/ 03 марта 2020

У меня есть 2 кадра данных с этими формами: 

DF1 <- data.frame(
  idCarte = c('a', 'a', 'b', 'b', 'b'),
  idPack = c('1', '2', '2', '3', '3'),
  timeIn = c('10:00:02', '12:00:50', '11:40:00', '12:10:35', '15:15:00'),
  timeOut = c('12:00:00', '14:00:00', '11:50:00', '15:00:00', '16:00:00')
)

DF1
idCarte  idPack      timeIn   timeOut
      a      1     10:00:02  12:00:00
      a      2     12:00:50  14:00:00
      b      2     11:40:00  11:50:00
      b      3     12:10:35  15:00:00
      b      3     15:15:35  16:00:00

DF2 <- data.frame(
  idCarte = c('a', 'a', 'b', 'b', 'b'),
  idPack = c('1', '2', '3', '3', '2'),
  timeBetween = c('11:00:02', '13:00:50', '14:10:35', '15:20:00', '18:00:00')
)

DF2
idCarte  idPack    timeBetween
      a       1       11:00:02
      a       2       13:00:50
      b       3       14:10:35
      b       3       15:20:00
      b       2       18:00:00

И я хочу получить этот результат 

idCarte  idPack      timeIn   timeOut  timeBetween
      a      1     10:00:02  12:00:00     11:00:02 
      a      2     12:00:50  14:00:00     13:00:50
      b      2     11:40:00  11:50:00           NA
      b      3     12:10:35  15:00:00     14:10:35
      b      3     15:15:00  16:00:00     15:20:00

Я могу сделать это с помощью для l oop как это, но это действительно медленно 

for (i in 1:nrow(DF1)) {
  timeBetweenLocal <- DF2 %>%
    filter(
      idCarte == DF1[i,"idCarte"] &
      idPack == DF1[i,"idPack"] &
      timeBetween >= DF1[i,"timeIn"] &
      timeBetween <= DF1[i,"timeOut"]
    )
  if (nrow(timeBetweenLocal) > 0) {
    DF1[i, "timeBetween"] <- timeBetweenLocal[1, "timeBetween"]
  } else {
    DF1[i, "timeBetween"] <- NA
  }
}

Я хочу сделать это векторизованным способом с dplyr :: mutate до go быстрее, но это немного сложно. 

DF1 %>%
  mutate (
    timeBetween = ifelse (
      nrow(DF2 %>%
             dplyr::filter(
               idCarte == .$idCarte &
               idPack == .$idPack &
               timeBetween >=.$timeIn &
               timeBetween <= .$timeOut
             )
      ) > 0,
      DF2 %>%
        dplyr::filter(
          idCarte == .$idCarte &
          idPack == .$idPack &
          timeBetween >=.$timeIn &
          timeBetween <= .$timeOut
        ),
      NA
    )
  )

# Error : Result must have length 4, not 0

Моя проблема в том, что мне нужно проверить время сопоставления, потому что есть несколько idCarte, idPack У кого-нибудь есть идея векторизовать этот алгоритм? Спасибо

Ответы [ 3 ]

3 голосов
/ 03 марта 2020

Вот решение с left_join и case_when. left_join может привести к дублированию строк, вы можете использовать na.omit или filter(!duplicated(...)), если хотите удалить некоторые дубликаты. 

library(lubridate)
library(dplyr)

# Yours data
DF1 <- data.frame(stringsAsFactors = F,
  idCarte = c('a', 'a', 'b', 'b', 'b'),
  idPack = c('1', '2', '2', '3', '3'),
  timeIn = c('10:00:02', '12:00:50', '11:40:00', '12:10:35', '15:15:00'),
  timeOut = c('12:00:00', '14:00:00', '11:50:00', '15:00:00', '16:00:00')
)


DF2 <- data.frame(stringsAsFactors = F,
  idCarte = c('a', 'a', 'b', 'b', 'b'),
  idPack = c('1', '2', '3', '3', '2'),
  timeBetween = c('11:00:02', '13:00:50', '14:10:35', '15:20:00', '18:00:00')
)


# Solution with left_join lead to duplicate rows

df = left_join(x = DF1, y = DF2, by = c("idCarte"="idCarte","idPack"="idPack")) %>% 
  mutate(timeBetween = case_when(hms(timeBetween)>= hms(timeIn) & hms(timeBetween)<= hms(timeOut) ~ timeBetween,
                                  T ~ NA_character_
                                  )
         )

# The output
# 
#   idCarte idPack   timeIn  timeOut timeBetween
# 1       a      1 10:00:02 12:00:00    11:00:02
# 2       a      2 12:00:50 14:00:00    13:00:50
# 3       b      2 11:40:00 11:50:00        <NA>
# 4       b      3 12:10:35 15:00:00    14:10:35
# 5       b      3 12:10:35 15:00:00        <NA>
# 6       b      3 15:15:00 16:00:00        <NA>
# 7       b      3 15:15:00 16:00:00    15:20:00
1 голос
/ 03 марта 2020

Вот решение dplyr, упомянутое в комментариях: 

library(dplyr)
library(lubridate)

DF1 %>% 
  left_join(DF2) %>% 
  mutate(timeIn = as_datetime(hms(timeIn)),
         timeOut = as_datetime(hms(timeOut)),
         timeBetween = as_datetime(hms(timeBetween))) %>% 
  filter(timeBetween > timeIn & timeBetween < timeOut | is.na(timeBetween))
#Joining, by = c("idCarte", "idPack")
#  idCarte idPack              timeIn             timeOut         timeBetween
#1       a      1 1970-01-01 10:00:02 1970-01-01 12:00:00 1970-01-01 11:00:02
#2       a      2 1970-01-01 12:00:50 1970-01-01 14:00:00 1970-01-01 13:00:50
#3       b      2 1970-01-01 11:40:00 1970-01-01 11:50:00                <NA>
#4       b      3 1970-01-01 12:10:35 1970-01-01 15:00:00 1970-01-01 14:10:35
0 голосов
/ 03 марта 2020

Чтобы проверить совпадения в первых двух столбцах, мы можем использовать outer. Для нескольких совпадений мы хотим проверить, находится ли время между timeIn и timeOut. Поэтому выгодно преобразовать времена в POSIXct формат. 

DF1[3:4] <- lapply(DF1[3:4], as.POSIXct, format="%H:%M:%S")
DF2[3] <- as.POSIXct(DF2[[3]], format="%H:%M:%S")

. Для outer мы кодируем вспомогательную функцию. 

rp <- function(x) Reduce(paste, x)

Теперь мы создаем список w с индексами, которые из первых двух столбцов обоих фреймов данных совпадают, используя outer. 

w <- apply(outer(rp(DF1[1:2]), rp(DF2[1:2]), `==`), 1, which)

Посмотрите на lapply(... в следующей строке; мы называем каждую запись списка w, бросаем либо NA, если она пуста, либо выбираем ту запись, которая попадает в интервал времени DF1. Пустые элементы мы снова превращаем в NA. do.call("c", ...) объединяет результирующий список в вектор, который мы можем cbind до DF1. 

res <- cbind(DF1, timeBetween=do.call("c", lapply(seq(w), function(i) {
  r <- DF2[w[[i]], 3]
  if (length(r) == 0) r <- NA
  else r <- r[r > DF1[i, 3] & r < DF1[i, 4]]
  if (length(r) == 0) r <- NA
  return(r)
  })))

При желании мы можем вырезать даты в конце. 

res[3:5] <- lapply(res[3:5], strftime, format="%H:%M:%S")

Результат 

res    
#   idCarte idPack   timeIn  timeOut timeBetween
# 1       a      1 10:00:02 12:00:00    11:00:02
# 2       a      2 12:00:50 14:00:00    13:00:50
# 3       b      2 11:40:00 11:50:00        <NA>
# 4       b      3 12:10:35 15:00:00    14:10:35
# 5       b      3 15:15:00 16:00:00    15:20:00
...