Replicating a PlotStyle from Trees, Maps, and Theorems

Question

How might I make a plot with this style, where the callouts are on the side and the y-axes chopped off for a minimal look?

Here's some example data with the callout that I'd like to add, but I'm not sure how to replicate the style with a DateListPlot:

ts = TimeSeries[FinancialData["MSFT", "Jan. 1, 2018"]];
callout = {DateObject[{2018, 3, 12, 0, 0, 0.}, "Instant", 
    "Gregorian", -4.], 96.7699966430664};
DateListPlot[ts, PlotTheme -> "Minimal", PlotStyle->RGBColor[0.979, 0.670, 0.102], 
    Ticks -> {{"Jan 1, 2018", "Mar 1, 2018", "Apr 1, 2018",  "Jun 1, 2018"}}]

This example is from a slide deck of Jean-Luc Doumont which describes his beautifully typeset book, Trees, Maps, and Theorems.

Beautifully typeset as it may be, nevertheless such a graph as the one presented seems very poorly legible to me, and particularly prone to manipulation and misinterpretation, because of the lack of a properly divided vertical axis. — MarcoB, May 30 '18 at 04:57

Lukas Lang · Answer 1 · 2018-05-29T19:19:24.880

Try the following: (if you don't understand what an option does, leave a comment - but please look in the documentation center first)

addCallout[min_, max_, date_, val_, Left] := {Line@{{min, val}, {date, val}}, Text[Pane[Round@val, FrameMargins -> 10], {min, val}, {1, 0}]}
addCallout[min_, max_, date_, val_, Right] := {Line@{{max, val}, {date, val}}, Text[Pane[Round@val, FrameMargins -> 10], {max, val}, {-1, 0}]}

ticks = {"Mar 1, 2018", "Apr 1, 2018"}
(* {"Mar 1, 2018", "Apr 1, 2018"} *)

ts = TimeSeries[FinancialData["MSFT", "Jan. 1, 2018"]];
calloutDate = AbsoluteTime@DateObject[{2018, 3, 12, 0, 0, 0.}, "Instant", "Gregorian", -4.];
With[
 {min = Min@ts["Times"], max = Max@ts["Times"]},
 DateListPlot[
  ts,
  PlotTheme -> "Minimal",
  PlotStyle -> Directive[Thickness@Scaled@0.015, CapForm@"Round", JoinForm@"Round", RGBColor[0.979, 0.670, 0.102]],
  Frame -> {{False, False}, {True, False}},
  PlotRange -> {75, All},
  PlotRangePadding -> 0,
  PlotRangeClipping -> False,
  Prolog -> {
    GrayLevel@0.2,
    Line@{{{min, 75}, {min, ts@min}}, {{max, 75}, {max, ts@max}}},
    addCallout[min, max, calloutDate, ts@calloutDate, Left],
    addCallout[min, max, min, ts@min, Left],
    addCallout[min, max, max, ts@max, Right]
    },
  ImagePadding -> 50,
  FrameTicks -> {
    {None, None},
    {
     {AbsoluteTime@DateObject[#, "Instant"], Pane[DateValue[#, "MonthName"], FrameMargins -> 5], {0.02, 0}} & /@
      Join[ticks, {min, max}],
     None
     }
    },
  FrameStyle -> Directive[GrayLevel@0.2],
  BaseStyle -> Directive[FontSize -> 18, FontFamily -> "Segoe UI"]
  ]
 ]

Mathematica graphics

Thank you for your answer, would it be easy to add multiple callouts from the right as well? — M.R., May 29 '18 at 23:09
@M.R. Yes, just add as many addCallout[min,max,...] lines as you want. The syntax is addCallout[min,max,date,value,dir], where dir is Left or Right. And date should be AbsoluteTime[...] — Lukas Lang, May 30 '18 at 06:05

kglr · Accepted Answer · 2018-05-30T07:46:28.153

ClearAll[tmtDLP]
tmtDLP[sc_ : 4, nt_ : 5, dtick_ : "Year"][data_, left_List, right_List, 
    opts : OptionsPattern[DateListPlot]] := 
  Module[{dt = Join[{data}, {data[[#]]} & /@ Join[left, right]], joined, ticks,
      marked = Join[left, right], min, max, ymin, ymax, dmin, dmax, jldstyle}, 
    {min, max} = MinMax @ data[[All, 2]];
    {dmin, dmax} = MinMax @ (AbsoluteTime /@ data[[All, 1]]);
    ticks = {#, DateString[#, dtick], {.05, 0.}} & /@ 
        System`DateListPlotDump`getTickDates[dmin, dmax, 2, nt][[-1, 2]];
    {ymin, ymax} = {(sc min - max)/(sc - 1), (sc max - min)/(sc - 1)};
    joined = Prepend[ConstantArray[False, Length@marked], True];
    jldstyle = Sequence[PlotRange -> {ymin, ymax}, AspectRatio -> 1, 
        GridLines -> None, LabelStyle -> 16,  PlotRangeClipping -> False, 
        PlotRangePadding -> 0, ImagePadding -> Scaled[.05], 
        PlotStyle -> {Directive[Thick, RGBColor[0.88, 0.61, 0.14]],
          ## & @@ Join @@ (ConstantArray[Directive[PointSize[Large], #], Length@#2] & @@@ 
            Transpose[{{Red, Blue}, {left, right}}])}, 
        FrameStyle -> {{#, #} &@ Directive[Opacity[0], FontOpacity -> 1], 
          {Directive[Gray, FontColor -> Black], Opacity[0]}}, 
        FrameTicks -> {{data[[Prepend[left, 1], 2]], data[[Append[right, -1], 2]]}, 
          {ticks, None}}, 
        Epilog -> {Gray, Thin, 
            Line[{{data[[#, 1]], ymin}, data[[#]]}] & /@ {1, -1}, 
            Line[{{data[[1, 1]], data[[#, 2]]}, data[[#]]}] & /@ left,    
            Line[{{data[[-1, 1]], data[[#, 2]]}, data[[#]]}] & /@ right}];
    DateListPlot[dt, Joined -> joined, opts, jldstyle]]

Examples:

SeedRandom[111]
values = 50 + Accumulate@RandomInteger[{-6, 6}, 37];
dates1 = DateRange[{1990, 1}, DatePlus[{1990, 1}, {36, "Month"}], "Month"];
data1 = Thread[{dates1, values}];
dates2 = DateRange[{1990, 1}, DatePlus[{1990, 1}, {36, "Week"}], "Week"];
data2 = Thread[{dates2, values}];

Row[Framed @ tmtDLP[#][data1, {13}, {28}, ImageSize -> 300] & /@ {2, 5}, Spacer[10]]

Row[Framed @ tmtDLP[#, 4, "MonthNameShort"][data2, {13}, {28}, 
  ImageSize -> 300] & /@ {2, 5}, Spacer[10]]

Add additional labeled points, override some default options, and add additional DateListPlot options:

Row[Framed @ tmtDLP[#][data1, {13}, {26, 28}, 
   ImageSize -> 300, BaseStyle ->  PointSize[Large], 
   PlotStyle -> {Directive[Red, Thick], Green, Blue, Orange}, 
   Filling -> {1 -> {Top, LightBlue}}] & /@ {2, 5}, Spacer[10]]

Row[Framed @ tmtDLP[#, 4, "MonthNameShort"][data2, {13}, {26, 28}, 
   ImageSize -> 300, BaseStyle ->  PointSize[Large], 
   PlotStyle -> {Directive[Red, Thick], Green, Blue, Orange}, 
   Filling -> {1 -> {Top, LightBlue}}] & /@ {2, 5}, Spacer[10]]

Note: This works as is in Version 11.3 on Wolfram Cloud. For version 9 replace System`DateListPlotDump`getTickDates with Graphics`DateListPlotDump`getTickDates, and Minmax with Through[{Min, Max}@#]&.

You might be missing an argument, I'm getting an error when I run this. Append::normal: Nonatomic expression expected at position 1 in Append[10,{0.05,0.}]. @kglr — M.R., May 29 '18 at 23:06

m_goldberg · Answer 3 · 2018-05-29T18:10:54.483

4

Here is some fairly minimal code that might work for you. It makes use of the augmented form of Callout's 3rd argument to control the exact placement of the callout.

ts = TimeSeries[FinancialData["MSFT", "Jan. 1, 2018"]];
calloutX = 
  AbsoluteTime @
    DateObject[{2018, 3, 12, 0, 0, 0.}, "Instant", "Gregorian", -4.]; 
calloutY = 96.77;

DateListPlot[
  Callout[ts, calloutY, {{calloutX, calloutY + 1}, {0, .5}}],
  PlotStyle -> RGBColor[0.979, 0.670, 0.102],
  Frame -> False,
  Ticks -> 
    {{"Jan 1, 2018", "Mar 1, 2018", "Apr 1, 2018", "Jun 1, 2018"}, Automatic}]

edited May 29 '18 at 18:10

answered May 29 '18 at 18:02

m_goldberg

107,779
16
103
257

That was sort of my first answer and people had objects. :) Please see these comments. – Anton Antonov May 29 '18 at 18:10
@AntonAntonov. Not the same. You didn't take complete control of the placement of the callout and you didn't get the ticks right. – m_goldberg May 29 '18 at 18:13
Ah, yeah, I meant "sort of". But still, it is not what it is wanted and it is closer what it was argued against. – Anton Antonov May 29 '18 at 18:16
1

@AntonAntonov. What is wanted is not exactly clear. That's why I wrote "might work for you". Personally, I think your first answer and this one are closer to what the OP needs than some of others. But that's an opinion. – m_goldberg May 29 '18 at 18:19

score 4 · Answer 4 · answered May 30 '18 at 12:19

A completely different approach is to define a custom PlotTheme modifying the built-in theme "Web" with appropriate options (making use of this answer by Mr.Wizard) and use a helper function that constructs the PlotRange and Epilog options settings:

Use the function Themes`AddThemeRules to define the new theme "TM&T":

Themes`AddThemeRules["TM&T", DateListPlot,
  {AspectRatio -> 1, LabelStyle -> 16, Joined -> True, 
   ImagePadding -> Scaled[.05], PlotRangeClipping -> True, PlotRangePadding -> 0, 
   FrameTicksStyle -> {{Opacity[0], Opacity[1]}, {Automatic, Opacity[1]}}, 
   FrameTicks -> {{None, None}, 
     {System`DateListPlotDump`getTickDates[#, #2, 2, 5][[-1, 2]] &, None}},
   ## & @@ Charting`ResolvePlotTheme["Web", DateListPlot]}];

A helper function that constructs the needed lines and labels:

ClearAll[addOpts]
addOpts[df_ : "Year", sc_ : 4,  style_ : 16][d_, left_, right_] := 
  Module[{ymin, ymax, min, max}, {min, max} = MinMax[d[[All, 2]]];
    {ymin, ymax} = {(sc min - max)/(sc - 1), (sc max - min)/(sc - 1)};
    {DateTicksFormat -> {df}, PlotRange -> {ymin, ymax}, 
    Epilog -> {Text[Style[d[[#, 2]], style], 
         Offset[{-5, -1}, {d[[1, 1]], d[[#, 2]]}], Right] & /@ Prepend[left, 1], 
      Text[Style[d[[#, 2]], style], 
         Offset[{5, -1}, {d[[-1, 1]], d[[#, 2]]}], Left] & /@ Prepend[right, -1], 
      Gray, Thin, Line[{{d[[#, 1]], ymin}, d[[#]]}] & /@ {1, -1}, 
      Line[{{d[[1, 1]], d[[#, 2]]}, d[[#]]}] & /@ left, 
      Line[{{d[[-1, 1]], d[[#, 2]]}, d[[#]]}] & /@ right}}];

Examples:

SeedRandom[111]
values = 50 + Accumulate@RandomInteger[{-6, 6}, 37];
dates1 = DateRange[{1990, 1}, DatePlus[{1990, 1}, {36, "Month"}], "Month"];
data1 = Thread[{dates1, values}];
dates2 = DateRange[{1990, 1}, DatePlus[{1990, 1}, {36, "Week"}], "Week"];
data2 = Thread[{dates2, values}];

 Row[{Framed @ DateListPlot[data1, PlotTheme -> "TM&T", 
    addOpts[][data1, {13}, {28}], ImageSize -> 300], 
  Framed @ DateListPlot[data2, PlotTheme -> "TM&T", 
    addOpts["MonthNameShort"][data2, {13}, {26, 28}], 
    ImageSize -> 300, Filling -> Top, PlotStyle -> 97]}, Spacer[10]]

Anton Antonov · Answer 5 · 2018-05-29T17:14:42.047

3

May be not so trivial after all

Looking at the comments and question`s subsequent clarifications this is what I came up with (before giving up going further...):

Framed[ColumnForm[{
   Style["MSFT time series", FontWeight -> "Heavy", FontSize -> 14, 
    FontFamily -> "Helvetica"], 
   Show[{DateListPlot[ts, Filling -> {ts[[1]], ts[[-1]]}, 
      Axes -> {True, False}, Frame -> False, 
      PlotStyle -> RGBColor[0.979, 0.670, 0.102], 
      ImageSize -> Medium], 
     DateListPlot[{Callout[callout, callout[[2]], 
        Appearance -> "Leader"]}],
     ListPlot[ts["Path"][[{1, -1}]], Filling -> Axis, 
      Frame -> False]}, ImagePadding -> {{40, 40}, {20, 10}}]
   }]]

First answer

You can just use Show:

Show[{
 DateListPlot[ts, PlotTheme -> "Scientific", PlotStyle -> RGBColor[0.979, 0.670, 0.102]], 
 DateListPlot[{Callout[callout, callout[[2]], Appearance -> "Leader"]}]
}]

Also, see examples in Callout.

edited May 29 '18 at 17:14

answered May 29 '18 at 16:30

Anton Antonov

37,787
3
100
178

1

that doesn’t look visually at all like what the OP wants (clipped frame, horizontal callout, etc...) – user5601 May 29 '18 at 16:34
1

@user56601 You commented 1 min after I submitted my answer. Also, see my update -- OP desired form can be done with Show, DateListPlot, and Callout. Also, I think the question is trivial, so I voted to be closed. – Anton Antonov May 29 '18 at 16:36
Did you figure out how to clip the frame? – user5601 May 29 '18 at 16:40
@user5601 "Did you figure out how to clip the frame?" -- I am not sure what that means. Can you be more clear? (So, I can figure it out for you...) – Anton Antonov May 29 '18 at 16:46
2

@AntonAntonov I've added a better image to my question showing the two stylistic features of the plot I'd like to capture – M.R. May 29 '18 at 17:12
@M.R. Ok, thanks. I did not realize question's strong emphasis on the stylistic form reproduction. (And I retracted my "to close" vote.) – Anton Antonov May 29 '18 at 17:17

Replicating a PlotStyle from Trees, Maps, and Theorems

5 Answers5

May be not so trivial after all

First answer