Как я могу определить функцию в r, чтобы отмечать праздники по неделям?

Question

У меня есть поле дат, обозначающее конец недели. Я пытаюсь создать новое поле, используя функцию, которая отмечает (1 или 0), включает ли эта неделя какой-либо из 6 выходных, указанных с помощью пакета timeDate. Я получаю следующую ошибку: «Ошибка при переносе: сравнение (3) возможно только для атомов c и типов списков» - как я могу решить?

Функция должна занимать конец недели дата (x) в формате гггг-мм-дд (например, 2017-01-01) и год этой даты (у) в формате гггг (например, 2017).

library(lubridate)
library(timeDate)

Date = as.Date(c("2017-01-01", "2017-01-08", "2017-01-15", "2017-01-22", "2017-06-04", "2017-07-09", "2017-07-16"))
Year = year(Date)
Holiday.During.Week = as.Date(c("2017-01-01", NA, NA, NA, "2017-05-29", "2017-07-04", NA))
Desired.Output = c(1,0,0,0,1,1,0)
data <- data.frame(Date, Year, Holiday.During.Week, Desired.Output)
data

holiday.function = function(x, y) {
  return(
    as.numeric(
      (USNewYearsDay(y) < x & USNewYearsDay(y) > (x - 7)) +
      (USMemorialDay(y) < x & USMemorialDay(y) > (x - 7)) +
      (USIndependenceDay(y) < x & USIndependenceDay(y) > (x - 7)) +
      (USLaborDay(y) < x & USLaborDay(y) > (x - 7)) +
      (USThanksgivingDay(y) < x & USThanksgivingDay(y) > (x - 7)) +
      (USChristmasDay(y) < x & USChristmasDay(y) > (x - 7))
    )
  )
}
data$Holiday.Flag = holiday.function(data$Date, data$Year)

Редактировать Спасибо Иану Кэмпбеллу за то, что он работал без предоставленных данных. Я обновил код для включения образца фрейма данных и библиотек

Answer 1

Звучит так, как будто у вас много данных, поэтому давайте используем data.table. Я сгенерировал случайную выборку в 10 000 000 дней в конце этого ответа.

Сначала мы создадим таблицу данных всех праздников между 1900 и 2020 годами.

library(timeDate)
library(data.table)
library(lubridate)
HolidayTable <- rbindlist(lapply(1900:2020,function(y){data.frame(Year = y, Holiday = as.Date(c(USNewYearsDay(y),USMemorialDay(y),USIndependenceDay(y),USLaborDay(y),USThanksgivingDay(y),USChristmasDay(y))))}))

Нам нужно сделать копию даты праздника, потому что data.table Скользящие объединения объединяют столбец, к которому вы присоединяетесь.

setDT(test.data)
setDT(HolidayTable)
HolidayTable[,Date := Holiday]
test.data[, Year := year(Date)]

Теперь мы выполняем скользящее объединение с roll = 6, чтобы присоединиться к датам, которые не более 6 дней в будущем. Затем мы можем создать желаемый вывод с логическим сравнением, приведенным к целому числу, с помощью +.

HolidayTable[test.data, on = c("Year","Date"), roll = 6][
  ,.(Index,Year,Date,Holiday,HolidayPresent = +(!is.na(Holiday)))]

#             Index Year       Date    Holiday HolidayPresent
#       1:        1 2018 2018-04-21       <NA>              0
#       2:        2 2017 2017-09-30       <NA>              0
#       3:        3 2017 2017-01-07 2017-01-01              1
#       4:        4 2017 2017-08-26       <NA>              0
#       5:        5 2018 2018-09-01       <NA>              0
#      ---                                                   
# 9999996:  9999996 2017 2017-06-24       <NA>              0
# 9999997:  9999997 2018 2018-03-17       <NA>              0
# 9999998:  9999998 2018 2018-07-07 2018-07-04              1
# 9999999:  9999999 2018 2018-01-13       <NA>              0
#10000000: 10000000 2017 2017-08-12       <NA>              0

10000000 строк, выполненных всего за 2,5 секунды на моем ноутбуке.

system.time({HolidayTable[test.data, on = c("Year","Date"), roll = 6][,.(Index,Year,Date,Holiday,HolidayPresent = +(!is.na(Holiday)))]})
   user  system elapsed 
  2.045   0.426   2.484 

Данные

library(zoo)
WeekEndingDate2017 <- zoo::as.Date(Reduce(function(x,y){x + days(7)},1:51,as.Date("2017-01-07","%Y-%m-%d"), accumulate = TRUE))
WeekEndingDate2018 <- zoo::as.Date(Reduce(function(x,y){x + days(7)},1:51,as.Date("2018-01-06","%Y-%m-%d"), accumulate = TRUE))
set.seed(1)
test.data <- data.frame(Index = 1:10000000, Date = sample(c(WeekEndingDate2017,WeekEndingDate2018),size = 10000000, replace = TRUE))