R/meetr.R

In artichaud1/meetr: Easily find common openings in agendas, taking timezones into account.

library(lubridate)
library(purrr)
library(stringr)

#' Given a sequence of interval specification (in 'HH:MM to HH:MM' format),
#' return a function that will take a start date and an end date and return all
#' intervals within those dates that correspond to the interval specification.
#' @param keep_weekdays Character vector of weekdays (e.g. 'Monday', 'Tuesday', etc.).
#' @param ... Character vector where each element has format 'HH:MM to HH:MM'
#' @importFrom purrr map flatten map2
#' @importFrom stringr str_split
#' @importFrom magrittr "%>%"
select_days <- function(keep_weekdays, ...){

  args <- list(...)

  # If no hours specified, assume whole day is selected
  if(length(args) == 0){
    args <- '00:00 to 24:00'
  }

  splitted <- str_split(args, 'to')
  start_hm <- map(splitted, 1)
  end_hm <- map(splitted, 2)

  res <- function(start_day, end_day){
    all_days <- seq(start_day, end_day, by = 'day')
    kept_days <- all_days[weekdays(all_days) %in% keep_weekdays]

    map(kept_days,
        function(d){
          map2(hm(start_hm), hm(end_hm),
               ~ interval(d + .x, d + .y))
        }
    ) %>%
      flatten()
  }

  structure(res, class = append('dayselector', class(res)))

}

#' @export
`+.dayselector` <- function(func1, func2){

  res <- function(start_day, end_day){
    c(
      func1(start_day, end_day),
      func2(start_day, end_day)
    )
  }

  structure(res, class = append('dayselector', class(res)))
}


#' @importFrom lubridate "%within%"
#' @importFrom purrr discard
#' @importFrom magrittr "%>%"
#' @export
`-.dayselector` <- function(func1, func2){

  res <- function(start_day, end_day){

    res1 <- func1(start_day, end_day)
    res2 <- func2(start_day, end_day)

    map(res1,
        function(r1){
          for(r2 in res2){
            if(r1 %within% r2){
              return(NULL)
            }
            else{
              r1 <- lubridate::setdiff(r1, r2)
            }
          }
          r1
        }
    ) %>%
      discard(is.null)
  }

  structure(res, class = append('dayselector', class(res)))
}


#' Select Mondays.
#' @param ... Character vector where each element has format 'HH:MM to HH:MM'.
#' @export
monday <- function(...){
  select_days('Monday', ...)
}

#' Select Tuedays.
#' @param ... Character vector where each element has format 'HH:MM to HH:MM'.
#' @export
tuesday <- function(...){
  select_days('Tuesday', ...)
}

#' Select Wednesdays.
#' @param ... Character vector where each element has format 'HH:MM to HH:MM'.
#' @export
wednesday <- function(...){
  select_days('Wednesday', ...)
}

#' Select Thursdays
#' @param ... Character vector where each element has format 'HH:MM to HH:MM'.
#' @export
thursday <- function(...){
  select_days('Thursday', ...)
}

#' Select Fridays
#' @param ... Character vector where each element has format 'HH:MM to HH:MM'.
#' @export
friday <- function(...){
  select_days('Friday', ...)
}

#' Select Saturdays.
#' @param ... Character vector where each element has format 'HH:MM to HH:MM'.
#' @export
saturday <- function(...){
  select_days('Saturday', ...)
}

#' Select Sundays.
#' @param ... Character vector where each element has format 'HH:MM to HH:MM'.
#' @export
sunday <- function(...){
  select_days('Sunday', ...)
}

#' Select all days of the week.
#' @param ... Character vector where each element has format 'HH:MM to HH:MM'.
#' @export
everyday <- function(...){
  select_days(
    c(
      'Monday',
      'Tuesday',
      'Wednesday',
      'Thursday',
      'Friday',
      'Saturday',
      'Sunday'
    ),
    ...
  )
}

#' Select week days (Monday to Friday)
#' @param ... Character vector where each element has format 'HH:MM to HH:MM'.
#' @export
week_days <- function(...){
  select_days(
    c(
      'Monday',
      'Tuesday',
      'Wednesday',
      'Thursday',
      'Friday'
    ),
    ...
  )
}

