基于频率的日期转换

Question

我有一个小难题。我希望为我的数据集中的每个参与者安排特定的日期时段，以便获得预约。我有一个日期范围，从14天到流感爆发到流感疫苗接种。因此，如果流感疫苗注射被安排在2021年4月29日，那么预约可以从2021年4月15日到4月28日。当然，流感疫苗的注射日期因参与者而异。每个日期，每个约会的参与者数量是最多的(假设每个日期有8个参与者)。我设法(在你们的帮助下)创建了一个数据框架，其中包含每个参与者可能预约的所有日期：

Each row is for one participant

我需要从这个数据框中检查第一个可能的日期是否出现了8次或更少(空位还没有填满)，将该日期放在一个新列中。然后，当该日期的8个空位被填满时，继续到下一个日期，直到再次达到最大值8，依此类推

然后，结果应该是附加的列，其中包含每个参与者的任命日期。

我希望我已经说得足够清楚了，但还是要让我知道。我一直在为此绞尽脑汁，因为我甚至不知道这是不是最好的方法，所以我非常感谢任何帮助。

非常感谢!

Answer 1

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

首先，包含已经预订的约会的tibble。它一开始就是空的。

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
}

测试它。请注意，在撰写本文时，2021年4月1日还不到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月01日的所有插槽

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