calendar heat map tetris chart

Question

So I was reading this post and I fell a little in love with the calendar heat map with Tetris-style month breaks.

However, the ggplot example doesn't implement the Tetris breaks, which are arguably the best part.

So, FTFY, gist here:

The procedure for this is:

1. create appropriate Tetris breaks for your data
2. left_join your data to the Tetris breaks created in (1)
3. pump the above through ggplot with some specially crafted geoms

The methodology for (1) is reasonably straightforward, implemented in the calendar_tetris_data(...) function in the gist, though it would be nice to make it a little more flexible.

My question is mainly around (3): how do I bundle up the 7 geoms necessary to make the breaks into a single procedure or geom?

If I do this:

calendar_tetris_geoms <- function() {
  geom_segment(aes(x=x, xend=x, y=ymin, yend=ymax)) +                    # (a)
    geom_segment(aes(x=xmin, xend=xmax, y=y, yend=y)) +                  # (b)
    geom_segment(aes(x=dec.x, xend=dec.x, y=dec.ymin, yend=dec.ymax)) +  # (c)
    geom_segment(aes(x=nye.xmin, xend=nye.xmax, y=nye.y, yend=nye.y)) +  # (d)
    geom_segment(x=-0.5, xend=51.5, y=7.5, yend=7.5) +                   # put a line along the top
    geom_segment(x=0.5, xend=52.5, y=0.5, yend=0.5) +                    # put a line along the bottom
    geom_text(aes(x=month.x, y=month.y, label=month.l), hjust=0.25)      # (e)

}

And then try to add that to my ggplot, it doesn't work:

> ggplot(data) + calendar_tetris_geoms()
Error in calendar_tetris_geoms() : 
  argument "plot" is missing, with no default

I clearly don't understand how this works. How does this work?

Answer 1

Update 2019-08-06 - Pulling everything into one post to make a Tetris Calendar Heat Map

Sample date data.

This is a stand in for your date data.

mydatedata<-as.Date(paste(sample(c(2018:2019), 3000, replace = TRUE), # year
                          sample(c(1:12),      3000, replace = TRUE), # month
                          sample(c(1:28),      3000, replace = TRUE), # day
                          sep="-"))

Create a data frame summarizing your data

Replace mydatedata with your df$date field.

newdf<-as.data.frame(table(mydatedata), stringsAsFactors = FALSE); 
names(newdf)<-c("date", "n")
newdf$date<-as.Date(newdf$date, format='%Y-%m-%d')

Create Calendar Tetris Data Functions

Note: I created a weekday label, renamed several functions to avoid name collision, and moved the the helper functions inside the main function.

Original source links:

1) https://gist.github.com/dvmlls/5f46ad010bea890aaf17

2) calendar heat map tetris chart

