2
$\begingroup$

I have a Barchart like this:

data = {{1995, 0.5, 0.2, 0.3}, {1996, 0.4, 0.3, 0.3}, {1997, 0.5, 0.1,
     0.4}, {1998, 0.6, 0.1, 0.3}, {1999, 0.9, 0, 0.1}, {2000, 0.5, 
    0.2, 0.3}, {2001, 0.5, 0.5, 0}, {2002, 0.5, 0.5, 0}, {2003, 0.5, 
    0.5, 0}, {2004, 0.3, 0.7, 0}, {2005, 0.1, 0.9, 0}};
BarChart[data[[All, 2 ;; 4]], ChartLayout -> "Percentile", 
 Frame -> {True, True, False, False}, 
 PlotRange -> {{All, All}, {All, All}}, 
 PlotRangePadding -> {{0, 0.3}, {0, 0}}, 
 PlotLabel -> Style["Label", Black, 18], 
 FrameLabel -> {None, Style["relative share [%]", 14]}, 
 ChartLabels -> {Placed[IntegerPart[data[[All, 1]]], Axis, 
    Rotate[#, Pi/2] &], None}, ChartLegends -> {"1", "2", "3"}, 
 ChartStyle -> {Red, Blue, Green}, BarSpacing -> {0, 1}, 
 LabelStyle -> {FontFamily -> "Arial", 12}, 
 BaseStyle -> {FontFamily -> "Arial", 12}, ImageSize -> {700, 400}]

Now I have some events which occur in specific years like in this timeline:

timeline = 
TimelinePlot[{Labeled[DateObject[{1998}], "Event A"], 
  Labeled[DateObject[{2001}], "Event B"], 
  Labeled[DateObject[{2005}], "Event C"]}]

Now I want to combine theses two plots so that the timeline is under the barchart but it should be well aligned (years in the same position and the callouts below the time axis). Is there a way to do this? Or maybe there is a better solution instead of TimeLinePlot?

$\endgroup$
4
$\begingroup$
  1. To use DateHistogram instead of BarChart (so that the chart and the timeline plot share a common date axis) we construct a list of WeightedData objects:

wd = WeightedData[data[[All, {1}]], data[[All, #]]] & /@ {2, 3, 4};
  1. To use the graphics primitives produced by TimelinePlot as Epilog in DateHistogram we need to modify the vertical scales and positions of primitives. The function translateScale does this job.

ClearAll[translateScale]
translateScale[t_: - .07, s_: .05] := GeometricTransformation[#, 
   TranslationTransform[{0, t}] @* ScalingTransform[{1, s}]] &;

Examples:

timeline = TimelinePlot[{Labeled[DateObject[{1998, 7, 15}], "Event A"], 
    Labeled[DateObject[{2001, 7, 15}], "Event B"], 
    Labeled[DateObject[{2005, 7, 15}], "Event C"]}, 
   AxesOrigin -> Top, PerformanceGoal -> "Speed"];

dh = DateHistogram[wd, "Year", ChartLayout -> "Stacked", 
 ChartStyle -> {Red, Green, Blue}, ImageSize -> Large,
 Ticks -> {AbsoluteTime /@ Thread[{data[[All, 1]], 7, 15}], Automatic}, 
 DateTicksFormat -> {"Year"}, 
 ChartBaseStyle -> Opacity[1], PlotRangeClipping -> False, 
 ImagePadding -> {{Automatic, 50}, {120, 10}}, 
 Epilog -> translateScale[][First @ timeline]]

enter image description here

Add the option PlotLayout -> "Grouped" in timeline and re-evaluate dh to get:

enter image description here

Post-process dh to add spacing between groups:

dh /. RectangleBox[{a_, b_}, {c_, d_}, e_] :> 
  RectangleBox[{a + (c - a)/6, b}, {c - (c - a)/6, d}, e]

enter image description here

$Version

11.3 .0 for Microsoft Windows (64 - bit) (March 7, 2018)

Note: In Version 12.0, change RectangleBox to Rectangle in the replacement rule for modifying spacings.

Update: To rotate date labels, you can use

Ticks -> {{#, Rotate[DateString[#, "Year"], 90 Degree]} & /@ 
   AbsoluteTime /@ Thread[{data[[All, 1]], 7, 15}], Automatic}

and Epilog -> translateScale[-.1][First @ timeline] to get

enter image description here

|improve this answer|||||
$\endgroup$
  • $\begingroup$ that is brilliant, thx! However, after replicating your code, the last row (add spacing between the bars) does not seem to work... $\endgroup$ – M.A. Jan 31 at 6:55
  • $\begingroup$ @M.A., can you post a small example where the replacement rule to change spacings doesn't work? $\endgroup$ – kglr Jan 31 at 7:37
  • $\begingroup$ @M.A., it could be version/OS-related. I am using version 11.3 (windows 10-64bit). $\endgroup$ – kglr Jan 31 at 8:48
  • 1
    $\begingroup$ @M.A., just tried the same example in v12.0 (wolfram cloud). It seems that the only change needed is to replace RectangleBox with Rectangle. $\endgroup$ – kglr Jan 31 at 8:58
  • $\begingroup$ I tried to combine insights form this post here (mathematica.stackexchange.com/questions/183528/…) in order to rotate the ticks. It works but the years are not centered in the middle of the bars but on left side. any idea? $\endgroup$ – M.A. Jan 31 at 13:59

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.