Exercise 5.2 Solutions

1b.

data = {{-3, -1}, {-1, 25}, {1, 25}, {3, 
            1}};

n = Length[data]

TableForm[data]

g1 = 
        ListPlot[data, PlotStyle -> {Red, PointSize[0.02]}];

quad = LeastSqPoly[data, 2]

predictedys = quad /. x -> Transpose[data][[1]]

g2 = Plot[quad, {x, -3, 3}];

Show[g1, g2];

e2f[actual_, predicted_] := 
      Sqrt[Apply[Plus, (actual - predicted)^2]/Length[actual]]

e2f[Transpose[data][[2]], predictedys]

3.

data = {{1, 0.6}, {2, 1.9}, {3, 4.3}, {4, 7.6}, {5, 
            12.6}};

TableForm[data]

g1 = 
        ListPlot[data, PlotStyle -> {Red, PointSize[0.02]}];

xs = Transpose[data][[1]]

ys = Transpose[data][[2]]

n = Length[data]

(a)

newys = Log[ys]

newdata = Transpose[{xs, newys}]

ListPlot[newdata, PlotStyle -> {PointSize[0.02]}];

Regression[newdata]

Exp[-1.0123]

g2 = 
        Plot[Exp[-1.0123] Exp[0.747534 x], {x, 0, 5}, 
          PlotStyle -> {Blue}];

Show[g1, g2]

predictedys = 
      Exp[-1.0123] Exp[0.747534 x] /. x -> xs

e2f[ys, predictedys]

(b)

newxs = Log[xs]

newdata = Transpose[{newxs, newys}]

ListPlot[newdata, PlotStyle -> {PointSize[0.02]}];

Regression[newdata]

g3 = 
        Plot[Exp[- .575507] x^1.88596, {x, 0, 5}, 
          PlotStyle -> {Black}];

Show[g1, g3]

predictedys = Exp[- .575507] x^1.88596 /. x -> xs

e2f[ys, predictedys]

(c)

Show[{g1, g2, g3}];

5.

datai = {{-1, 13.45}, {0, 3.01}, {1, 0.67}, {2, 
            0.15}};

dataii = {{-1, 13.65}, {0, 1.38}, {1, 0.49}, {3, 
            0.15}};

gdatai = 
        ListPlot[datai, PlotStyle -> {Red, PointSize[0.02]}];

gdataii = 
        ListPlot[dataii, PlotStyle -> {Green, PointSize[0.02]}];

Show[{gdatai, gdataii}];

(a)

dataiysa = Log[Transpose[datai][[2]]]

newdataia = 
      Transpose[{Transpose[datai][[1]], dataiysa}]

ListPlot[newdataia, PlotStyle -> {PointSize[0.02]}];

Regression[newdataia]

gpreddataia = 
        Plot[Exp[1.10037] Exp[-1.49907 x], {x, -1, 3}, 
          PlotStyle -> {Blue}];

predicteddataiys = 
      Exp[1.10037] Exp[-1.49907 x] /. 
        x -> Transpose[datai][[1]]

e2f[Transpose[datai][[2]], predicteddataiys]

newdataiiys = Log[Transpose[dataii][[2]]]

newdataiia = 
      Transpose[{Transpose[dataii][[1]], newdataiiys}]

ListPlot[newdataiia, PlotStyle -> {PointSize[0.02]}];

Regression[newdataiia]

gpreddataiia = 
        Plot[Exp[0.875264] Exp[-1.05875 x], {x, -2, 3}, 
          PlotStyle -> {Black}];

predicteddataiiys = 
      Exp[0.875264] Exp[-1.05875 x] /. 
        x -> Transpose[dataii][[1]]

e2f[Transpose[dataii][[2]], predicteddataiiys]

Show[{gdatai, gpreddataia}];

Show[gdataii, gpreddataiia];

(b)

newdataibys = (Transpose[datai][[2]])^(-1/
            2)

Regression[
      Transpose[{Transpose[datai][[1]], newdataibys}]]

gpreddataib = 
        Plot[1/((0.7845233 + 
                    0.7573258 x)^2), {x, -1, 3}, 
          PlotStyle -> {Blue}];

predicteddataibys = 
      1/((0.7845233 + 0.7573258 x)^2) /. 
        x -> Transpose[datai][[1]]

Show[{gdatai, gpreddataib}];

newdataiibys = (Transpose[dataii][[2]])^(-1/
            2)

Regression[
      Transpose[{Transpose[dataii][[1]], newdataiibys}]]

gpreddataiib = 
        Plot[1/((0.849877 + 0.577658 x)^2), {x, -1, 3}, 
          PlotStyle -> {Blue}];

predicteddataiibys = 
      1/((0.849877 + 0.577658 x)^2) /. 
        x -> Transpose[dataii][[1]]

Show[{gdataii, gpreddataiib}];

(c)

17.

Clear[a, b, c, n]

f[a_, b_, 
        c_] = (∑_(k = 1)^n)(((a (Subscript[x, k]) + b (Subscript[y, k]) + c - (Subscript[z, k])))^2)

