How can I make a heatmap of a days in year?

24

16

I know Mathematica has a ListPlot for time series but does it have a function for visualizing a list of dates as a heat map like this:

enter image description here

This idea is from D3, check it out here.

M.R.

Posted 2012-10-10T16:06:53.847

Reputation: 30 727

1

I presume you've looked at the source for the page, as well as the source files here for ideas?

– J. M.'s ennui – 2012-10-10T16:11:08.143

I've checked it out on github, was looking through the java classes... – M.R. – 2012-10-10T16:16:56.473

I suspect you could adopt ArrayPlot[RandomReal[1, {7, 53}], ColorFunction -> "Rainbow"] to give something similar, although you would need to spend some time getting the details right. – DavidC – 2012-10-10T16:20:03.470

Tedious… but definitely doable, as others have said. Nothing built-in, though. What have you tried so far? – F'x – 2012-10-10T16:21:17.017

I was almost there, but the hard part is getting the divisions right... – M.R. – 2012-10-10T16:26:13.250

After gathering by the month, stacking the matrices should be easy but its not – M.R. – 2012-10-10T16:37:24.520

2This is an odd display. Is its purpose to show values that have a weekly, week of the month, and monthly cycle? So, for example, a particular vertical column shows results for all the Mondays in a particular month, and the bottom row shows the days in the last week of each month? – George Wolfe – 2012-10-10T16:48:24.260

@george Yes, I feel it helps to see the divisions along weeks and months... sort of a birds eye view along all the dimensions... – M.R. – 2012-10-10T16:51:52.933

Use the ArrayPlot[RandomReal[1, {7, 53}], ColorFunction -> f[] ], use Epilog to draw the monthly dividers, and make the outer plot borders invisible. ("He said, with out trying to do it"). I guess the borders are the tricky part. What is your actual data like? – George Wolfe – 2012-10-10T16:58:09.367

Actually, kind of a neat display. – George Wolfe – 2012-10-10T17:05:11.680

RandomDateList[minYear_:1800, maxYear_:2100] := {RandomInteger[{minYear, maxYear}], RandomInteger[{1, 12}], RandomInteger[{1, 31}], RandomInteger[{0, 23}], RandomInteger[{0, 59}], RandomInteger[{0, 59}]}; RandomDates[n_] := Table[RandomDateList[],{n}]; RandomDates[n_, i_, x_] := Table[RandomDateList[i, x],{n}]; – M.R. – 2012-10-10T17:10:47.237

Answers

20

This site has exactly what you want here, already in Mathematica code. One example here: enter image description here

Murta

Posted 2012-10-10T16:06:53.847

Reputation: 23 859

Is it just me or are the days ordered backward? I see each of the sections as calendar pages. (+1 btw) – Mr.Wizard – 2012-10-10T18:51:53.807

The days are from top to down, and month from left to rigth. – Murta – 2012-10-10T20:30:02.103

I know, it just feels backward to me. I wanted to know if anyone else felt the same way. (If you look at each bordered area as though it were a page in a standard wall calendar the days run from right to left.) – Mr.Wizard – 2012-10-10T20:57:49.530

Oh.. now I get your point! I like this way because it's easy to see week seasonality. – Murta – 2012-10-10T21:26:21.813

Are you implying that you could not if the days of the week ran from bottom to top in this cart? – Mr.Wizard – 2012-10-10T21:29:08.400

14

So this generates the heatmap:

