How would I duplicate this plot and table in Mathematica?

Question

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

Mathematica graphics

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
@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
Website: http://tylervigen.com/spurious-correlations. Oddly morbid — MCMastery, Apr 30 '18 at 00:10

kglr · Accepted Answer · 2018-04-29T23:02:26.470

8

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

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

edited Apr 29 '18 at 23:02

answered Apr 29 '18 at 21:52

kglr

394,356
18
477
896

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
@HenrikSchumacher I don't think so. The last 'd' value is 4.1, and the last 'm' value is 3.7 – Brian Apr 29 '18 at 22:17
@kglr OK, I get it. Thank you – Brian Apr 29 '18 at 22:20

Henrik Schumacher · Answer 2 · 2018-04-29T21:57:35.400

4

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.

edited Apr 29 '18 at 21:57

answered Apr 29 '18 at 21:28

Henrik Schumacher

106,770
7
179
309

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
Works great, thanks! – Brian Apr 29 '18 at 22:03
You're welcome. – Henrik Schumacher Apr 30 '18 at 07:40

How would I duplicate this plot and table in Mathematica?

2 Answers2