根据频率移动日期

Question

我有点困惑。我想为我的数据集中的每个参与者安排特定的日期空档以进行预约。我有一个日期范围，从 14 天到流感爆发，再到流感疫苗。因此，如果流感疫苗接种时间安排在 2021 年 4 月 29 日，则预约可以在 2021 年 4 月 15 日至 4 月 28 日期间进行。流感疫苗接种日期当然因参与者而异。每个日期，每个约会有最大参与者数量（假设每个日期有 8 名参与者）。我设法（在你们的帮助下）创建了一个数据框，其中包含每个参与者可以预约的所有日期：

Each row is for one participant

我需要从这个数据框中检查第一个可能的日期是否出现了 8 次或更少（插槽尚未填充），将该日期放在新列中。然后，当该日期的 8 槽已满时，继续下一个日期，直到再次达到最大值 8，等等

结果应该是一个额外的列，其中包含每个参与者的约会日期。

我希望我已尽力使这一点足够清楚，否则请告诉我。我一直在为此伤脑筋，因为我什至不知道这是否是最好的方法，所以非常感谢任何帮助。

非常感谢！

Answer 1

这是一个基于 tidyverse 和 lubridate 的可能解决方案。

首先，包含已预订约会的小标题。开头是空的。

library(tidyverse)
library(lubridate)

bookedAppointments <- tibble(
                        AppointmentDate=structure(NA_real_, class="Date"),
                        ParticipantID=numeric()
                      )
bookedAppointments
# A tibble: 0 x 2
# … with 2 variables: AppointmentDate <date>, ParticipantID <dbl>

现在，一个函数可以查找在可预约的最后可能日期之前的日期。

findAvailableSlots <- function(lastDate) {
  bookedSlots <- bookedAppointments %>%
                      filter(AppointmentDate %within% interval(lastDate - days(14), lastDate)) %>%
                      group_by(AppointmentDate) %>%
                      summarise(BookedSlots=n())
  availableSlots <- tibble(
                      AppointmentDate=lastDate - days(0:13),
                      MaximumSlots=8
                    ) %>% 
                    filter(AppointmentDate - today() > -1) %>% 
                    left_join(bookedSlots, by="AppointmentDate") %>% 
                    replace_na(list(BookedSlots=0)) %>% 
                    mutate(AvailableSlots=MaximumSlots - BookedSlots) %>% 
                    filter(AvailableSlots > 0)
  availableSlots
}

测试一下。请注意，在撰写本文时，01Apr2021 还不到 14 天...

possibles <- findAvailableSlots(dmy("01Apr2021"))
possibles
# A tibble: 4 x 4
  AppointmentDate MaximumSlots BookedSlots AvailableSlots
  <date>                 <dbl>       <dbl>          <dbl>
1 2021-04-01                 8           0              8
2 2021-03-31                 8           0              8
3 2021-03-30                 8           0              8
4 2021-03-29                 8           0              8

预订时段。为简单起见，只需取最后一个可用日期。

bookedAppointments <- bookedAppointments %>% 
                          add_row(
                            AppointmentDate=possibles %>% 
                                              pull(AppointmentDate) %>% 
                                              head(1), 
                            ParticipantID=1
                          )
bookedAppointments
# A tibble: 1 x 2
  AppointmentDate ParticipantID
  <date>                  <dbl>
1 2021-04-01                  1

在 2021 年 4 月 1 日填满所有空缺

for (i in 2:8) 
  bookedAppointments <- bookedAppointments %>% 
    add_row(AppointmentDate=dmy("01Apr2021"), ParticipantID=i)

现在再预约

possibles <- findAvailableSlots(dmy("01Apr2021"))
bookedAppointments <- bookedAppointments %>% 
  add_row(
    AppointmentDate=possibles %>% pull(AppointmentDate) %>% head(1), 
    ParticipantID=99
  )
# A tibble: 9 x 2
  AppointmentDate ParticipantID
  <date>                  <dbl>
1 2021-04-01                  1
2 2021-04-01                  2
3 2021-04-01                  3
4 2021-04-01                  4
5 2021-04-01                  5
6 2021-04-01                  6
7 2021-04-01                  7
8 2021-04-01                  8
9 2021-03-31                 99

根据频率移动日期

Shifting dates based on frequency

r

date

timeslots