#' Select weekend days (Saturday and Sunday)
#' @param ... Character vector where each element has format 'HH:MM to HH:MM'.
#' @export
weekends <- function(...){
  select_days(
    c(
      'Saturday',
      'Sunday'
    ),
    ...
  )
}


#' Specify your availabilities.
#' @description Use this function in combination with the interval generating
#' functions in this package (e.g. `this_week`, `this_week_and_next`, etc.).
#' @examples
#' agenda1 <-
#' this_week_and_next(1) %>%
#'  available(
#'    monday("9:00 to 12:00", "16:00 to 17:00") +
#'      friday()
#'  )
#' @export
#' @importFrom lubridate int_start int_end
available <- function(interv, func){

  res <-
    func(start_day = int_start(interv), end_day = int_end(interv))

  structure(res, class = append('agenda', class(res)))
}



#' Interval for this week and next n.
#' @param n How many next weeks
#' @param week_start Integer, 1 to 7: what is the start of the week.
#' (1 = Monday, 7 = Sunday)? If 0, week starts today.
#' @export
#' @import lubridate
this_week_and_next <- function(n = 1, week_start = 1){
  if(week_start == 0){
    interval(today(), today() + 7*(1 + n))
  }
  else{
    interval(today(), today() + 7*(1 + n) - wday(today(), week_start = week_start))
  }
}

#' Interval for this week.
#' @param week_start Integer, 1 to 7: what is the start of the week.
#' (1 = Monday, 7 = Sunday)? If 0, week starts today.
#' @export
#' @import lubridate
this_week <- function(week_start = 1){
  this_week_and_next(n = 0, week_start = week_start)
}

#' Interval for next n weeks, starting k weeks from now.
#' @param n How many weeks total.
#' @param from_now Starting how many weeks from now.
#' @param week_start Integer, 1 to 7: what is the start of the week.
#' (1 = Monday, 7 = Sunday)? If 0, week starts today.
#' @export
#' @import lubridate
next_weeks <- function(n, from_now = 1, week_start = 1){
  if(week_start == 0){
    interval(today() + 7*(from_now), today() + 7*(1 + n))
  }
  else{
    interval(today() + 7*(from_now) + 1 - wday(today(), week_start = week_start),
             today() + 7*(from_now + n) - wday(today(), week_start = week_start))
  }
}

#' Interval for next week.
#' #' @param week_start Integer, 1 to 7: what is the start of the week
#' (1 = Monday, 7 = Sunday)? If 0, week starts today.
#' @export
next_week <- function(week_start = 1){
  next_weeks(1, 1, week_start)
}


#'@export
`+.agenda` <- function(a1, a2){
  c(a1, a2)
}

# `-.agenda` <- function(a1, a2){
#   setdiff(a1, a2)
# }


#' Find openings common to two agendas.
#' @description Given two agendas, created by the `available` function,
#' and a meeting duration, we want to find suitable times for a meeting.
#' @param agenda1 First agenda.
#' @param agenda2 Second agenda.
#' @param how_long Character, how long will the meeting be (format: 'HH:MM').
#' @param all If TRUE, return all common openings, otherwise return earliest
#' common opening.
#' @examples
#' agenda1 <-
#' this_week_and_next(1) %>%
#'   available(
#'     monday('9:00 to 12:00', '16:00 to 17:00') +
#'       friday()
#'   )
#'
#' agenda2 <-
#'   this_week() %>%
#'   available(
#'     week_days('11:00 to 12:00') -
#'       friday()
#'   ) +
#'   next_week() %>%
#'   available(
#'     week_days('13:00 to 17:00')
#'   )
#'
#' meet(agenda1, agenda2, '00:30')
#' @importFrom purrr map flatten discard map_dbl
#' @import lubridate
#' @importFrom magrittr "%>%"
#' @export
meet <- function(agenda1, agenda2, how_long, all = FALSE){

  # Find intersection
  res <-
    map(agenda1,
      function(iv1){
        map(agenda2,
            function(iv2){
              lubridate::intersect(iv1, iv2)
            }
        )
      }
    ) %>%
      flatten() %>%
      discard(~ is.na(int_start(.)) ||
                is.na(int_end(.)) ||
                minutes(.) < minutes(hm(how_long)))

  # Sort and return earliest intersection
  ordering <- order(map_dbl(res, ~ as.numeric(int_start(.))))

  if(all){
    res[ordering]
  }
  else{
    res[which(ordering == 1)]
  }
}