<< Calendar`
year = 1990;
yearLen = DaysBetween[{year, 1, 1}, {year, 12, 31}] + 1;
data = RandomReal[1, yearLen];
days = Map[DayOfWeek[{year, 1, #}] &, Range[3, 9]];
day1 = Position[days, DayOfWeek[{year, 1, 1}]][[1, 1]];
dayn = Position[days, DayOfWeek[{year, 12, 1}]][[1, 1]];
Paddata = Join[ConstantArray[100, day1 - 1], data];
Paddata2 = Join[Paddata, ConstantArray[100, 7 - dayn]];
plot1 = ArrayPlot[Partition[Paddata2, 7] // Transpose, ColorFunction -> (If[# == 100, White, Blend[{Green, Yellow, Red}, #]] &),  ColorFunctionScaling -> False, Frame -> False];

enter image description here

The Next step would be to write a function that overlay the month separators as lines. Since I can't load the page above from my work I went ahead and finished writing the code.

This function draws a rectangle given a starting day of the week, the number of days in the month, and an offset:

outline[starting_, totaldays_, offset_] := Module[{fullweeks,extradays},
fullweeks = Floor[(totaldays - (7 - starting + 1))/7];
extradays = totaldays - 7*fullweeks - (7 - starting + 1);
Which[extradays == 0 && starting == 1 ,
Line[{{offset, 7}, {offset, 0}, {offset + fullweeks, 0}, {offset + fullweeks, 7}, {offset + fullweeks, 0}}],
extradays == 0 && starting > 1,
Line[{{offset, 7 - starting + 1}, {offset, 0}, {fullweeks + offset + 1, 0}, {fullweeks + offset + 1, 7}, {offset + 1, 7}, {offset + 1, 7 - starting + 1}, {offset,7 - starting + 1}}],
extradays > 0 && starting == 1,
Line[{{offset, 7}, {offset, 0}, {offset + fullweeks + 1,0}, {offset + fullweeks + 1, 
  7 - extradays}, {offset + fullweeks + 2,7 - extradays}, {offset + fullweeks + 2, 7}, {offset, 7}}],
extradays > 0 && starting > 1,
Line[{{offset, 7 - starting + 1}, {offset,0}, {fullweeks + 1 + offset, 0}, {1 + fullweeks + offset,7 - extradays}, {fullweeks + 2 + offset,7 - extradays}, {fullweeks + 2 + offset, 7}, {offset + 1,7}, {offset + 1, 7 - starting + 1}, {offset, 7 - starting + 1}}]
]
]

And this block of code figures out where to draw each rectangle and plots them

FirstDays =  Map[Position[days, #] &,Map[DayOfWeek[{year, #, 1}] &, Range[1, 12]]] // Flatten;
DaysPerMonth = Join[Map[DaysBetween[{year, #, 1}, {year, # + 1, 1}] &,Range[1, 11]],{31}];
edges = {outline[FirstDays[[1]], 31, 0]};
For[j = 2, j <= 12, j++,
max1 = Max[List @@ edges[[-1, All, All, 1]]];
min1 = Min[Select[List @@ edges[[-1, 1, All]], (#[[1]] == max1) &][[All, 2]]];
If[min1 == 0,
 AppendTo[edges, outline[FirstDays[[j]], DaysPerMonth[[j]], max1]],
 AppendTo[edges, outline[FirstDays[[j]], DaysPerMonth[[j]], max1 - 1]]
];
]
Show[plot1, Graphics[{Thick, edges}]]

enter image description here

David Slater

Posted 2012-10-10T16:06:53.847

Reputation: 1 425

...and if you don't want to have to load a package just for DayOfWeek[], see this.

– J. M.'s ennui – 2012-10-10T17:28:50.170

Yes I was just being lazy – David Slater – 2012-10-10T17:37:59.400

3

Using image processing and trying to keep the code compact. The whole problem is that the genius who devised this chart made the alignments artificially (and IMHO unnecessarily) complicated

dates = Most@NestWhileList[DatePlus[#, 1] &, {1997, 1, 1}, 
                                         Developer`CalendarData[#, "Year"] == 1997 &];
(*random Colors*)
colorOfDay = RandomReal[{0, 1}, Length@dates];
month      = DateString[#, "Month"] & /@ dates;
dayOfWeek  = Developer`CalendarData[#, "DayOfWeekNumber"] & /@ dates;
gb         = GatherBy[Sort@Transpose[{dayOfWeek, month, colorOfDay}], First];

colorMonth[x_] := Image@Array[ .8 Boole@EvenQ[ToExpression@x] &, {10, 10}];
coloredDay[x_] := Image@Array[ List @@ ColorData["TemperatureMap"][x] &, {10, 10}];

m  = Map[colorMonth[#[[2]]] &, gb, {2}];
m1 = Map[coloredDay[#[[3]]] &, gb, {2}];

mm = Max[Length /@ m[[1 ;; #]]] & /@ Range@Length@m /.
                  {52 -> (PadLeft [#, 53, Image[Array[1 &, {10, 10}]]] &),
                   53 -> (PadRight[#, 53, Image[Array[1 &, {10, 10}]]] &)};

ia = ColorNegate@EdgeDetect[       ImageAssemble[(#[[1]]@#[[2]])&/@ Transpose[{mm, m}]], .9];
ib = ImageMultiply[Erosion[ia, 1], ImageAssemble[(#[[1]]@#[[2]])&/@ Transpose[{mm, m1}]]]

Mathematica graphics

Dr. belisarius

Posted 2012-10-10T16:06:53.847

Reputation: 112 848