Поднабор дат с указанным днем ​​недели и выбор следующей даты, если день недели отсутствует

Question

Я могу найти много информации о SO относительно обработки поднабора дат для определенного дня недели (например, Получить даты определенного дня недели из года в R ).Тем не менее, я не могу найти ни одной, которая реализует запасную логику, которую я хотел бы.В частности, если данный день недели не существует на данной неделе, я хотел бы получить следующую доступную дату, исключая субботу и воскресенье.

Например, из вектора дат я хочу выбрать вседаты, соответствующие четвергам.Однако в те недели, когда четверги отсутствуют, я должен выбрать дату следующего рабочего дня.В приведенном ниже примере это следующий день, пятница.

library(lubridate)

# Create some dates
dates <- seq.Date(as.Date("2017-11-16"), as.Date("2017-11-24"), by = 1)

# Remove Thursday, November 23
dates <- dates[dates != as.Date("2017-11-23")]

# Get all Thursdays in dates
dates[wday(dates) == 5]
# [1] "2017-11-16"

# Desired Output:
# Because Thursday 2017-11-23 is missing in a week,
# we roll over and select Friday 2017-11-24 instead  
# [1] "2017-11-16" "2017-11-24"

Примечание 1. Для данной недели, когда четверг отсутствует, а пятница также отсутствует, я бы хотел перенести на понедельник.По сути, в течение недель, когда четверг не найден, возьмите следующую дату среди доступных дат.

Примечание 2: Я хотел бы достичь этого без каких-либо внешних зависимостей, кроме обычных пакетов R, таких как lubridate и т. Д.(например, нет зависимости от библиотеки c ++).

Я уверен, что мог бы написать что-то, чтобы делать то, что я хочу, но у меня возникают проблемы с поиском создания чего-то короткого и элегантного.

Answer 1

Я нарушаю ваше условие "нет внешних зависимостей", но, поскольку вы уже используете lubridate (это зависимость ;-)), я предоставлю вам решение, которое использует lead и lagот dplyr.Вы можете написать и написать их сами, хотя, глядя на источник, если это действительно сложное условие.

Что я делаю, так это выясняю, где находятся «пропуски» в последовательности, вычисляя вид выполненияразница дней.Как только мы узнаем, где находится пропуск, мы просто переходим к следующим данным в последовательности, что бы это ни было.Теперь вполне может быть, что это не пятница, а суббота.В этом случае вам придется выяснить, хотите ли вы по-прежнему хотеть следующую пятницу, даже если между ними четверг.

library(dplyr)

rollover_to_next <- function(dateseq, the_day = 5) {
  day_diffs <- lead(wday(dateseq) - lag(wday(dateseq))) %% 7
  skips <- which(day_diffs > 1) 

  sort(c(dateseq[wday(dateseq) == the_day], dateseq[skips + 1]))
}

dates <- seq.Date(as.Date("2017-11-16"), as.Date("2017-11-24"), by = 1)
dates <- dates[dates != as.Date("2017-11-23")]

rollover_to_next(dates)

Вывод:

[1] "2017-11-16" "2017-11-24"

Вывозможно, придется учитывать крайний случай, когда элемент idx + 1 не существует, но я оставлю это на ваше усмотрение.

Answer 2

Альтернатива с findInterval.

Создание последовательности дат ('tmp'), начиная с основного дня недели ('wd') в неделю min 'даты', до max 'date'.

Выбор дат, соответствующих целевому рабочему дню ('wds').

Выбор рабочих дней из 'date' ('date_1_5').

ИспользованиеfindInterval для перевода 'wds' к ближайшему доступному рабочему дню в 'date_1_5'.

f <- function(wd, dates){
  tmp <- seq(as.Date(paste(format(min(dates), "%Y-%W"), wd, sep = "-"),
                     format = "%Y-%W-%u"),
             max(dates), by = 1)

  wds <- tmp[as.integer(format(tmp, "%u")) == wd]

  dates_1_5 <- dates[as.integer(format(dates, "%u")) %in% 1:5]

  dates_1_5[findInterval(wds, dates_1_5, left.open = TRUE) + 1]
}

---

Некоторые примеры:

d <- seq.Date(as.Date("2017-11-16"), as.Date("2017-11-24"), by = 1)

dates <- d[d != as.Date("2017-11-23")]
f(wd = 4, dates)
# [1] "2017-11-16" "2017-11-24"

dates <- d[d != as.Date("2017-11-16")]
f(wd = 4, dates)
# [1] "2017-11-17" "2017-11-23"

dates <- d[!(d %in% as.Date(c("2017-11-16", "2017-11-17", "2017-11-21", "2017-11-23")))]
f(wd = 2, dates)
# [1] "2017-11-20" "2017-11-22"

---

Чуть более компактно при использовании data.table подвижного соединения:

library(data.table)

wd <- 2
# using 'dates' from above

d1 <- data.table(dates)
d2 <- data.table(dates = seq(as.Date(paste(format(min(dates), "%Y-%W"), wd, sep = "-"),
                                     format = "%Y-%W-%u"),
                             max(dates), by = 1))

d1[wday(dates) %in% 2:6][d2[wday(dates) == wd + 1],
                         on = "dates", .(x.dates), roll = -Inf]

...или неэквивалентное объединение:

d1[wday(dates) %in% 2:6][d2[wday(dates) == wd + 1],
                         on = .(dates >= dates), .(x.dates), mult = "first"]

При желании просто включите функцию, как указано выше.

Answer 3

может быть не самый элегантный способ, но я думаю, что он должен работать:)

library(lubridate)


dates <- seq.Date(as.Date("2017-11-16"), as.Date("2017-11-30"), by = 1) #your dates
dates <- dates[dates != as.Date("2017-11-23")] # thursday
dates <- dates[dates != as.Date("2017-11-24")] # friday
dates <- dates[dates != as.Date("2017-11-25")] # satureday
dates <- dates[dates != as.Date("2017-11-26")] # sunday
dates <- dates[dates != as.Date("2017-11-27")] # monday
dates <- dates[dates != as.Date("2017-11-28")] # tuesday
#dates <- dates[dates != as.Date("2017-11-29")] # wednesday

dates_shall_be <- seq.Date(min(dates)-wday(min(dates))+1, max(dates), by = 1) # create a shall-be list of days within your date-range
# min(dates)-wday(min(dates))+1 shiftback mindate to get missing thursdays in week one

thuesdays_shall = dates_shall_be[wday(dates_shall_be) == 5] # get all thuesdays that should be in there

for(i in 1:6) # run threw all possible followup days till wednesday next week 
{
  thuesdays_shall[!thuesdays_shall %in% dates] = thuesdays_shall[!thuesdays_shall %in% dates] + 1 # if date is not present in your data add another day to it
}

thuesdays_shall[!thuesdays_shall %in% dates] = NA # if date is still not present in the data after 6 shifts, this thursday + the whole followup days till next thursday are missing and NA is taken
thuesdays_shall