`purrr` alternative to row-wise function that determines event date based on complex rule set

Question

I am working with a client that wants to provide an input spreadsheet with a text description of when certain events should occur in a given year. Each event (and there are at least 200 of them) is a separate row, containing a complex rule set about when it should occur, e.g., "the first Saturday before October 1st" or "the Friday closest to December 1st". There are also a few times when the event simply occurs on a particular date, but this is rare. However, the actual spreadsheet has about 15 columns that control the start dates of each event, so the logic I need to use to compute the start dates gets pretty in-depth.

I've come up with a way to compute the start dates using a function and a loop that iterates over each row of my data.frame, but I'm wondering whether there is a more efficient tidyverse or purrr solution to this problem. Is it possible (or advisable) to vectorize a solution to this problem?

This is my current (working) solution for the smallest, most compact example I could imagine. Can I make this more efficient, and readable for my more complex real-world input?

library(tidyverse)
library(lubridate)

# Bring in demo data that describes 3 events, and when they should each start.

demo <- structure(list(Event = c("Gala", "Celebration", "Wrap-up"), date_start
= structure(c(18871, NA, NA), class = "Date"), weekday_near = c(NA,
"Saturday", "Friday" ), near_description = c(NA, "before", "closest to"),
near_date = structure(c(NA, 18901, 18962), class = "Date")), row.names = c(NA,
-3L), class = c("tbl_df", "tbl", "data.frame"))

This is what the demo data look like:

Event       date_start weekday_near near_description near_date 
Gala        2021-09-01 NA           NA               NA        
Celebration NA         Saturday     before           2021-10-01
Wrap-up     NA         Friday       closest to       2021-12-01

Now, determine start dates for each event - the Gala, the Celebration, and the Wrap-up.

# Create a tibble that contains all possible dates for these events this year.

datedb <- tibble(date = seq(make_date(2021, 9, 1), make_date(2021, 12, 31), by = 1),
                 wday = wday(date, label = TRUE, abbr = FALSE))


# Write function meant to determine event date for each row of the dataframe.

determine_date <- function(df){
  
  # define variables that are easier to read
  # this part makes me squeamish - 
  # there's gotta be a better way to do this with the tidyverse
  event_date_exact <- df[["date_start"]]
  event_near_wday <- df[["weekday_near"]]
  event_near_desc <- df[["near_description"]]
  event_near_date <- df[["near_date"]]
  
  # Event date - if there is an exact date for the event, choose it as the event date.
  if (!is.na(event_date_exact)) {
    event_date <- event_date_exact
  
  # Otherwise, if the date is dependent on another date, figure out when it should be:
  } else {
    event_date_vec <- datedb %>% filter(wday == event_near_wday) %>% pull(date)
    event_date <- 
      case_when(
        # If you're looking for the closest weekday to a particular date:
        event_near_desc == "closest to" ~ event_date_vec[which(abs(event_date_vec - event_near_date) == 
                         min(abs(event_date_vec - event_near_date), na.rm = TRUE))],
        # If you're looking for the first weekday before that weekday
        event_near_desc == "before" ~ rev(event_date_vec[which(event_date_vec - event_near_date < 0)])[1],
        # If neither of these worked, output NA to check why 
        TRUE ~ NA_Date_
      )
       }
}

# create empty vector to store results
start_dates <- lubridate::ymd()

for (i in 1:nrow(demo)) {
  start_dates[i] <- determine_date(demo[i,])
}

# add start dates back to original demo dataframe
demo$start_date <- start_dates

Desired output:

Note new start_date column

demo

Event       date_start weekday_near near_description near_date    start_date
Gala        2021-09-01 NA           NA               NA           2021-09-01
Celebration NA         Saturday     before           2021-10-01   2021-09-25
Wrap-up     NA         Friday       closest to       2021-12-01   2021-12-03

user_9834962 · Answer