D[f[a, b, c], a]

D[f[a, b, c], b]

D[f[a, b, c], c]

18a.

data = {{1, 1, 7}, {1, 2, 9}, {2, 1, 10}, {2, 2, 11}, {2, 3, 
            12}};

TableForm[data]

g1 = 
        ScatterPlot3D[data, 
          PlotStyle -> {Red, PointSize[0.09]}];

xs = Transpose[data][[1]]

ys = Transpose[data][[2]]

zs = Transpose[data][[3]]

coeffmat = Transpose[{Table[1, {Length[data]}], xs, ys}]

zmat = Transpose[data][[3]]

Inverse[Transpose[coeffmat] . coeffmat] . Transpose[coeffmat] . 
      zmat

f[{x_, y_}] := (19/5)  +  (12/5) x  +  (6/5) 
          y

points = Transpose[{xs, ys}]

g2 = Plot3D[f[{x, y}], {x, 0, 2}, {y, 0, 3}];

Show[g1, g2];

predictedzs = Map[f, points]

e2f[zs, predictedzs]

Functions Used in this notebook

Regression[XY0_]:=Module[ {k, n, XY = XY0 },
n = Length[XY];
X = (Subscript[(Transpose[XY]), [[1]]]); 
Y = (Subscript[(Transpose[XY]), [[2]]]); 
A=(({{(∑_(k = 1)^n) ((Subscript[X, [[k]]])^2), (∑_(k = 1)^n) (Subscript[X, [[k]]])}, {(∑_(k = 1)^n) (Subscript[X, [[k]]]), n}})); 
B=(({{(∑_(k = 1)^n) 
                                  (Subscript[X, [[k]]]) 
                              (Subscript[Y, [[k]]])}, {(∑_(k = 1)^n) (Subscript[Y, [[k]]])}})); 
c = LinearSolve[A, B]; 
a = 
                  (Subscript[c, [[1, 1]]]); 
b = 
                  (Subscript[c, [[2, 1]]]); 
E2 = (∑_(k = 1)^n)((((Subscript[Y, [[k]]]) - a (Subscript[X, [[k]]]) - b))^2); 
Return[ a x + b ]; ];

PowerCurve[XY0_, m_] := 
        Module[ {k, n, XY = XY0 }, 
n = 
            Length[XY]; 
X = (Subscript[(Transpose[XY]), [[1]]]);  
Y = (Subscript[(Transpose[XY]), [[2]]]);  
a = (∑_(k = 1)^n)((((Subscript[X, [[k]]])))^m) (Subscript[Y, [[k]]]) /(∑_(k = 1)^n)((((Subscript[X, [[k]]])))^(2  m)); 
Return[ 
            a (x^m)]; ];

\(\(LeastSqPoly[XY0_, m_] := 
        Module[{a, b, c, i, j, k, sum, pow, prod, X, Y, XY}, 
XY = XY0; 

          n = Length[XY]; 
a = Table[0, {m + 1}, {m + 1}]; 

          b = Table[0, {m + 1}]; 
c = Table[0, {m + 1}]; 
          pow = Table[0, {2\ m + 1}]; 

          X = \(Transpose[XY]\)[[1]]; 
          Y = \(Transpose[XY]\)[[2]]; 

          For[k = 1, 
            k ≤ n, \(k++\), 
\ \ \ YK = 
              Y[[k]]; 
\ \ \ XK = 
              X[[k]]; 
\ \ \ prod := 
              1; 
\ \ \ For[r = 1, 
              r ≤ 
                m + 1, \(r++\), 
\ \ \ \ \ \ b[[
                  r]] = 
                b[[r]] + 
                  YK\ prod; 
\ \ \ \ \ \ prod = prod\ XK];\ ]; 

          For[j = 1, 
            j ≤ 
              2\ m, \(j++\), 
\ \ \ pow[[
                j + 1]] = 
              0]; 
\ \ \ pow[[0 + 1]] := 
            n; 
\ \ \ For[k = 1, k ≤ n, \(k++\), 
            XK = X[[
                k]]; 
\ \ \ \ \ \ prod = 
              X[[k]]; 
\ \ \ \ \ \ For[
              j = 1, j ≤ 
                2\ m, \(j++\), 
\ \ \ \ \ \ \ \ \ pow[[
                  j + 1]] = 
                pow[[j + 1]] + 
                  prod; 
\ \ \ \ \ \ \ \ \ prod = prod\ XK];\ ]; 

          For[i = 1, 
            i ≤ 
              m + 1, \(i++\), 
\ \ \ \(For[j = 1, 
                j ≤ 
                  m + 1, \(j++\), 
\ \ \ \ \ \ \(a[[i, 
                      j]] = 
                    pow[[i + j - 
                        1]];\)\ ];\)\ ]; 

          c = LinearSolve[a, b]; 

          sum = c[[m + 1]]; 

          For[k = m, 1 ≤ k, \(k--\), 
            sum = c[[k]] + sum\ x]; 

          sum = Expand[sum]; 
Return[sum];];\)\)