Calendar Heatmap by Paul Bleicher

calendarHeat.R

 ##############################################################################
 #                        Calendar Heatmap                                    #
 #                                by                                          #
 #                         Paul Bleicher                                      #
 # an R version of a graphic from:                                            #
 # http://stat-computing.org/dataexpo/2009/posters/wicklin-allison.pdf        #
 #  requires lattice, chron, grid packages                                    #
 ############################################################################## 

## calendarHeat: An R function to display time-series data as a calendar heatmap 
## Copyright 2009 Humedica. All rights reserved.

## This program is free software; you can redistribute it and/or modify
## it under the terms of the GNU General Public License as published by
## the Free Software Foundation; either version 2 of the License, or
## (at your option) any later version.

## This program is distributed in the hope that it will be useful,
## but WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
## GNU General Public License for more details.

## You can find a copy of the GNU General Public License, Version 2 at:
## http://www.gnu.org/licenses/gpl-2.0.html
 
# days <- seq(as.Date("2015-01-1"), as.Date("2015-12-31"), "days")
# values <- runif(365)
# calendarHeat(days, values)

calendarHeat <- function(dates, 
                         values,
                         colors,
                         ncolors=99,
                         title,
                         date.form = "%Y-%m-%d", ...) {
  require(lattice, quietly = TRUE)
  require(grid, quietly = TRUE)
  
  if (class(dates) == "character" | class(dates) == "factor" ) {
    dates <- strptime(dates, date.form)
          }
  caldat <- data.frame(value = values, dates = dates)
  min.date <- as.Date(paste(format(min(dates), "%Y"),
                      "-1-1",sep = ""))
  max.date <- as.Date(paste(format(max(dates), "%Y"),
                       "-12-31", sep = ""))
  dates.f <- data.frame(date.seq = seq(min.date, max.date, by="days"))
  
  # Merge moves data by one day, avoid
  caldat <- data.frame(date.seq = seq(min.date, max.date, by="days"), value = NA)
  dates <- as.Date(dates) 
  caldat$value[match(dates, caldat$date.seq)] <- values
  
  caldat$dotw <- as.numeric(format(caldat$date.seq, "%w"))
  caldat$woty <- as.numeric(format(caldat$date.seq, "%U")) + 1
  caldat$yr <- as.factor(format(caldat$date.seq, "%Y"))
  caldat$month <- as.numeric(format(caldat$date.seq, "%m"))
  yrs <- as.character(unique(caldat$yr))
  d.loc <- as.numeric()                        
  for (m in min(yrs):max(yrs)) {
    d.subset <- which(caldat$yr == m)  
    sub.seq <- seq(1,length(d.subset))
    d.loc <- c(d.loc, sub.seq)
    }  
  caldat <- cbind(caldat, seq=d.loc)
  
  #color styles
  if (missing(colors)) colors <- c("#D61818", "#FFAE63", "#FFFFBD", "#B5E384")                          

  calendar.pal <- colorRampPalette(colors, space = "Lab")
  def.theme <- lattice.getOption("default.theme")
  cal.theme <-
     function() {  
    theme <-
    list(
      strip.background = list(col = "transparent"),
      strip.border = list(col = "transparent"),
      axis.line = list(col="transparent"),
      par.strip.text=list(cex=0.8))
      }
  lattice.options(default.theme = cal.theme)
  yrs <- (unique(caldat$yr))
  nyr <- length(yrs)
  print(cal.plot <- levelplot(value~woty*dotw | yr, data=caldat,
     as.table=TRUE,
     aspect=.12,
   layout = c(1, nyr%%7),
     between = list(x=0, y=c(0.5,0.5)),
     strip=TRUE,
     main = ifelse(missing(title), "", title),
     scales = list(
       x = list(
                 at= c(seq(2.9, 52, by=4.42)),
                 labels = month.abb,
                 alternating = c(1, rep(0, (nyr-1))),
                 tck=0,
                 cex = 0.7),
       y=list(
            at = c(0, 1, 2, 3, 4, 5, 6),
            labels = c("Sunday", "Monday", "Tuesday", "Wednesday", "Thursday",
                        "Friday", "Saturday"),
            alternating = 1,
            cex = 0.6,
            tck=0)),
     xlim =c(0.4, 54.6),
     ylim=c(6.6,-0.6),
     cuts= ncolors - 1,
     col.regions = (calendar.pal(ncolors)),
     xlab="" ,
     ylab="",
     colorkey= list(col = calendar.pal(ncolors), width = 0.6, height = 0.5),
     subscripts=TRUE
      ) )
  panel.locs <- trellis.currentLayout()
  for (row in 1:nrow(panel.locs)) {
      for (column in 1:ncol(panel.locs))  {
      if (panel.locs[row, column] > 0)
  {
      trellis.focus("panel", row = row, column = column,
                    highlight = FALSE)
  xyetc <- trellis.panelArgs()
  subs <- caldat[xyetc$subscripts,]
  dates.fsubs <- caldat[caldat$yr == unique(subs$yr),]
  y.start <- dates.fsubs$dotw[1]
  y.end   <- dates.fsubs$dotw[nrow(dates.fsubs)]
  dates.len <- nrow(dates.fsubs)
  adj.start <- dates.fsubs$woty[1]
  
  for (k in 0:6) {
   if (k < y.start) {
      x.start <- adj.start + 0.5
      } else {
      x.start <- adj.start - 0.5
        }
    if (k > y.end) {
       x.finis <- dates.fsubs$woty[nrow(dates.fsubs)] - 0.5
      } else {
       x.finis <- dates.fsubs$woty[nrow(dates.fsubs)] + 0.5
        }
      grid.lines(x = c(x.start, x.finis), y = c(k -0.5, k - 0.5), 
       default.units = "native", gp=gpar(col = "grey", lwd = 1))
       }
  if (adj.start <  2) {
   grid.lines(x = c( 0.5,  0.5), y = c(6.5, y.start-0.5), 
        default.units = "native", gp=gpar(col = "grey", lwd = 1))
   grid.lines(x = c(1.5, 1.5), y = c(6.5, -0.5), default.units = "native",
        gp=gpar(col = "grey", lwd = 1))
   grid.lines(x = c(x.finis, x.finis), 
        y = c(dates.fsubs$dotw[dates.len] -0.5, -0.5), default.units = "native",
        gp=gpar(col = "grey", lwd = 1))
   if (dates.fsubs$dotw[dates.len] != 6) {
   grid.lines(x = c(x.finis + 1, x.finis + 1), 
        y = c(dates.fsubs$dotw[dates.len] -0.5, -0.5), default.units = "native",
        gp=gpar(col = "grey", lwd = 1))
        }
   grid.lines(x = c(x.finis, x.finis), 
        y = c(dates.fsubs$dotw[dates.len] -0.5, -0.5), default.units = "native",
        gp=gpar(col = "grey", lwd = 1))
        }
  for (n in 1:51) {
    grid.lines(x = c(n + 1.5, n + 1.5), 
      y = c(-0.5, 6.5), default.units = "native", gp=gpar(col = "grey", lwd = 1))
          }
  x.start <- adj.start - 0.5
  
  if (y.start > 0) {
    grid.lines(x = c(x.start, x.start + 1),
      y = c(y.start - 0.5, y.start -  0.5), default.units = "native",
      gp=gpar(col = "black", lwd = 1.75))
    grid.lines(x = c(x.start + 1, x.start + 1),
      y = c(y.start - 0.5 , -0.5), default.units = "native",
      gp=gpar(col = "black", lwd = 1.75))
    grid.lines(x = c(x.start, x.start),
      y = c(y.start - 0.5, 6.5), default.units = "native",
      gp=gpar(col = "black", lwd = 1.75))
   if (y.end < 6  ) {
    grid.lines(x = c(x.start + 1, x.finis + 1),
     y = c(-0.5, -0.5), default.units = "native",
     gp=gpar(col = "black", lwd = 1.75))
    grid.lines(x = c(x.start, x.finis),
     y = c(6.5, 6.5), default.units = "native",
     gp=gpar(col = "black", lwd = 1.75))
     } else {
        grid.lines(x = c(x.start + 1, x.finis),
         y = c(-0.5, -0.5), default.units = "native",
         gp=gpar(col = "black", lwd = 1.75))
        grid.lines(x = c(x.start, x.finis),
         y = c(6.5, 6.5), default.units = "native",
         gp=gpar(col = "black", lwd = 1.75))
         }
         } else {
             grid.lines(x = c(x.start, x.start),
              y = c( - 0.5, 6.5), default.units = "native",
              gp=gpar(col = "black", lwd = 1.75))
             }
  
   if (y.start == 0 ) {
    if (y.end < 6  ) {
    grid.lines(x = c(x.start, x.finis + 1),
     y = c(-0.5, -0.5), default.units = "native",
     gp=gpar(col = "black", lwd = 1.75))
    grid.lines(x = c(x.start, x.finis),
     y = c(6.5, 6.5), default.units = "native",
     gp=gpar(col = "black", lwd = 1.75))
     } else {
        grid.lines(x = c(x.start + 1, x.finis),
         y = c(-0.5, -0.5), default.units = "native",
         gp=gpar(col = "black", lwd = 1.75))
        grid.lines(x = c(x.start, x.finis),
         y = c(6.5, 6.5), default.units = "native",
         gp=gpar(col = "black", lwd = 1.75))
         }
         }
  for (j in 1:12)  {
     last.month <- max(dates.fsubs$seq[dates.fsubs$month == j])
     x.last.m <- dates.fsubs$woty[last.month] + 0.5
     y.last.m <- dates.fsubs$dotw[last.month] + 0.5
     grid.lines(x = c(x.last.m, x.last.m), y = c(-0.5, y.last.m),
       default.units = "native", gp=gpar(col = "black", lwd = 1.75))
     if ((y.last.m) < 6) {
        grid.lines(x = c(x.last.m, x.last.m - 1), y = c(y.last.m, y.last.m),
         default.units = "native", gp=gpar(col = "black", lwd = 1.75))
       grid.lines(x = c(x.last.m - 1, x.last.m - 1), y = c(y.last.m, 6.5),
         default.units = "native", gp=gpar(col = "black", lwd = 1.75))
     } else {
        grid.lines(x = c(x.last.m, x.last.m), y = c(- 0.5, 6.5),
         default.units = "native", gp=gpar(col = "black", lwd = 1.75))
      }
   }
   }
   }
  trellis.unfocus()
  } 
  lattice.options(default.theme = def.theme)
}