# Replicating a PlotStyle from Trees, Maps, and Theorems

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. May 30 '18 at 4:57

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.}} & /@
SystemDateListPlotDumpgetTickDates[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,
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"];
dates2 = DateRange[{1990, 1}, DatePlus[{1990, 1}, {36, "Week"}], "Week"];

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 SystemDateListPlotDumpgetTickDates with GraphicsDateListPlotDumpgetTickDates, 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.R. hope the updated version works without issues.
– kglr
May 30 '18 at 7:05

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},
PlotRangeClipping -> False,
Prolog -> {
GrayLevel@0.2,
Line@{{{min, 75}, {min, ts@min}}, {{max, 75}, {max, ts@max}}},
},
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"]
]
]


• 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[...] May 30 '18 at 6:05

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


• @AntonAntonov. Not the same. You didn't take complete control of the placement of the callout and you didn't get the ticks right. 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. May 29 '18 at 18:16
• @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. May 29 '18 at 18: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 ThemesAddThemeRules to define the new theme "TM&T":

ThemesAddThemeRules["TM&T", DateListPlot,
{AspectRatio -> 1, LabelStyle -> 16, Joined -> True,
FrameTicksStyle -> {{Opacity[0], Opacity[1]}, {Automatic, Opacity[1]}},
FrameTicks -> {{None, None},
{SystemDateListPlotDumpgetTickDates[#, #2, 2, 5][[-1, 2]] &, None}},
## & @@ ChartingResolvePlotTheme["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"];
dates2 = DateRange[{1990, 1}, DatePlus[{1990, 1}, {36, "Week"}], "Week"];

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


### May be not so trivial after all

Looking at the comments and questions 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]],
ListPlot[ts["Path"][[{1, -1}]], Filling -> Axis,
Frame -> False]}, ImagePadding -> {{40, 40}, {20, 10}}]
}]]


You can just use Show:

Show[{
DateListPlot[ts, PlotTheme -> "Scientific", PlotStyle -> RGBColor[0.979, 0.670, 0.102]],

Also, see examples in Callout.
• @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. May 29 '18 at 16:36