25

I'm using Paul Bleicher's Calendar Heatmap to visualize some events over time and I'm interested to add black-and-white fill patterns instead of (or on top of) the color coding to increase the readability of the Calendar Heatmap when printed in black and white.

Here is an example of the Calendar Heatmap look in color,

Calendar Heatmap color

and here is how it look in black and white,

Calendar Heatmap black and white

it gets very difficult to distinguish between the individual levels in black and white.

Is there an easy way to get R to add some kind of patten to the 6 levels instead of color?

Code to reproduce the Calendar Heatmap in color.

source("http://blog.revolution-computing.com/downloads/calendarHeat.R")

stock <- "MSFT"
start.date <- "2012-01-12"
end.date <- Sys.Date()

quote <- paste("http://ichart.finance.yahoo.com/table.csv?s=", stock, "&a=", substr(start.date,6,7), "&b=", substr(start.date, 9, 10), "&c=", substr(start.date, 1,4), "&d=", substr(end.date,6,7), "&e=", substr(end.date, 9, 10), "&f=", substr(end.date, 1,4), "&g=d&ignore=.csv", sep="")
stock.data <- read.csv(quote, as.is=TRUE)

# convert the continuous var to a categorical var 
stock.data$by <- cut(stock.data$Adj.Close, b = 6, labels = F)

calendarHeat(stock.data$Date, stock.data$by, varname="MSFT Adjusted Close")

update 02-13-2013 03:52:11Z, what do I mean by adding a pattern,

I envision adding a pattern to the individual day-boxes in the Calendar Heatmap as pattern is added to the individual slices in the pie chart to the right (B) in this plot,

new-features.html#patterns

found here something like the states in this plot.

Eric Fail
  • 8,191
  • 8
  • 72
  • 128
  • What do you mean by adding a pettern? You want to change the size of cells? do you want to add text in some cells? – agstudy Feb 22 '13 at 03:06
  • you could in theory overwrite the lattice panel function to use `gridExtra::grid.pattern` instead of `grid.rect`. But it's unlikely to work well as this function is buggy – baptiste Feb 22 '13 at 03:51
  • @agstudy, thank you for your question. I added an update to clarify, but I like your idea of adding a letter or something like it to the individual day-box. Regardless, I initially envisioned some sort of pattern like I have described in the update. – Eric Fail Feb 22 '13 at 03:55
  • @baptiste, I looked in the `calendarHeat` function, but couldn't see `grid.rect` used. Would you please explain how I can replace `grid.rect` by `gridExtra::grid.pattern`. Thanks. – Eric Fail Feb 22 '13 at 04:02
  • `calendarHeat` uses `lattice::levelplot`, for which the default panel function is `panel.levelplot`, and in there you will find `grid.rect`. Unfortunately `grid.pattern` doesn't seem to like something in the way x and y units that were passed to `grid.rect` (that's what I mean by buggy...) – baptiste Feb 22 '13 at 04:11
  • 1
    adding a letter or a point symbol may be a much better idea; for this too you should write a custom panel function. BTW, why the ggplot2 tag? – baptiste Feb 22 '13 at 04:12
  • @baptiste, thanks for the follow up. Writing a custom panel function is a bit more then I can handle at the moment, but hopefully someone have an answer that will solve it. Else I'll have to learn to write a panel function. I added the ggplot2 tag as I have seen this plot made with ggplot2, [here](http://blog.revolutionanalytics.com/2009/11/charting-time-series-as-calendar-heat-maps-in-r.html?cid=6a010534b1db25970b0120a64f4aa1970b#comment-6a010534b1db25970b0120a64f4aa1970b), and I thought someone might suggestion a ggplot2-solution. – Eric Fail Feb 22 '13 at 04:19
  • @EricFail customizing a panel function is easy, but I don't like the way this question is asked. It would be better to do something from scratch using levelplot and a custom panel with teh panel and not customzing the calendarHeat function... – agstudy Feb 22 '13 at 04:23
  • are you considering svg as a possible output format? Using the gridSvg package and/or some postprocessing one could potentially use the native svg support of fill patterns – baptiste Feb 24 '13 at 00:57
  • @baptiste, I hadn't thought about that. I guess that could work. If nothing else I could make a `system()` call to transform the svg to a PDF. – Eric Fail Feb 25 '13 at 00:54

3 Answers3

16

I answered this question before he becomes a bounty. It looks like the OP find my previous answer a little bit complicated. I organized the code in a single gist here. you need just to download the file and source it.

I create new function extra.calendarHeat which is an extension of the first one to draw hetmap of double time series.(dat,value1,value2). I addedthis new parameters:

   pch.symbol : vector of symbols , defualt 15:20
   cex.symbol : cex of the symbols , default = 2
   col.symbol : color of symbols , default #00000044
   pvalues    : value of symbols

