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

Question

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:

This idea is from D3, check it out here.

Answer 1

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

Answer 2

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];

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}]]

Answer 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}]]]