calendar_tetris_data <- function(date_min, date_max) {

  year2 <- function(d) as.integer(format(d, '%Y'))

  wday2 <- function(d) {
    n <- as.integer(format(d, '%u'))
    ifelse(n==7, 0, n) + 1 # I want the week to start on Sunday=1, so turn 7 into 0.
  }

  wday2factor <- function(wd) factor(wd, levels=1:7, labels=c('Sunday', 'Monday', 'Tuesday', 'Wednesday', 'Thursday', 'Friday', 'Saturday'))

  week2 <- function(d, year) { 
    # If January 1st is a Sunday, my weeks will start from 1 instead of 0 like the rest of them. 
    nyd <- as.Date(ISOdate(year, 1, 1))
    # So if that's the case, subtract 1. 
    as.integer(format(d, '%U')) - ifelse(wday2(nyd) == 1, 1, 0)
  }

  start <- as.Date(ISOdate(year2(min(date_min)),1,1))
  end <- as.Date(ISOdate(year2(max(date_max)), 12, 31))

  all.dates <- start + 0:as.integer(end - start, units='days')

  data.frame(date=all.dates) %>% tbl_df %>% 
    mutate(
      wday=wday2(date),
      year=year2(date),
      month=as.integer(format(date, '%m')),
      week=week2(date, year),
      day=as.integer(format(date, '%d')),
      weekday=wday2factor(wday), #20190806, adding weekday label


      # (a) put vertical lines to the left of the first week of each month
      x=ifelse(day <= 7, week - 0.5, NA),
      ymin=ifelse(day <= 7, wday - 0.5, NA),
      ymax=ifelse(day <= 7, wday + 0.5, NA),

      # (b) put a horizontal line at the bottom of the first of each month
      y=ifelse(day == 1, wday - 0.5, NA),
      xmin=ifelse(day == 1, week - 0.5, NA),
      xmax=ifelse(day == 1, week + 0.5, NA),

      # (c) in december, put vertical lines to the right of the last week
      dec.x=ifelse(month==12 & day >= 25, week + 0.5, NA),
      dec.ymin=ifelse(month==12 & day >= 25, wday - 0.5, NA),
      dec.ymax=ifelse(month==12 & day >= 25, wday + 0.5, NA),

      # (d) put a horizontal line at the top of New Years Eve
      nye.y=ifelse(month==12 & day == 31, wday + 0.5, NA),
      nye.xmin=ifelse(month==12 & day == 31, week - 0.5, NA),
      nye.xmax=ifelse(month==12 & day == 31, week + 0.5, NA),

      # (e) put the first letter of the month on the first day
      month.x=ifelse(day == 1, week, NA),
      month.y=ifelse(day == 1, wday, NA),
      month.l=ifelse(day == 1, substr(format(date, '%B'), 1, 3), NA)
    )
}

Create the ggplot2 geom:

calendar_tetris_geoms <- function() {
  list(
    geom_segment(aes(x=x, xend=x, y=ymin, yend=ymax)),                 # (a)
    geom_segment(aes(x=xmin, xend=xmax, y=y, yend=y)),                 # (b)
    geom_segment(aes(x=dec.x, xend=dec.x, y=dec.ymin, yend=dec.ymax)), # (c)
    geom_segment(aes(x=nye.xmin, xend=nye.xmax, y=nye.y, yend=nye.y)), # (d)
    geom_segment(x=-0.5, xend=51.5, y=7.5, yend=7.5),                  # put a line along the top
    geom_segment(x=0.5, xend=52.5, y=0.5, yend=0.5),                   # put a line along the bottom
    geom_text(aes(x=month.x, y=month.y, label=month.l), hjust=0.25)    # (e)
  )
}

Create the plot:

library(ggplot2)
library(dplyr) # for %>% pipe


calendar_tetris_data(min(newdf$date), max(newdf$date)) %>% 
  left_join(newdf) %>% 
  ggplot() + 
    geom_tile(aes(x=week, y=weekday, fill = n), colour = "white") + 
    calendar_tetris_geoms() + 
    facet_wrap(~ year, ncol = 1) 

Answer 2

Modifying @baptiste's suggestion, if I do this:

calendar_tetris_geoms <- function() {
  list(
    geom_segment(aes(x=x, xend=x, y=ymin, yend=ymax)),                 # (a)
    geom_segment(aes(x=xmin, xend=xmax, y=y, yend=y)),                 # (b)
    geom_segment(aes(x=dec.x, xend=dec.x, y=dec.ymin, yend=dec.ymax)), # (c)
    geom_segment(aes(x=nye.xmin, xend=nye.xmax, y=nye.y, yend=nye.y)), # (d)
    geom_segment(x=-0.5, xend=51.5, y=7.5, yend=7.5),                  # put a line along the top
    geom_segment(x=0.5, xend=52.5, y=0.5, yend=0.5),                   # put a line along the bottom
    geom_text(aes(x=month.x, y=month.y, label=month.l), hjust=0.25)    # (e)
  )
}

Then this works a treat:

calendar_tetris_data(min(stock.data$date), max(stock.data$date)) %>% 
  left_join(stock.data) %>% 
  ggplot() + 
  geom_tile(aes(x=week, y=wday2factor(wday), fill = Adj.Close), colour = "white") + 
  calendar_tetris_geoms() + 
  facet_wrap(~ year, ncol = 1)