Here some examples:

## I am using same data 
stock <- "MSFT"
start.date <- "2012-01-12"
end.date <- Sys.Date()
quote <- paste("http://ichart.finance.yahoo.com/table.csv?s=",
               stock,
               "&a=", substr(start.date,6,7),
               "&b=", substr(start.date, 9, 10),
               "&c=", substr(start.date, 1,4), 
               "&d=", substr(end.date,6,7),
               "&e=", substr(end.date, 9, 10),
               "&f=", substr(end.date, 1,4),
               "&g=d&ignore=.csv", sep="")             
stock.data <- read.csv(quote, as.is=TRUE)

p1 <- extra.calendarHeat(dates= stock.data$Date, values = stock.data$Adj.Close,
                         pvalues = stock.data$Volume,
                         varname="W&B MSFT Adjusted Close 
                                  \n Volume as no border symbol ")

enter image description here

## multiply symbols
p2 <- extra.calendarHeat(dates= stock.data$Date, values = stock.data$Adj.Close,
                         pvalues = stock.data$Volume,
                         varname="W&B MSFT Adjusted Close \n 
                                    black Volume as multiply symbol ",
                         pch.symbol = c(3,4,8,9),
                         col.symbol='black')

enter image description here

## circles symbols
p3 <- extra.calendarHeat(dates= stock.data$Date, values = stock.data$Adj.Close,
                         pvalues = stock.data$Volume,
                         varname="W&B  MSFT Adjusted Close \n blue Volume as circles",
                         pch.symbol = c(1,10,13,16,18),
                         col.symbol='blue')

enter image description here

## triangles  symbols
p4 <- extra.calendarHeat(dates= stock.data$Date, values = stock.data$Adj.Close,
                         pvalues = stock.data$Volume,
                         varname="W&B MSFT Adjusted Close \n red Volume as triangles",
                         pch.symbol = c(2,6,17,24,25),
                         col.symbol='red')

enter image description here

p5 <- extra.calendarHeat(dates= stock.data$Date, values = stock.data$Adj.Close,
                         varname="MSFT Adjusted Close",
                         pch.symbol = LETTERS,
                         col.symbol='black')

enter image description here

# symbols are LETTERS
p6 <- extra.calendarHeat(dates= stock.data$Date, values = stock.data$Adj.Close,
                         pvalues = stock.data$Volume,
                         varname="MSFT Adjusted Close  \n Volume as LETTERS symbols",
                         pch.symbol = letters,
                         color='r2b')

enter image description here

agstudy
  • 119,832
  • 17
  • 199
  • 261
  • 1
    this is really impressive. I'll keep the bounty going for a little longer and then award it. I really appreciate that you put all your code in _one place_. Thanks! – Eric Fail Feb 25 '13 at 01:28
  • @EricFail thakns for choosing this answer. just I am curious you will use it in which context? – agstudy Feb 28 '13 at 00:35
  • I am tracking client contacts in a clinic. We have a range of different contact types and tests that we need to keep an eye on and we only have access to a black and white laser printer–or a black and grey-tones printer. Again, I appreciate your help. – Eric Fail Feb 28 '13 at 06:00
  • @EricFail client? do you mean patient, isn't? Whatever, did you test it on you real data? – agstudy Feb 28 '13 at 06:04
  • My understanding is that 'patient' is predominately used for people receiving medical treatment. Whereas 'client' is used for people who are receiving social services (e.g. psychological services), but can also be used about a person receiving medical services. Some people use the terms interchangeably, and I don't think that is necessarily wrong (talk about detour). I'm testing it on the real data sometime within the next two weeks, but I'm quite sure it will work as I've planned. – Eric Fail Feb 28 '13 at 06:13
  • 1
    @EricFail thanks for the explanation client/patient. My confusing because the 2 terms exist in French. Whatever, glad that I this helps. – agstudy Feb 28 '13 at 06:16
  • Hello! Can this be applied to a `ggplot2` `geom_bar` object (or any other `geom_` instance)? –  Feb 07 '14 at 22:52
  • Using symbols and letters appears to be only a work around. The question was about fill pattern like the following http://www.andypope.info/charts/patternfills.htm – user3072843 Nov 09 '18 at 10:35
12

You can panel.level.plot from latticeExtra to add pattern. I think the question as it is asked is a little bit specific. So I try to generalize it. The idea is to give the steps to transform a time series to a calendar heatmap: with 2 patterns (fill color and a shape). We can imagine multiple time series (Close/Open). For example, you can get something like this

enter image description here

or like this, using a ggplot2 theme:

enter image description here

The function calendarHeat , giving a single time series (dat,value) , transforms data like this :

   date.seq value dotw woty   yr month seq
1 2012-01-01    NA    0    2 2012     1   1
2 2012-01-02    NA    1    2 2012     1   2
3 2012-01-03    NA    2    2 2012     1   3
4 2012-01-04    NA    3    2 2012     1   4
5 2012-01-05    NA    4    2 2012     1   5
6 2012-01-06    NA    5    2 2012     1   6

So I assume that I have data formated like this, otherwise, I extracted from calendarHeat the part of data transformation in a function(see this gist)

 dat <- transformdata(stock.data$Date, stock.data$by)

Then the calendar is essentially a levelplot with custom sacles , custom theme and custom panel' function.

library(latticeExtra)
levelplot(value~woty*dotw | yr, data=dat, border = "black",
          layout = c(1, nyr%%7),
          col.regions = (calendar.pal(ncolors)),
          aspect='iso',
          between = list(x=0, y=c(1,1)),
          strip=TRUE,
          panel = function(...) {
            panel.levelplot(...)
            calendar.division(...)  
            panel.levelplot.points(...,na.rm=T,
                                   col='blue',alpha=0.5,
                                   ## you can play with cex and pch here to get the pattern you      
                                   ## like
                                   cex =dat$value/max(dat$value,na.rm=T)*3
                                   pch=ifelse(is.na(dat$value),NA,20),
                                   type = c("p"))

          },
          scales= scales,
          xlim =extendrange(dat$woty,f=0.01),
          ylim=extendrange(dat$dotw,f=0.1),
          cuts= ncolors - 1,
          colorkey= list(col = calendar.pal(ncolors), width = 0.6, height = 0.5),
          subscripts=TRUE,
          par.settings = calendar.theme)

Where the scales are:

 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 =1),
   y=list(
     at = c(0, 1, 2, 3, 4, 5, 6),
     labels = c("Sunday", "Monday", "Tuesday", "Wednesday", "Thursday",
                "Friday", "Saturday"),
     alternating = 1,
     cex =1,
     tck=0))

