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.
Mathematica Stack Exchange is a question and answer site for users of Wolfram Mathematica. It only takes a minute to sign up.
Sign up to join this communityI 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.
This site has exactly what you want here, already in Mathematica code.
One example here:
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}]]
DayOfWeek[]
, see this.
$\endgroup$
– J. M.'s ennui♦
Oct 10 '12 at 17:28
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}]]]
ArrayPlot[RandomReal[1, {7, 53}], ColorFunction -> "Rainbow"]
to give something similar, although you would need to spend some time getting the details right. $\endgroup$ – DavidC Oct 10 '12 at 16:20