Chapter 27 #28

Here are data from 1959 to 1995, relating the CO2 levels (in parts per million) on Mauna Loa to mean global temperatures (in degrees Celsius).

data = N[{{1959,16.53,2452},{1960,16.51,2563},{1961,16.5,2577},{1962,16.52,2681},{1963,16.52,2826},{1964,16.7,2989},{1965,16.68,3127},{1966,16.55,3285},{1967,16.58,3399},{1968,16.62,3571},{1969,16.53,3789},{1970,16.55,4064},{1971,16.72,4227},{1972,16.58,4395},{1973,16.56,4633},{1974,16.69,4641},{1975,16.65,4613},{1976,16.72,4880},{1977,16.53,5018},{1978,16.55,5066},{1979,16.55,5348},{1980,16.57,5279},{1981,16.59,5109},{1982,16.56,5069},{1983,16.75,5060},{1984,16.53,5231},{1985,16.51,5404},{1986,16.58,5596},{1987,16.77,5723},{1988,16.74,5947},{1989,16.66,6053},{1990,16.83,6109},{1991,16.78,6178},{1992,16.6,6084},{1993,16.6,6053},{1994,16.73,6199},{1995,16.83,6412}}];
n = Length[data];

xs = Transpose[data][[3]];
xbar = Total[xs] / n
sx = Sqrt[Total[(xs - xbar)^2] / (n - 1)]
zxs = (xs - xbar) / sx;

ys = Transpose[data][[2]];
ybar = Total[ys] / n
sy = Sqrt[Total[(ys - ybar)^2] / (n - 1)]
zys = (ys - ybar) / sy;

r = Total[zxs * zys] / (n - 1)
b1 = r sy / sx
b0 = ybar - b1 xbar

Now let's investigate how good the fit was.

Show[ListPlot[Transpose[{xs, ys}]], Plot[b0 + b1 x, {x, Min[xs], Max[xs]}]]
yhats = b0 + b1 xs;
es = ys - yhats;
ListPlot[Transpose[{xs, es}]]
Histogram[es]

Now let's compute the confidence intervals for the slope and intercept.

se = Sqrt[Total[es * es] / (n - 2)]
seb1 = se / (Sqrt[n - 1] sx)
seb0 = se Sqrt[1 / n + xbar^2 / Total[(xs - xbar)^2]]
tstar = 2.438;
b1 - tstar * seb1
b1 + tstar * seb1
b0 - tstar * seb0
b0 + tstar * seb0

Deformations of Rock

deformerTransp[bound_, curvesToDeform_, pointsToDeform_, matrix_] :=
Manipulate[Graphics3D[{
(* Draw axes. *)
RGBColor[1.0, 0.0, 0.0],
Line[{{bound, 0, 0}, {0, 0, 0}}],
Line[{{-bound, 0, 0}, {-bound/2, 0, 0}}],
RGBColor[0.0, 1.0, 0.0],
Line[{{0, bound, 0}, {0, 0, 0}}],
Line[{{0, -bound, 0}, {0, -bound/2, 0}}],
RGBColor[0.0, 0.0, 1.0],
Line[{{0, 0, bound}, {0, 0, 0}}],
Line[{{0, 0, -bound}, {0, 0, -bound/2}}],
(* Draw the rigid boxes. *)
RGBColor[0.5, 0.5, 0.5],
Line[Map[Function[point, point + {0, -1, 0}], smallBox, {2}]],
Line[Map[Function[point, point + {0, 1, 0} + t velocity], smallBox, {2}]],
(* Draw the points and curves. *)
RGBColor[0.0, 0.0, 0.0],
PointSize[Large],
Point[Map[Function[point, point.Transpose[matrix]], pointsToDeform]],
AbsoluteThickness[2],
Line[Map[Function[curve, curve.Transpose[matrix]], curvesToDeform]]
}], {t, 0, 1}];

smallBox = {{{0,0,0},{0,0,1}},{{0,1,0},{0,1,1}},{{1,0,0},{1,0,1}},{{0,0,0},{0,1,0}},{{0,0,1},{0,1,1}},{{1,0,0},{1,1,0}},{{0,0,0},{1,0,0}},{{0,0,1},{1,0,1}},{{0,1,0},{1,1,0}}, {{1, 1, 1}, {1, 1, 0}}, {{1, 1, 1}, {1, 0, 1}}, {{1, 1, 1}, {0, 1, 1}}};
largeBox = {{{-1,-1,-1},{-1,-1,1}},{{-1,1,-1},{-1,1,1}},{{1,-1,-1},{1,-1,1}},{{1,1,-1},{1,1,1}},{{-1,-1,-1},{-1,1,-1}},{{-1,-1,1},{-1,1,1}},{{1,-1,-1},{1,1,-1}},{{1,-1,1},{1,1,1}},{{-1,-1,-1},{1,-1,-1}},{{-1,-1,1},{1,-1,1}},{{-1,1,-1},{1,1,-1}},{{-1,1,1},{1,1,1}}};
comboBox = Join[smallBox, largeBox];

velocity = {3 / 10, -3 / 10, 3 / 10};
l = {{0, v1 Log[1 + v2] / v2, 0}, {0, Log[1 + v2], 0}, {0, v3 Log[1 + v2] / v2, -Log[1 + v2]}};
deformerTransp[2, smallBox, {}, MatrixExp[t l /. {v1 -> velocity[[1]], v2 -> velocity[[2]], v3 -> velocity[[3]]}]]