# How would I duplicate this plot and table in Mathematica?

I have struggled trying to duplicate this graphic from Spurious correlations using ListLinePlot, but I cannot get the tick options to display the year for every data point. I suspect there is a simple way to display the table, but I don't know where to start

Here is what I have:

y = Range[2000, 2009];
d = {5, 4.7, 4.6, 4.4, 4.3, 4.1, 4.2, 4.2, 4.2, 4.1};
m = {8.2, 7, 6.5, 5.3, 5.2, 4, 4.6, 4.5, 4.2, 3.7};

ListLinePlot [d, PlotStyle -> {ColorData[97, 1]}, ImagePadding -> {{50, 50}, {20, 20}},
AspectRatio -> 1/4, ImageSize -> Large, Axes -> False, BaseStyle -> {FontSize -> 14},
Ticks -> {{2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009}, {4.0, 5.0}},
FrameTicks -> {None, All, None, None},
Frame -> {True, True, False, False}]


• Please show us what you have a tried. Also, check out Column and Grid. – C. E. Apr 29 '18 at 20:44
• Also provide raw data, you should not expect us to manually enter all of the data. – Bob Hanlon Apr 29 '18 at 20:52
• You will also be interested in Plot with multiple Y-axes. – MarcoB Apr 29 '18 at 21:20
• @MarcoB Thanks. That is exactly what I have been trying to do, but I cannot get the x-axis to have a label for every data point, so all the years display properly – Brian Apr 29 '18 at 21:26

{mscale, dscale} = MinMax /@ {m, d}
rescaledm = Rescale[m, mscale, dscale];
mticks =  ChartingFindTicks[dscale, mscale];

DateListPlot[{d, rescaledm}, {2000}, Joined -> True,
FrameTicks -> {{Automatic, mticks}, {DateRange[{2000}, {2009}, "Year"], Automatic}}]


• Very nice and concise – Brian Apr 29 '18 at 22:08
• @Brian, thank you for the accept. – kglr Apr 29 '18 at 22:09
• Why is the last blue data point (for 2009) missing? – Brian Apr 29 '18 at 22:12
• I think the last blue edge is only hidden by the last yellow one. – Henrik Schumacher Apr 29 '18 at 22:14
• @Brian, as Henrik noted, it is there but hidden behind the yellow line. You can try something like PlotStyle->{ Directive[Opacity[.7],Thickness[.02]], Thick} to see both lines. – kglr Apr 29 '18 at 22:17

This might take you closer to you goal:

y = Range[2000, 2009];
d = {5, 4.7, 4.6, 4.4, 4.3, 4.1, 4.2, 4.2, 4.2, 4.1};
m = {8.2, 7, 6.5, 5.3, 5.2, 4, 4.6, 4.5, 4.2, 3.7};
mticks = Range[3, 9];
{scale, shift} = NArgMin[Total[(d - (s m + b))^2], {s, b}];
mscaled = (scale m + shift);
ListLinePlot[
{
Transpose[{y, d}],
Transpose[{y, mscaled}]
},
ImagePadding -> {{50, 50}, {20, 20}},
AspectRatio -> 1/4,
ImageSize -> Large,
BaseStyle -> {FontSize -> 14},
FrameTicks -> {
{Range[4, 5, 0.2], Transpose[{scale mticks + shift, mticks}]},
{y, None}
},
Frame -> {{True, True}, {True, False}},
InterpolationOrder -> 3,
PlotMarkers -> None
]


The format for FrameTicks and Frame is always {{left,right},{bottom,top}}. Note also how you can introduce "fake" ticks on the right hand side with Transpose[{scale mticks + shift, mticks}]: first entry in each sublist is the actual tick position; second entry is what is shown to the beholder.

I was also a bit puzzled that we cannot specify the x-axis' ticks arbitrarily. But the point is that without explicit x-coodinates, ListLinePlot assumes the x-coordinates to run from 1 to 10 for the list d has length 10. So, we actually can enforce that x-ticks are only plotted at positions specified by y = Range[2000, 2009] --- but the ticks will then be way outside the plot range and hence invisible.

• That is great! I get that you need to scale and shift the 'm' data to plot on the same graph as the 'd' data, but I don't understand the mechanics of what line 4 is doing. – Brian Apr 29 '18 at 21:36
• Very nice. Instead of the Minimize, I'd suggest NArgMin[...]` here, which would return the list of optimized parameters directly. The result is the same, of course. – MarcoB Apr 29 '18 at 21:36
• Very good point. Thanks! – Henrik Schumacher Apr 29 '18 at 21:42
• When I run the code in a new notebook, I get this error, and the right side ticks don't display: Transpose::nmtx: The first two levels of {3.30863 +0.201386 mticks,mticks} cannot be transposed. – Brian Apr 29 '18 at 21:55
• Sorry. Fixed it. Please try again. – Henrik Schumacher Apr 29 '18 at 21:58