12
$\begingroup$

How to compute the outline of a calendar month like this D3 example.

(D3 is a functional language built on JavaScript developed at Stanford and used by New York Times to deploy interactive graphics.)

days = <| DayRange[DateObject[{2014, 10, 5}], 
     DateObject[{2014, 10, 11}]] // Map[DayName] // 
   MapIndexed [#1 -> First[#2] &] |>

(* <|Sunday -> 1, Monday -> 2, Tuesday -> 3, Wednesday -> 4, 
 Thursday -> 5, Friday -> 6, Saturday -> 7|> *)

Day positions for Oct 2014:

october2014 = <| 
    DayRange[DateObject[{2014, 10, 1}], 
      DateObject[{2014, 10, 31}]] //  
     MapIndexed[#1 -> {days[DayName[#1]], -1 - 
          Quotient[-days[DayName[#1]] + First[#2], 7]} &] |> // 
   Dataset;

Individual day Rectangles give shape to the month though because they overlap the grid looks somewhat ragged:

{october2014[Values, Rectangle[# - {1, 1}, #] & /* RegionBoundary] // 
   Normal,
  october2014[KeyMap[Normal /* (#[[3]] &)]] // Normal // Normal // 
   Map[Text[First[#], Last[#] - {1/2, 1/2}] &] } // Graphics

enter image description here

But how to compute (not only show graphically) the boundary of the month as a whole? 

october2014[Values /* RegionUnion /* RegionBoundary, 
   Rectangle[# - {1, 1}, #] &] // Normal // DiscretizeRegion

enter image description here

The desired answer is a closed Line specified by the corner points of the boundary only. This is a special case of simplifying polyhedral region (currently no answers), but will accept any method.

The correct answer for above is: 

Line[{{0, -5}, {6, -5}, {6, -4}, {7, -4}, {7, 0}, {3,0}, {3, -1}, {0, -1}, {0, -5}}]
Improve this question
$\endgroup$
9
  • 2
    $\begingroup$ seen Lunchtime Playground >> time series as calendar heat map? $\endgroup$ – kglr Oct 1 '14 at 15:21
  • $\begingroup$ I believe you can use this answer of mine to get the outline as a closed Line (just feed the points to Line). $\endgroup$ – rm -rf♦ Oct 1 '14 at 15:34
  • $\begingroup$ @rm-rf, in trying to replicate your answer I can't Import that data: It's a CSV but whose first row is: {"spiel = {{186", " -89}", " {186", " -88}", " {185", " -89}", " \ {187", " -89}", " {186", " -90}", " {186", " "}... Can you post your solution? But see my comment to Juhno below re expected format. $\endgroup$ – alancalvitti Oct 1 '14 at 17:03
  • 1
    $\begingroup$ Such as october2014[Values, {# - {1, 1}, #, # - {0, 1}, # - {1, 0}} &][ Apply[Join] /* Counts /* Select[OddQ] /* Keys /* sort /* Line /* Graphics] $\endgroup$ – Rojo Oct 2 '14 at 1:27
  • 1
    $\begingroup$ Sorry, sort = #[[Last@FindShortestTour[#, DistanceFunction -> ManhattanDistance]]] &; $\endgroup$ – Rojo Oct 2 '14 at 1:28
10
$\begingroup$ 
ClearAll[mpbmdcg,ljr]; 
mpbmdcg[k_]:= Composition[MeshPrimitives[#,k]&, BoundaryMesh, DiscretizeGraphics, Graphics];
ljr = Composition[Line, Join[#, {#[[1]]}]&, Replace[#,Line[{a_,b_}]:>a, {0, Infinity}]&];

poly = First@mpbmdcg[2]@(Rectangle/@(-1+Normal[october2014[Values]]));
fastdesc= FullSimplify[ Reduce[ 
         Region`RegionProperty[Rationalize/@poly, {x, y}, "FastDescription"][[1,2]],{x,y}]]
(*(0 <= x < 3 && -5 <= y <= -1)||(3 <= x <= 6 && -5 <= y <= 0)||(6 <  x <= 7 && -4 <= y <= 0) *)

rectangles = Rectangle@@@(Transpose/@((fastdesc/. And|Or->List)/.  Inequality[a_,__,b_]:>{a,b}));

lines = ljr @ mpbmdcg[1] @ rectangles
(*  Line[{{6., 0.}, {3.,   0.}, {3., -1.}, {0., -1.}, {0., -5.}, 
          {3., -5.}, {6., -5.}, {6.,  4.}, {7., -4.}, {7., 0.}, {6., 0.}}]*)

Original post:

Junho answers the specific question re the outline of the month grid.

Here I make a few minor changes (to remove dependence on the Calendar package by using V9 date/time functions) in ragfield's code (available at LunchTime Playground) which provides a full-fledged calendar heat map.

First few lines on sources:

enter image description here

dayindex = {Sunday -> 1, Monday -> 2, Tuesday -> 3, Wednesday -> 4, 
            Thursday -> 5, Friday -> 6, Saturday -> 7};
monthstart[month_, year_] := DayName[{year, month, 1}] /. dayindex
dayspermonth[month_, year_] := DayCount[{year,month,1},DatePlus[{year, month, 1}, {{1, "Month"}}]]
monthlayout[month_, year_] := Partition[Range[dayspermonth[month, year]], 7, 7, 
                              {monthstart[month, year], 1}, ""]

Generate month grid:

startingweek[month_, year_] := Ceiling[(DayCount[{year, 1, 1}, {year, month, 1}] + 
     monthstart[1, year])/7.0]
monthgrid[month_, year_] := Module[{cd, cds, p1, p2, p3, p4, p5, p6, p7, p8, shift}, 
  shift = startingweek[month, year]; cd = monthlayout[month, year]; 
  cds = Position[cd, x_ /; x != ""]; cds[[All, 2]] = 7 - cds[[All, 2]];
  cds[[All, 1]] = cds[[All, 1]] - 1 + shift; 
  p1 = {shift, cds[[1, 2]] + 1}; p2 = {shift, 0}; 
  p3 = {Max[cds[[All, 1]]], 0}; p4 = Last[cds]; 
  p5 = Last[cds] + {1, 0}; p6 = {p5[[1]], 7}; p7 = {shift + 1, 7}; 
  p8 = p1 + {1, 0}; 
  Graphics[{FaceForm[], EdgeForm[Gray], Rectangle[#] & /@ cds, Thick, 
    Line[{p1, p2, p3, p4, p5, p6, p7, p8, p1}]}]]

Labeled[Show[monthgrid[10, 2014]], 
 Style[DateString[{2014, 10}, {"MonthName", " ", "Year"}], "Section",  Purple], Top]

enter image description here

Generate year grid:

yeargrid[year_, opts : OptionsPattern[Show]] := Show[Table[monthgrid[i, year], {i, 1, 12}], opts]

Column[Labeled[yeargrid[#, ImageSize -> 500], Style[#,"Subsection"], Top] & /@ {2012, 2013, 2014}]

enter image description here

Use with data:

year = 2013; stock = "AAPL";
bg = yeargrid[year];
price = FinancialData[stock, {{year, 1, 1}, {year, 12, 31}}];
DateListPlot[price, Filling -> Axis, Joined -> True, 
 PlotLabel -> stock <> " " <> ToString[year]]

enter image description here

Some preps:

(* color the data *)
colors = Blend[{Green, Red}, #] & /@ Rescale[price[[All, 2]]];

(* calculate xy postion for the each date *)
rectposition[{y_, m_, d_}] := Module[{lx, ly}, 
  lx = Ceiling[(DayCount[{y, 1, 1}, {y, m, d}] + monthstart[1, y])/7.0]; 
          ly = 7 - DayName[{y, m, d}] /. dayindex; {lx, ly}]

(* generate legend *)
q = DensityPlot[x, {x, 0, 1}, {y, 0, 0.1}, AspectRatio -> Automatic, 
   FrameTicks -> None, ColorFunction -> (Blend[{Green, Red}, #] &), 
   PlotRangePadding -> None];
l = Show[q, ImageSize -> 200, Frame -> True, 
   FrameTicks -> {{None, None}, {{{0, Min[price[[All, 2]]]}, 
                   {1, Max[price[[All, 2]]]}},  None}}];

(* generate label *)
lt = Graphics[{Text[Style[#[[1]], Medium, Black], {-1, 7 - #[[2]] + 0.5}]} & /@ dayindex];

... final steps:

cq = Table[{FaceForm[colors[[i]]], 
    Rectangle[rectposition[price[[i, 1]]]]}, {i, 1, Length[price]}];
sg = Graphics[{EdgeForm[], cq}];

Show[lt, sg, bg, 
 PlotLabel -> Style[stock <> " " <> ToString[year], "Section"],
 Frame -> True, Frame -> True, FrameTicks -> None,
 FrameStyle -> Directive[White], FrameLabel -> l, ImageSize -> 1000]

enter image description here

Improve this answer
$\endgroup$
4
  • $\begingroup$ @kguler, In March 2013 there are only 7 corner points, but your algorithm outputs 8. Is it a simple matter of taking Union of the p1 ...p8 in monthgrid? $\endgroup$ – alancalvitti Oct 3 '14 at 3:52
  • $\begingroup$ @alan, Union is a good idea. But I think Junho's solution is more robust and straightforward. As is ljr works when fastdesc terms are all Inequalitys; it needs more work to account for other patterns in fastdesc. $\endgroup$ – kglr Oct 3 '14 at 7:31
  • $\begingroup$ @kguler, on review, 8 points are generally distinct but 1 may not be a corner point (eg 1 or 2 months in any given year), then Union would not delete the non-corner point. $\endgroup$ – alancalvitti Oct 4 '14 at 17:58
  • 2
    $\begingroup$ Packaged your code: github.com/kmisiunas/PlotCalendar $\endgroup$ – Karolis Dec 28 '16 at 23:19
5
$\begingroup$

This is your codes.

days = <|DayRange[DateObject[{2014, 10, 5}], 
      DateObject[{2014, 10, 11}]] // Map[DayName] // 
    MapIndexed[#1 -> First[#2] &]|>;
october2014 = <|
    DayRange[DateObject[{2014, 10, 1}], DateObject[{2014, 10, 31}]] //
      MapIndexed[#1 -> {days[DayName[#1]], -1 - 
          Quotient[-days[DayName[#1]] + First[#2], 7]} &]|> // 
   Dataset;

I made RectangleRegionSimplify like this as referred to here

lastUnion[coo_] := 
 Flatten[Replace[SplitBy [ coo, Last], {f_, ___, l_} -> {f, l}, 1], 1]
firstUnion[coo_] := 
 Flatten[Replace[SplitBy [ coo, First], {f_, ___, l_} -> {f, l}, 1], 1]
RectangleRegionSimplify[p__] := Module[{pts, rst},
  pts = MeshPrimitives[
     BoundaryDiscretizeRegion[
      DiscretizeRegion[RegionUnion@p], MaxCellMeasure -> \[Infinity]],
      2][[1, 1]];
  rst = Append[pts, First[pts]];
  rst = N[Rationalize[Chop[rst, 10^-6]], 5];
  rst // firstUnion // lastUnion // Rationalize // N // Line
  ]

Now you can check your code with this.

pri = MeshPrimitives[
   october2014[Values, Rectangle[# - {1, 1}, #] &] // Normal // 
    BoundaryDiscretizeGraphics, 2];
pri1 = RectangleRegionSimplify[pri]
pri2 = october2014[KeyMap[Normal /* (#[[3]] &)]] // Normal // Normal //
    Map[Text[First[#], Last[#] - {1/2, 1/2}] &];
Graphics[{pri1, PointSize[Large], Red, Point @@ pri1, pri2}]

Line[{{3., -1.}, {0., -1.}, {0., -5.}, {6., -5.}, {6., -4.}, {7., \ -4.}, {7., 0.}, {3., 0.}, {3., -1.}}]

Blockquote

Improve this answer
$\endgroup$
5
  • $\begingroup$ "...compute (not only show graphically)...". Output should be Line[{p1,...,pn}] where pk are the calendar's corner points only. $\endgroup$ – alancalvitti Oct 1 '14 at 17:00
  • $\begingroup$ That yields the entire grid of lines. The correct answer is: Line[{{0, -5}, {6, -5}, {6, -4}, {7, -4}, {7, 0}, {3, 0}, {3, -1}, {0, -1}, {0, -5}}]. $\endgroup$ – alancalvitti Oct 1 '14 at 17:26
  • $\begingroup$ Your latest edit still has too many points, eg: {..., {2., -1.}, {1., -1.},...} $\endgroup$ – alancalvitti Oct 1 '14 at 17:56
  • $\begingroup$ @alancalvitti Would you check the answer. $\endgroup$ – Junho Lee Oct 2 '14 at 4:13
  • $\begingroup$ +1, your method tests ok on all months in 2014, thanks. I also tested by deleting an "internal" day 2014-10-14, which broke: MeshPrimitives::cnorep: There is no simple cell representation for the specified cells of the BoundaryMeshRegion. That's fine as it's not a real calendar month, but I would like to investigate further & compare to kguler. $\endgroup$ – alancalvitti Oct 2 '14 at 20:10
2
$\begingroup$

Perhaps instead of building the rectangles you can build lines, and only keep the vertices that appear an odd number of times? Such as 

sort = #[[Last@FindShortestTour[#, DistanceFunction -> ManhattanDistance]]] &
october2014[Values, {# - {1, 1}, #, # - {0, 1}, # - {1, 0}} &][ 
   Apply[Join] /* Counts /* Select[OddQ] /* Keys /* sort /* Line /* Graphics]
Improve this answer
$\endgroup$
3
  • $\begingroup$ Sorry, can't build a more proper answer now $\endgroup$ – Rojo Oct 3 '14 at 14:30
  • $\begingroup$ How is this not a proper answer? $\endgroup$ – Mr.Wizard Oct 3 '14 at 15:19
  • $\begingroup$ @Mr.Wizard, well, its a copy paste of a comment, it isn't self contained, it isn't tuned to my satisfaction (perhaps one could avoid FindShortestTour, and its sandwiched between intimidating long and good looking answers $\endgroup$ – Rojo Oct 3 '14 at 20:01
2
$\begingroup$

Here's a method inspired by Rojo's that uses VectorAngle to select corner points, based on their angle with adjoining points along the boundary. This avoids the traveling salesman.

Generalizing to any month:

days = <|Sunday -> 1, Monday -> 2, Tuesday -> 3, Wednesday -> 4, Thursday -> 5, Friday -> 6, Saturday -> 7|>;

. 

daySpan[DateObject[{y_, m_}]] := 
      DayRange[{y, m}, DatePlus[{y, m}, {1, "Month"}]] // Drop[#, -1] &;

.

dayPositionAssociation[DateObject[{y_, m_}]] := daySpan[DateObject[{y, m}]] // 
    MapIndexed[#1 -> {days[DayName[#1]], -1 - 
         Quotient[First[#2] - days[DayName[#1]], 7]} &] // Association;

.

dayRegion[p_List] := 
      MeshRegion[{p, p - {1, 0}, p - {1, 1}, p - {0, 1}}, Polygon[{1, 2, 3, 4}]];

Given neighboring points {p,q,r} along the boundary, VectorAngle[p-q,q-r] is either 0 or Pi/2. The list of MeshCoordinates needs to be wrapped cyclically:

   selectCornerPoints[pts_List] :=  Prepend[pts, Last@pts] // Append[#, First@pts] & // 
     Partition[#, 3, 1] & // 
    Select[ VectorAngle[#[[2]] - #[[1]], #[[3]] - #[[2]]] != 0 &] // 
   Map[#[[2]] &];

Oct 2014: 

boundaryPts = dayPositionAssociation[DateObject[{2014, 10}]] // Map[dayRegion] // 
    Values // RegionUnion // MeshCoordinates // Round;

. 

boundaryPts // selectCornerPoints
(* {{0, -5}, {0, -1}, {3, -1}, {3, 0}, {7, 0}, {7, -4}, {6, -4}, {6, -5}} *)

2014 outline

 Table[m -> (dayPositionAssociation[DateObject[{2014, m}]] // 
             Map[dayRegion] // Values // RegionUnion // 
          MeshCoordinates // Round // 
        selectCornerPoints // {Gray, Polygon[#], PointSize -> 0.05, 
         Red, Map[Point, #]} & // Graphics),
   {m, 1, 12}] // Partition[#, 3] & // Grid

enter image description here

Improve this answer
$\endgroup$
1
$\begingroup$

Some really great answers. Mine is not as flashy but it took me a few hours to get it so I'm throwing it up nevertheless.

I focused on making one month with the hope that I could make a month function and find a way to merge months together for a longer calendar (haven't gotten that far, yet).

I've also gone the route of creating an item function for the days. this was first to make the code easier to read but then I realised that if I make the month a function that you could pass in your own item function. That seems cool. Although I don't know if it will work considering the item function references a few variables that would be in the function.

Some issues are that the shape is resizeable in the final grid. I don't know how to turn that off. Also, the frame disappears when the items are wrapped in a Tooltip; don't know it that is a bug. I also don't know how I'm going to get the month border sorted as yet. Is there such a thing as a frame function? Maybe I'll try something with MapIndexed.

Well, enough chatter. Here is what I have. Oh, I'm on version 10.0.1

Update: Noticed and fixed a bug + , thanks to Pickett, fixed frame and resizing

month = {2014, 10};
days = {Sunday, Monday, Tuesday, Wednesday, Thursday, Friday, 
   Saturday};
lastDay = 
  QuantityMagnitude@
    DateDifference[month, DatePlus[month, {1, "Month"}], "Day"];
startWeekday = (Flatten@
     Position[True]@Map[DayMatchQ[month, #] &, days])[[1]];
weekCount = Quotient[(startWeekday - 9) + lastDay, 7] + 2;
dayPositions =(*day,weekday,week*)
  {#, Mod[# + startWeekday - 1 - Quotient[#, 7]*7  , 7] /. {0 -> 7},
     Quotient[(startWeekday - 9) + #, 7] + 2
     } & /@ Range[lastDay];
calendarTable = Table[Null, {weekdays, 7}, {weeks, weekCount}];

Clear[itemFunction];
itemFunction := (calendarTable[[#2, #3]] =
    Item[
     Tooltip[
      Graphics[{ColorData["DarkRainbow"][Rescale[#1, {1., lastDay}]], 
        Disk[]}],
      #1],
     Frame -> True, FrameStyle -> Gray]
   ) &

Apply[itemFunction, dayPositions, {1}];

Deploy@Grid[calendarTable, Spacings -> 0, ItemSize -> 5]

That's all, folks.

Edmund

enter image description here

Improve this answer
$\endgroup$
2
  • 1
    $\begingroup$ +1, regarding two of your question: You can make the graphics not resizable using Deploy. Add it in front of Grid, Deploy@Grid[.... Item is supposed to be the outermost head in the expression inside the grid, if it isn't things can break. If you put Tooltip around Graphics instead the frame is still visible. $\endgroup$ – C. E. Oct 3 '14 at 1:39
  • $\begingroup$ @Pickett Thanks! I noticed a bug in the above as well that I am trying to sort out. $\endgroup$ – Edmund Oct 3 '14 at 2:10

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.