9
$\begingroup$

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?

enter image description here

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

enter image description here

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

$\endgroup$
  • 1
    $\begingroup$ 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. $\endgroup$ – MarcoB May 30 '18 at 4:57
8
$\begingroup$
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}@#]&.

$\endgroup$
  • $\begingroup$ 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 $\endgroup$ – M.R. May 29 '18 at 23:06
  • $\begingroup$ @M.R. hope the updated version works without issues. $\endgroup$ – kglr May 30 '18 at 7:05
11
$\begingroup$

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

$\endgroup$
  • $\begingroup$ Thank you for your answer, would it be easy to add multiple callouts from the right as well? $\endgroup$ – M.R. May 29 '18 at 23:09
  • $\begingroup$ @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[...] $\endgroup$ – Lukas Lang May 30 '18 at 6:05
4
$\begingroup$

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

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

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

enter image description here

$\endgroup$
3
$\begingroup$

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

enter image description here

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

enter image description here

Also, see examples in Callout.

$\endgroup$
  • 1
    $\begingroup$ that doesn’t look visually at all like what the OP wants (clipped frame, horizontal callout, etc...) $\endgroup$ – user5601 May 29 '18 at 16:34
  • 1
    $\begingroup$ @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. $\endgroup$ – Anton Antonov May 29 '18 at 16:36
  • $\begingroup$ Did you figure out how to clip the frame? $\endgroup$ – user5601 May 29 '18 at 16:40
  • $\begingroup$ @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...) $\endgroup$ – Anton Antonov May 29 '18 at 16:46
  • 2
    $\begingroup$ @AntonAntonov I've added a better image to my question showing the two stylistic features of the plot I'd like to capture $\endgroup$ – M.R. May 29 '18 at 17:12

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.