calendar heat map tetris chart - r

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:
create appropriate Tetris breaks for your data
left_join your data to the Tetris breaks created in (1)
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

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)

Answer 2

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)