R/write_ical.R

In stRoke: Clinical Stroke Research

#' MOVED Write ical object
#' 
#' This function creates an ical file based on a data frame with mixed events. 
#' Export as .ics file using `calendar::ic_write()`.
#' 
#' @param df A data frame with the calendar data
#' @param date The name of the event date column in the data frame
#' @param date.end The name of the end date column in the data frame
#' @param title The name of the title column in the data frame
#' @param time.start The name of the start time column in the data frame
#' @param time.end The name of the end time column in the data frame
#' @param place The name of the place column in the data frame
#' @param place.def Default location to use when place is NA
#' @param time.def Default start time to use when time.start is NA
#' @param time.dur Default duration of the event in minutes, if time.end is NA
#' @param descr Name of description/notes column if any.
#' @param link Name of link column, if any.
#' @param t.zone A character string of time zone for events. The string must be 
#' a time zone that is recognized by the user's OS.
#' 
#' @return ical object
#' 
#' @examples
#' df <- data.frame(
#'   date = c("2020-02-10", "2020-02-11"),
#'   date.end = c("2020-02-13",NA),
#'   title = c("Conference", "Lunch"),
#'   start = c("12:00:00", NA),
#'   time.end = c("13:00:00", NA),
#'   note = c("Hi there","Remember to come"),
#'   link = c("https://icalendar.org","https://agdamsbo.github.io/stRoke/")
#' )
#' 
#' write_ical(
#'   df,
#'   date = "date",
#'   date.end = "date.end",
#'   title = "title",
#'   time.start = "start",
#'   time.end = "time.end",
#'   place.def = "Conference Room",
#'   descr = "note",
#'   link = "link"
#' )
#' 
#' @export
#' 
#' @importFrom lubridate ymd hms dminutes
#' @importFrom dplyr if_else
#' @importFrom calendar ic_guid ic_write
#'
#' @seealso
#' [calendar package](https://github.com/ATFutures/calendar/)
#' [icalendar standard webpage](https://icalendar.org)
#'
#'
write_ical <-
  function(df,
           date = "date",
           date.end = NA,
           title = "title",
           time.start = "start",
           time.end = "end",
           place = NA,
           place.def = NA,
           time.def = "10:00:00",
           time.dur = 60,
           descr = NA,
           link = NA,
           t.zone = "CET") {
    if (!date %in% colnames(df)) {
      stop("Supplied date is not a valid column name")
    }
    
    if (!title %in% colnames(df)) {
      stop("Supplied title is not a valid column name")
    }
    
    if (any(is.na(df[,title]))) {
      stop("Missing title values are not allowed")
    }
    
    if (is.character(place) & !place %in% colnames(df)) {
      stop("Supplied place is not a valid column name")
    }
    
    if (is.character(time.start) & !time.start %in% colnames(df)) {
      stop("Supplied time.start is not a valid column name")
    }
    
    if (is.character(time.end) & !time.end %in% colnames(df)) {
      stop("Supplied time.end is not a valid column name")
    }
    
    # Both ifelse() and dplyr::if_else() has problems and gives errors 
    # handling NA's, as everything is evaluated.
    # This is my take on a approach by row.
    df <- do.call(rbind, 
                  lapply(
                    split(df,
                          seq_len(nrow(df))),
                    function(i) {
                      if (is.na(i[time.start])) {
                        i$start_time <-
                          lubridate::ymd(i[, date], tz = t.zone) +
                          lubridate::hms(time.def)
                      }
                      else if (!is.na(i[, time.start])) {
                        i$start_time <-
                          lubridate::ymd(i[, date], tz = t.zone) +
                          lubridate::hms(i[, time.start])
                      }
                      
                      if (is.character(date.end) &
                          is.na(i[, time.end]) &
                          !is.na(i[, date.end])) {
                        stop("time.end is missing for some date.end")
                      }
                      else if (is.character(date.end) &
                          !is.na(i[, time.end]) &
                          !is.na(i[, date.end])) {
                        i$end_time <-
                          lubridate::ymd(i[, date.end], tz = t.zone) +
                          lubridate::hms(i[, time.end])
                      }
                      else if (!is.na(i[, time.end])) {
                        i$end_time <-
                          lubridate::ymd(i[, date], tz = t.zone) +
                          lubridate::hms(i[, time.end])
                      } else {
                        i$end_time <- 
                          i$start_time + lubridate::dminutes(time.dur)
                      }
                      
                      i
                      
                    }))
    
    place_meet <- rep(NA, nrow(df))
    
    if (!is.na(place)) {
      place_meet <- df[, place]
    }
    
    place_meet[is.na(place_meet)] <- place.def
    
    df_mod <-  data.frame(
      SUMMARY = df[, title],
      DTSTART = df[, "start_time"],
      DTEND = df[, "end_time"],
      UID = replicate(nrow(df), calendar::ic_guid()),
      stringsAsFactors = FALSE
    )
    
    if (!all(is.na(place_meet))) {
      df_mod <-  data.frame(df_mod,
                            LOCATION = place_meet)
    }
    
    if (!is.na(link)) {
      df_mod <-  data.frame(df_mod,
                            URL = df[, link])
    }
    
    if (!is.na(descr)) {
      df_mod <-  data.frame(df_mod,
                            DESCRIPTION = df[, descr])
    }
    
    calendar::ical(df_mod)
  }