R/calendR.R

Defines functions calendR

Documented in calendR

#' @title Monthly and yearly calendars
#'
#' @description Create ready to print monthly and yearly calendars. The function allows personalizing colors (even setting a gradient color scale for a full month or year), texts and fonts. In addition, for monthly calendars you can also add text on the days and moon phases.
#'
#' @param year Calendar year. By default uses the current year.
#' @param month Month of the year or `NULL` (default) for the yearly calendar.
#' @param from Custom start date of the calendar. If `from != NULL`, `year` and `month` arguments won't be taken into account.
#' @param to Custom end date of the calendar.
#' @param start `"S"` (default) for starting the week on Sunday or `"M"` for starting the week on Monday.
#' @param orientation The calendar orientation: `"portrait"` or `"landscape"` (default). Also accepts `"p"` and `"l"`.
#' @param title Title of the the calendar. If not supplied is the year and the month, or the year if `month = NULL`.
#' @param title.size Size of the main title.
#' @param title.col Color of the main title.
#' @param subtitle Subtitle of the calendar in italics (optional).
#' @param subtitle.col Color of the subtitle.
#' @param subtitle.size Font size of the subtitle.
#' @param text Character vector of texts to be added on the calendar. Only for monthly calendars.
#' @param text.pos Numeric vector containing the number of days of the month where to add the texts of the `text` argument.
#' @param text.size Font size of the texts added with the `text` argument.
#' @param text.col Color of the texts added with the `text` argument.
#' @param special.days Numeric vector indicating the days to color or `"weekend"` for coloring all the weekends.
#' @param special.col Color for the days indicated in special.days. If `gradient = TRUE`, is the higher color of the gradient.
#' @param gradient Boolean. If `special.days` is a numeric vector of the length of the displayed days, `gradient = TRUE` creates a gradient of the `special.col` on the calendar.
#' @param low.col If `gradient = TRUE`, is the lower color of the gradient. If `gradient = FALSE` is the background color of the days. Defaults to `"white"`.
#' @param col Color of the lines of the calendar.
#' @param lwd Line width of the calendar.
#' @param lty Line type of the calendar. If `lty = 0` no lines are drawn.
#' @param font.family Font family of all the texts.
#' @param font.style Style of all the texts and numbers except the subtitle. Possible options are `"plain"` (default), `"bold"`, `"italic"` and `"bold.italic"`.
#' @param day.size Font size of the number of the days.
#' @param days.col Color of the number of the days.
#' @param weeknames Character vector with the names of the days of the week starting on Monday. By default they will be in the system locale.
#' @param weeknames.col Color of the names of the days.
#' @param weeknames.size Size of the names of the days.
#' @param week.number If `TRUE`, the week number of the year for each week is added.
#' @param week.number.col If `week.number = TRUE` is the color of the week numbers.
#' @param week.number.size If `week.number = TRUE` is the size of the week numbers.
#' @param monthnames Character vector with the names of the months of the calendar. By default they will be upper case and in the system locale.
#' @param months.size Font size of the names of the months.
#' @param months.col If `month = NULL`, is the color of the month names.
#' @param months.pos Horizontal align of the month names. Defaults to 0.5 (center).
#' @param mbg.col Background color of the month names. Defaults to "white".
#' @param legend.pos If `gradient = TRUE`, is the position of the legend. It can be set to `"none"` (default), `"top"`, `"bottom"`, `"left"` and `"right"`.
#' @param legend.title If `legend.pos != "none"` and  `gradient = TRUE`, is the title of the legend.
#' @param bg.col Background color of the calendar. Defaults to "white".
#' @param bg.img Character string containing the URL or the local directory of a image to be used as background.
#' @param margin Numeric. Allows controlling the margin of the calendar.
#' @param ncol Numeric. Controls the number of columns of the yearly calendar. Overrides the default values for "landscape" and "portrait" orientation.
#' @param lunar Boolean. If `TRUE`, draws the lunar phases. Only available for monthly calendars.
#' @param lunar.col If `lunar = TRUE`, is the color of the hide part of the moons.
#' @param lunar.size If `lunar = TRUE`, is the size of the representation of the moons.
#' @param pdf Boolean. If `TRUE`, saves the calendar in the working directory in A4 format.
#' @param doc_name If `pdf = TRUE`, is the name of the generated file (without the file extension). If not specified, creates files of the format: `Calendar_year.pdf` for yearly calendars and `Calendar_month_year.pdf` for monthly calendars.
#' @param papersize PDF paper size. Possible options are `"A6"`, `"A5"`, `"A4"` (default), `"A3"`, `"A2"`, `"A1"` and `"A0"`. Depending on the size you will need to fine-tune some arguments, like the font sizes.
#'
#' @author
#' \itemize{
#' \item{Soage González, José Carlos.}
#' \item{Maintainer: José Carlos Soage González. \email{jsoage@@uvigo.es}}
#' }
#'
#' @examples
#' # Calendar of the current year
#' calendR()
#'
#' # Calendar of July, 2005, starting on Monday
#' calendR(year = 2005, month = 7, start = "M", subtitle = "Have a nice day")
#'
#' \donttest{
#' # Create ready to print monthly calendars for all the months of the current year
#' # with week starting on Sunday
#' invisible(sapply(1:12 , function(i) calendR(month = i, pdf = TRUE,
#'  doc_name = file.path(tempdir(), paste0("myCalendar", i , ".pdf")))))
#' }
#'
#' @import ggplot2 dplyr forcats suncalc ggimage gggibbous
#' @importFrom grDevices rgb
#' @importFrom stats na.omit
#' @export
calendR <- function(year = format(Sys.Date(), "%Y"),
                    month = NULL,

                    from = NULL,
                    to = NULL,

                    start = c("S", "M"),
                    orientation = c("portrait", "landscape"),

                    title,
                    title.size = 20,
                    title.col = "gray30",

                    subtitle = "",
                    subtitle.size = 10,
                    subtitle.col = "gray30",

                    text = NULL,
                    text.pos = NULL,
                    text.size = 4,
                    text.col = "gray30",

                    special.days = NULL,
                    special.col = "gray90",
                    gradient = FALSE,
                    low.col = "white",

                    col = "gray30",
                    lwd = 0.5,
                    lty = 1,

                    font.family = "sans",
                    font.style = "plain",

                    day.size = 3,
                    days.col = "gray30",

                    weeknames,
                    weeknames.col = "gray30",
                    weeknames.size = 4.5,
                    week.number = FALSE,
                    week.number.col = "gray30",
                    week.number.size = 8,

                    monthnames,
                    months.size = 10,
                    months.col = "gray30",
                    months.pos = 0.5,
                    mbg.col = "white",

                    legend.pos = "none",
                    legend.title = "",

                    bg.col = "white",
                    bg.img = "",

                    margin = 1,
                    ncol,

                    lunar = FALSE,
                    lunar.col = "gray60",
                    lunar.size = 7,

                    pdf = FALSE,
                    doc_name = "",
                    papersize = "A4") {

  if(year < 0) {
    stop("You must be kidding. You don't need a calendar of a year Before Christ :)")
  }

  wend <- TRUE
  l <- TRUE

  if((!is.null(from) & is.null(to))) {
    stop("Provide an end date with the 'to' argument")
  }

  if((is.null(from) & !is.null(to))) {
    stop("Provide a start date with the 'from' argument")
  }

  if(is.character(special.days) & length(unique(na.omit(special.days))) != length(special.col)) {
    stop("The number of colors supplied on 'special.col' argument must be the same of length(unique(na.omit(special.days)))")
  }

  if (length(unique(start)) != 1) {
    start <- "S"
  }

  if (length(unique(orientation)) != 1) {
    orientation <- "landscape"
  }


  if(missing(ncol)) {
    ncol <- ifelse(orientation == "landscape" | orientation == "l", 4, 3)
  }


  match.arg(start, c("S", "M"))
  match.arg(orientation, c("landscape", "portrait", "l", "p"))
  match.arg(papersize, c("A6", "A5", "A4", "A3", "A2", "A1", "A0"))


  if(!is.null(month)){
    if(month > 12) {
      stop("There are no more than 12 months in a year")
    }

    if(month <= 0) {
      stop("Months must be between 1 and 12")
    }

    if(is.character(month)) {
      stop("You must provide a month in a numeric format, between 1 and 12")
    }
  }

  months <- format(seq(as.Date("2016-01-01"), as.Date("2016-12-01"), by = "1 month"), "%B")

  if(!is.null(text) && is.null(text.pos)){
    warning("Select the number of days for the text with the 'text.pos' argument")
  }

  if(is.null(text) && !is.null(text.pos)){
    warning("Add text with the 'text' argument")
  }

  if(missing(weeknames)) {

    up <- function(x) {
      substr(x, 1, 1) <- toupper(substr(x, 1, 1))
      x
    }

    Day <- seq(as.Date("2020-08-23"), by = 1, len=7)
    weeknames <- c(up(weekdays(Day))[2:7], up(weekdays(Day))[1])
  }


  if(!is.null(from) & !is.null(to)) {

    if(as.numeric(as.Date(from) - as.Date(to)) > 0) {
      stop("'to' must be posterior to 'from'")
    }

    if(lunar == TRUE) {
      l <- FALSE
      warning("Lunar phases are only available for monthly calendars")
    }

    mindate <- as.Date(from)
    maxdate <- as.Date(to)
    weeknames <- substring(weeknames, 1, 3)

  } else {

    if(is.null(month)) {

      mindate <- as.Date(format(as.Date(paste0(year, "-0", 01, "-01")), "%Y-%m-01"))
      maxdate <- as.Date(format(as.Date(paste0(year, "-12-", 31)), "%Y-%m-31"))
      weeknames <- substring(weeknames, 1, 3)

    } else {

      if(month >= 10) {
        mindate <- as.Date(format(as.Date(paste0(year, "-", month, "-01")), "%Y-%m-01"))
      } else {
        mindate <- as.Date(format(as.Date(paste0(year, "-0", month, "-01")), "%Y-%m-01"))
      }

      maxdate <- seq(mindate, length = 2, by = "months")[2] - 1
    }
  }

  if(!is.null(from) & !is.null(to)) {

    # Temporal fix
    if(as.Date(to) - as.Date(from) > 366) {
      stop("'from' and 'to' can't me more than 1 year appart")
    }

    if(as.numeric(as.Date(to) - as.Date(from)) > 0) {

      # Set up dplyr::tibble with all the dates
      filler <- dplyr::tibble(date = seq(mindate, maxdate, by = "1 day"))

      # Filling colors
      dates <- seq(mindate, maxdate, by = "1 day")

    } else {
      stop("'to' must be posterior to 'from'")
    }
  } else {
    filler <- dplyr::tibble(date = seq(mindate, maxdate, by = "1 day"))
    dates <- seq(mindate, maxdate, by = "1 day")
  }

  fills <- numeric(length(dates))

  # Texts
  texts <- character(length(dates))
  texts[text.pos] <- text

  moon_m <- suncalc::getMoonIllumination(date = dates, keep = c("fraction", "phase", "angle"))
  moon <- moon_m[, 2]
  right <- ifelse(moon_m[, 4] < 0, TRUE, FALSE)

  if(is.character(special.days)) {

    if(length(special.days) != length(dates)){

      if(special.days != "weekend") {
        stop("special.days must be a numeric vector, a character vector of the length of the number of days of the year or month or 'weekend'")
      } else {
        wend <- FALSE
      }
    }


    if(gradient == TRUE){
      warning("Gradient won't be created as 'special.days' is of type character. Set gradient = FALSE in this scenario to avoid this warning")

      if(legend.title != "" & legend.pos == "none"){
        warning("Legend title specified, but legend.pos == 'none', so no legend will be plotted")
      }

    } else {
      if(length(special.days) != length(dates) & (legend.pos != "none" | legend.title != "")) {
        legend.pos = "none"
        warning("gradient = FALSE, so no legend will be plotted")
      }
    }

  } else {

    if(gradient == FALSE) {
      if(length(special.days) != length(dates) & (legend.pos != "none" | legend.title != "")) {
        legend.pos = "none"
        warning("gradient = FALSE, so no legend will be plotted")
      }
    } else {

      if(legend.title != "" & legend.pos == "none"){
        warning("Legend title specified, but legend.pos == 'none', so no legend will be plotted")
      }
    }

    # if(length(special.days) > length(dates)) {
    #
    #   stop("No element of the 'special.days' vector can be greater than the number of days of the corresponding month or year")
    # }

    if(gradient == TRUE & (length(special.days) != length(dates))) {
      stop("If gradient = TRUE, the length of 'special.days' must be the same as the number of days of the corresponding month or year")
    }
  }


  if(start == "M") {

    weekdays <- weeknames

    t1 <- dplyr::tibble(date = dates, fill = fills) %>%
      right_join(filler, by = "date") %>% # fill in missing dates with NA
      mutate(dow = ifelse(as.numeric(format(date, "%w")) == 0, 6, as.numeric(format(date, "%w")) - 1)) %>%
      mutate(month = format(date, "%B")) %>%
      mutate(woy = as.numeric(format(date, "%W"))) %>%
      mutate(year = as.numeric(format(date, "%Y"))) %>%
      mutate(month = toupper(factor(month, levels = months, ordered = TRUE))) %>%
      # arrange(year, month) %>%
      mutate(monlabel = month)

    if (!is.null(month)) { # multi-year data set
      t1$monlabel <- paste(t1$month, t1$year)
    }

    t2 <- t1 %>%
      mutate(monlabel = factor(monlabel, ordered = TRUE)) %>%
      mutate(monlabel = fct_inorder(monlabel)) %>%
      mutate(monthweek = woy - min(woy),
             y = max(monthweek) - monthweek + 1) %>%
      mutate(weekend = ifelse(dow == 6 | dow == 5, 1, 0))


    if( all(special.days == 0) == TRUE || length(special.days) == 0) {
      special.col <- "white"
    } else {

      if(is.character(special.days)) {

        if (length(special.days) == length(dates)) {
          fills <- special.days
        } else {
          if (special.days == "weekend") {
            fills <- t2$weekend
          }
        }

      } else {

        if(gradient == TRUE) {
          fills <- special.days
        } else {
          fills[special.days] <- 1
        }
      }
    }

  } else {

    weekdays <- c(weeknames[7], weeknames[1:6])

    t1 <- dplyr::tibble(date = dates, fill = fills) %>%
      right_join(filler, by = "date") %>% # fill in missing dates with NA
      mutate(dow = as.numeric(format(date, "%w"))) %>%
      mutate(month = format(date, "%B")) %>%
      mutate(woy = as.numeric(format(date, "%U"))) %>%
      mutate(year = as.numeric(format(date, "%Y"))) %>%
      mutate(month = toupper(factor(month, levels = months, ordered = TRUE))) %>%
      # arrange(year, month) %>%
      mutate(monlabel = month)

    if (!is.null(month)) { # Multi-year data set
      t1$monlabel <- paste(t1$month, t1$year)
    }

    t2 <- t1 %>%
      mutate(monlabel = factor(monlabel, ordered = TRUE)) %>%
      mutate(monlabel = fct_inorder(monlabel)) %>%
      mutate(monthweek = woy - min(woy),
             y = max(monthweek) - monthweek + 1) %>%
      mutate(weekend = ifelse(dow == 0 | dow == 6, 1, 0))


    if(all(special.days == 0) == TRUE  || length(special.days) == 0) {
      special.col <- "white"
    } else {

      if(is.character(special.days)) {

        if (length(special.days) == length(dates)) {
          fills <- special.days
        } else {
          if (special.days == "weekend") {
            fills <- t2$weekend
          }
        }
      } else {

        if(gradient == TRUE) {
          fills <- special.days
        } else {
          fills[special.days] <- 1
        }
      }
    }
  }


  df <- data.frame(week = weekdays,
                   pos.x = 0:6,
                   pos.y = rep(max(t2$monthweek) + 1.75, 7))

  if(missing(title)) {

    if(!is.null(from) & !is.null(to)) {

      title <- paste0(format(as.Date(from), "%m"), "/", format(as.Date(from), "%Y"), " - ",
                      format(as.Date(to), "%m"), "/", format(as.Date(to), "%Y"))

    }else{

      if(is.null(month)) {
        title <- year
      } else {
        title <- levels(t2$monlabel)
      }
    }
  }

  if(week.number == FALSE) {
    week.number.col <- "transparent"
  }


  if(is.null(month) | (!is.null(from) & !is.null(to))) {

    if(!missing(monthnames)) {
      if(length(monthnames) == length(levels(t2$monlabel))) {
        t2$monlabel <- factor(t2$monlabel, labels = monthnames)
      } else {
        stop("The length of 'monthname's must equal to the number months")
      }
    }

    if(lunar == TRUE & l != FALSE) {
      warning("Lunar phases are only available for monthly calendars")
    }


    if(gradient == TRUE || !missing(special.days)) {

      p <- ggplot(t2, aes(dow, woy + 1)) +
        geom_tile(aes(fill = fills), color = col, size = lwd, linetype = lty)

    } else {
      p <- ggplot(t2, aes(dow, woy + 1)) +
        geom_tile(aes(fill = fills), fill = low.col, color = col, size = lwd, linetype = lty)

    }


    if(is.null(from) & is.null(to)) {
      weeklabels <- 1:53

      if(length(t2$date) == 365) {
        weeklabels <- 1:53
      } else {
        if(t2$dow[1] == 6){
          weeklabels <- 1:54
        }
      }
    } else {
      weeklabels <-unique(t2$woy) + 1
    }

    if(is.character(special.days) & wend & length(unique(special.days) == length(dates))) {
      p <- p + scale_fill_manual(values = special.col, labels = levels(as.factor(fills)), na.value = "white", na.translate = FALSE)
    } else {
      p <- p + scale_fill_gradient(low = low.col, high = special.col, na.value = "white")
    }

    p <- p + facet_wrap( ~ monlabel, ncol = ncol, scales = "free") +
      ggtitle(title) +
      labs(subtitle = subtitle) +
      scale_x_continuous(expand = c(0.01, 0.01), position = "top",
                         breaks = seq(0, 6), labels = weekdays) +
      scale_y_continuous(expand = c(0.01, 0.01), trans = "reverse", breaks = unique(t2$woy) + 1, labels = weeklabels) +
      geom_text(data = t2, aes(label = gsub("^0+", "", format(date, "%d"))),
                size = day.size, family = font.family,
                color = days.col, fontface = font.style) +
      labs(fill = legend.title) +
      theme(panel.background = element_rect(fill = NA, color = NA),
            strip.background = element_rect(fill = mbg.col, color = mbg.col),
            plot.background = element_rect(fill = bg.col),
            panel.grid = element_line(colour = ifelse(bg.img == "", bg.col, "transparent")),
            strip.text.x = element_text(hjust = months.pos, face = font.style, color = months.col, size = months.size),
            legend.title = element_text(),
            axis.ticks = element_blank(),
            axis.title = element_blank(),
            axis.text.y = element_text(colour = week.number.col, size = week.number.size),
            axis.text.x = element_text(colour = weeknames.col, size = weeknames.size * 2.25),
            plot.title = element_text(hjust = 0.5, size = title.size, colour = title.col),
            plot.subtitle = element_text(hjust = 0.5, face = "italic", colour = subtitle.col, size = subtitle.size),
            legend.position = legend.pos,
            plot.margin = unit(c(1 * margin, 0.5 * margin, 1 * margin, 0.5 * margin), "cm"),
            text = element_text(family = font.family, face = font.style),
            strip.placement = "outsite")

    if(bg.img != "") {
      p <- ggbackground(p, bg.img)
    }

    # print(p)

  } else {

    tidymoons <- data.frame(
      x = t2$dow + 0.35,
      y =  t2$y + 0.3,
      ratio = moon,
      right = right
    )

    tidymoons2 <- data.frame(
      x = t2$dow + 0.35,
      y =  t2$y + 0.3,
      ratio = 1 - moon,
      right = !right
    )

    p <- ggplot(t2, aes(dow, y)) +
      geom_tile(aes(fill = fills), color = col, size = lwd, linetype = lty)

    if(lunar == TRUE) {
      p <- p + geom_moon(data = tidymoons, aes(x, y, ratio = ratio, right = right), size = lunar.size, fill = "white") +
        geom_moon(data = tidymoons2, aes(x, y, ratio = ratio, right = right), size = lunar.size, fill = lunar.col)
    }


    if(is.character(special.days) & wend & length(unique(special.days) == length(dates))) {
      p <- p + scale_fill_manual(values = special.col, labels = levels(as.factor(fills)), na.value = "white", na.translate = FALSE)
    } else {
      p <- p + scale_fill_gradient(low = low.col, high = special.col, na.value = "white")
    }

    p <- p + ggtitle(title) +
      labs(subtitle = subtitle) +
      geom_text(data = df, aes(label = week, x = pos.x, y = pos.y), size = weeknames.size, family = font.family, color = weeknames.col, fontface = font.style) +
      geom_text(aes(label = texts), color = text.col, size = text.size, family = font.family) +
      # scale_x_continuous(expand = c(0.01, 0.01), position = "top",
      #                   breaks = seq(0, 6), labels = weekdays) +
      scale_y_continuous(expand = c(0.05, 0.05), labels = rev(unique(t2$woy)), breaks = 1:length(unique(t2$woy))) +
      geom_text(data = t2, aes(label = 1:nrow(filler), x = dow -0.4, y = y + 0.35), size = day.size, family = font.family, color = days.col, fontface = font.style) +
      labs(fill = legend.title) +
      theme(panel.background = element_rect(fill = NA, color = NA),
            strip.background = element_rect(fill = NA, color = NA),
            plot.background = element_rect(fill = bg.col),
            panel.grid = element_line(colour = ifelse(bg.img == "", bg.col, "transparent")),
            strip.text.x = element_text(hjust = 0, face = "bold", size = months.size),
            legend.title = element_text(),
            axis.ticks = element_blank(),
            axis.title = element_blank(),
            axis.text.y = element_text(colour = week.number.col, size = week.number.size),
            axis.text.x = element_blank(),
            plot.title = element_text(hjust = 0.5, size = title.size, colour = title.col),
            plot.subtitle = element_text(hjust = 0.5, face = "italic", colour = subtitle.col, size = subtitle.size),
            legend.position = legend.pos,
            plot.margin = unit(c(1 * margin,  0.5 * margin, 1 * margin,  0.5 * margin), "cm"),
            text = element_text(family = font.family, face = font.style),
            strip.placement = "outsite")

    if(bg.img != "") {
      p <- ggbackground(p, bg.img)
    }

    # print(p)

  }

  if(pdf == FALSE & doc_name != ""){
    warning("Set pdf = TRUE to save the current calendar")
  }

  if(pdf == TRUE) {

    switch (papersize,
            A6 = {
              a <- 148
              b <- 105

            },
            A5 = {
              a <- 210
              b <- 148

            },
            A4 = {
              a <- 297
              b <- 210
            },
            A3 = {
              a <- 420
              b <- 297
            },
            A2 = {
              a <- 594
              b <- 420
            },
            A1 = {
              a <- 841
              b <- 594
            },
            A0 = {
              a <- 1189
              b <- 841
            },
    )


    if(doc_name == "") {
      if(!is.null(month)) {

        doc_name <- paste0("Calendar_", tolower(t2$month[1]), "_", year, ".pdf")

      } else {
        if(!is.null(from) & !is.null(to)) {
          doc_name <- paste0("Calendar_", from, "_", to, ".pdf")
        } else {
          doc_name <- paste0("Calendar_", year, ".pdf")
        }
      }


    } else {
      doc_name <- paste0(doc_name, ".pdf")
    }

    if(orientation == "landscape" | orientation == "l") {
      ggsave(filename = if(!file.exists(doc_name)) doc_name else stop("File does already exist!"),
             height = b, width = a, units = "mm")
    } else {
      ggsave(filename = if(!file.exists(doc_name)) doc_name else stop("File does already exist!"),
             width = b, height = a, units = "mm")
    }
  }

  return(p)
}

Try the calendR package in your browser

Any scripts or data that you put into this service are public.

calendR documentation built on Oct. 6, 2023, 1:07 a.m.