根据频率改变日期

编程问答 2022-05-16

问题描述

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

Each row is for one participant

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

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

我希望我试着把这说清楚，否则让我知道。我一直为此伤脑筋，因为我什至不知道这是否是最好的方法，因此非常感谢任何帮助。

非常感谢！

解决方法

这是一个基于 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
datedatedaterrtimeslots