Replicating a PlotStyle from Trees, Maps, and Theorems

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@[email protected], CapForm@"Round", JoinForm@"Round", RGBColor[0.979, 0.670, 0.102]],
  Frame -> {{False, False}, {True, False}},
  PlotRange -> {75, All},
  PlotRangePadding -> 0,
  PlotRangeClipping -> False,
  Prolog -> {
    [email protected],
    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[[email protected]],
  BaseStyle -> Directive[FontSize -> 18, FontFamily -> "Segoe UI"]
  ]
 ]

Mathematica graphics


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

enter image description here

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

enter image description here

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

enter image description here

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

enter image description here

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}@#]&.


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

plot