Shifting dates based on frequency

Question

I have a bit of a puzzle. I want to make certain date slots for every participant in my dataset to get an appointment. I have a date range that goes from 14 days until a flu shot up until the flu shot. So if the flu shot is schedule for the 29th of April 2021, the appointment can take place from the 15th of April until the 28th of April 2021. The flu shot dates of course vary per participant. Per date, there is a maximum amount of participants per appointment (let's say 8 participants per date). I managed (with help from you guys) to create a dataframe with all the dates that an appointment is possible per participant:

Each row is for one participant

What I need from this dataframe is to check that if the first possible date occurs 8 times or less (slot is not filled yet), place that date in a new column. Then, when the slot of 8 for that date is filled, continue to the next date until that reaches the maximum of 8 again, etc etc

The outcome should then be an additional column with the date of the appointment for every participant.

I hope i tried to make this clear enough but otherwise let me know. I have been breaking my brain over this because I don't even know if this is the best way to do it so ANY help is greatly appreciated.

Thanks a lot!

score 0 · Accepted Answer · answered Mar 29 '21 at 13:47

Here's a possible solution based on the tidyverse and lubridate.

First, a tibble containing appointments that have already been booked. It's empty to start with.

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>

Now, a function to find dates before the last possible date at which appointments are available.

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
}

Test it. Note that at the time of writing, 01Apr2021 is less than 14 days in the future...

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

Book a slot. For simplicity, simply take the last available date.

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

Fill all slots on 01Apr2021

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

Now book another appointment

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

To take the first available date, either sort `availableSlots` in `findAvalaibleSlots` or use `tail()` rather than `head()` when updating `bookedAppointments`. — Limey, Mar 29 '21 at 14:00

Shifting dates based on frequency

1 Answers1