If you would like to vectorize a function, under the hood it is really just making a call to mapply. So, if you want to use purrr style coding, you maybe just want to modify your function arguments as follows:

The setup:

library(tidyverse)
library(lubridate)
#> 
#> Attaching package: 'lubridate'
#> The following objects are masked from 'package:base':
#> 
#>     date, intersect, setdiff, union

# Bring in demo data that describes 3 events, and when they should each start.

demo <- structure(list(Event = c("Gala", "Celebration", "Wrap-up"), date_start
                       = structure(c(18871, NA, NA), class = "Date"), weekday_near = c(NA,
                                                                                       "Saturday", "Friday" ), near_description = c(NA, "before", "closest to"),
                       near_date = structure(c(NA, 18901, 18962), class = "Date")), row.names = c(NA,
                                                                                                  -3L), class = c("tbl_df", "tbl", "data.frame"))

datedb <- tibble(date = seq(make_date(2021, 9, 1), make_date(2021, 12, 31), by = 1),
                 wday = wday(date, label = TRUE, abbr = FALSE))

Here is refactored version of your function.

Using case_when as opposed to a switch statement is really up to you. I opted to use switch since this function is intended to be called within a pmap call, i.e. we expect it to only check a single value.

#write a function that expects 4 input values
#vectorize/pmap over each.
determine_date2 <- function(date_start, weekday_near, near_desc, near_date){
  event_vec <- datedb %>% filter(wday == weekday_near) %>% pull(date)
  event_date <-
    if(!is.na(date_start)){
      date_start
    } else if(!is.na(near_desc)){
      switch(
        near_desc,
        `closest to` = event_vec[which(abs(event_vec - near_date) == min(abs(event_vec - near_date), na.rm = TRUE))],
        before = rev(event_vec[which(event_vec - near_date < 0)])[1],
        NA_Date_
      )
    } else {
      NA_Date_
    }
  event_date
}

I actually just discovered that there isn't really a pmap_date variant, but what I produced below should suffice as a substitute.

pmap_date <- function(.l, .f, ...){
  res <- pmap(.l, .f, ...)
  check_res <- map_lgl(res, ~is.Date(.x)&&is_scalar_vector(.x))
  if(!all(check_res)){
    rlang::abort(glue::glue("all results must return a scalar date. offending entries: ",glue::glue_collapse("{!which(check_res)}", sep = ", ")))
  }
  
  return(reduce(res, c))
}

Now we should be able to use pmap_date inside a mutate function

demo %>%
  mutate(
    start_dates = pmap_date(list(date_start, weekday_near, near_description, near_date), determine_date2)
  )
#> # A tibble: 3 x 6
#>   Event       date_start weekday_near near_description near_date  start_dates
#>                                             
#> 1 Gala        2021-09-01                       NA         2021-09-01 
#> 2 Celebration NA         Saturday     before           2021-10-01 2021-09-25 
#> 3 Wrap-up     NA         Friday       closest to       2021-12-01 2021-12-03

If you prefer, you can make your "vectorized" wrapper function as if you called the Vectorize function yourself:

v_determine_date2 <- function(date_start, weekday_near, near_desc, near_date) pmap_date(list(date_start, weekday_near, near_desc, near_date), determine_date2)

demo %>%
  mutate(
    start_dates = v_determine_date2(date_start, weekday_near, near_description, near_date)
  )
#> # A tibble: 3 x 6
#>   Event       date_start weekday_near near_description near_date  start_dates
#>                                             
#> 1 Gala        2021-09-01                       NA         2021-09-01 
#> 2 Celebration NA         Saturday     before           2021-10-01 2021-09-25 
#> 3 Wrap-up     NA         Friday       closest to       2021-12-01 2021-12-03

^{Created on 2021-05-11 by the reprex package (v1.0.0)}

`purrr` alternative to row-wise function that determines event date based on complex rule set

Desired output:

1 Answers