And the theme is setting as :

 calendar.theme <- list(
   xlab=NULL,ylab=NULL,
   strip.background = list(col = "transparent"),
   strip.border = list(col = "transparent"),
   axis.line = list(col="transparent"),
   par.strip.text=list(cex=2))

The panel function uses a function caelendar.division. In fact, the division of the grid(month black countour) is very long and is done using grid package in the hard way (panel focus...). I change it a little bit, and now I call it in the lattice panel function: caelendar.division.

agstudy
  • 119,832
  • 17
  • 199
  • 261
7

We can use ggplot2's scale_shape_manual to get us shapes that appear close to shading, and we can plot these over the grey heatmap.
Note: This was adapted from @Jay's comments in the original blog posting for the calendar heatmap

# PACKAGES
library(ggplot2)
library(data.table)

# Transofrm data
stock.data <- transform(stock.data,
  week = as.POSIXlt(Date)$yday %/% 7 + 1,
  month = as.POSIXlt(Date)$mon + 1,
  wday = factor(as.POSIXlt(Date)$wday, levels=0:6, labels=levels(weekdays(1, abb=FALSE)), ordered=TRUE),
  year = as.POSIXlt(Date)$year + 1900)

# find when the months change
#   Not used, but could be 
stock.data$mchng <- as.logical(c(0, diff(stock.data$month)))

# we need dummy data for Sunday / Saturday to be included.
#  These added rows will not be plotted due to their NA values
dummy <- as.data.frame(stock.data[1:2, ])
dummy[, -which(names(dummy) %in% c("wday", "year"))] <- NA
dummy[, "wday"] <- weekdays(2:3, FALSE)
dummy[, "mchng"] <- TRUE
rbind(dummy, stock.data) -> stock.data

# convert the continuous var to a categorical var 
stock.data$Adj.Disc <- cut(stock.data$Adj.Close, b = 6, labels = F)

# vals is the greyscale tones used for the outer monthly borders
vals <- gray(c(.2, .5))

# PLOT
  # Expected warning due to dummy variable with NA's: 
  # Warning message:
  # Removed 2 rows containing missing values (geom_point). 
ggplot(stock.data) + 
  aes(week, wday, fill=as.factor(Adj.Disc), 
      shape=as.factor(Adj.Disc), color=as.factor(month %% 2)) + 
  geom_tile(linetype=1, size=1.8) + 
  geom_tile(linetype=6, size=0.4, color="white") + 
  scale_color_manual(values=vals) +
  geom_point(aes(alpha=0.2), color="black") + 
  scale_fill_grey(start=0, end=0.9) +  scale_shape_manual(values=c(2, 3, 4, 12, 14, 8)) + 
  theme(legend.position="none")  +  labs(y="Day of the Week") +  facet_wrap(~ year, ncol = 1)

enter image description here

Ricardo Saporta
  • 54,400
  • 17
  • 144
  • 178