24
$\begingroup$

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.

| improve this question | |
$\endgroup$
  • 1
    $\begingroup$ I presume you've looked at the source for the page, as well as the source files here for ideas? $\endgroup$ – J. M.'s discontentment♦ Oct 10 '12 at 16:11
  • $\begingroup$ I've checked it out on github, was looking through the java classes... $\endgroup$ – M.R. Oct 10 '12 at 16:16
  • $\begingroup$ 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. $\endgroup$ – DavidC Oct 10 '12 at 16:20
  • $\begingroup$ Tedious… but definitely doable, as others have said. Nothing built-in, though. What have you tried so far? $\endgroup$ – F'x Oct 10 '12 at 16:21
  • 2
    $\begingroup$ This 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? $\endgroup$ – George Wolfe Oct 10 '12 at 16:48
20
$\begingroup$

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

| improve this answer | |
$\endgroup$
  • $\begingroup$ Is it just me or are the days ordered backward? I see each of the sections as calendar pages. (+1 btw) $\endgroup$ – Mr.Wizard♦ Oct 10 '12 at 18:51
  • $\begingroup$ The days are from top to down, and month from left to rigth. $\endgroup$ – Murta Oct 10 '12 at 20:30
  • $\begingroup$ 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.) $\endgroup$ – Mr.Wizard♦ Oct 10 '12 at 20:57
  • $\begingroup$ Oh.. now I get your point! I like this way because it's easy to see week seasonality. $\endgroup$ – Murta Oct 10 '12 at 21:26
  • $\begingroup$ Are you implying that you could not if the days of the week ran from bottom to top in this cart? $\endgroup$ – Mr.Wizard♦ Oct 10 '12 at 21:29
14
$\begingroup$

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

| improve this answer | |
$\endgroup$
  • $\begingroup$ ...and if you don't want to have to load a package just for DayOfWeek[], see this. $\endgroup$ – J. M.'s discontentment♦ Oct 10 '12 at 17:28
  • $\begingroup$ Yes I was just being lazy $\endgroup$ – David Slater Oct 10 '12 at 17:37
3
$\begingroup$

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

| improve this answer | |
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.