Homework 4 Solutions

Empirical Models

Needs["Statistics`DataManipulation`"]Needs["Statistics`LinearRegression`"]\(Needs["Statistics`ContinuousDistributions`"]; 

    Needs["Graphics`Graphics`"]\)

Exercise 3:

Compute (by hand calculator) the regression line for this data:

ys = {2.2, 5.2, 4.8, 11.1, 13.9, 17.1}xs = Table[n, {n, 0, 5}]Regress[Transpose[{xs, ys}], {1, x}, x]

Exercise 3

Data from Exercise #3, p. 226

trial
       = {{0, 2.2},  {1,  5.2},  {2,  4.8},  {3,  11.1},  {4, 13.9}, 
         {5, 17.1}}\(Needs["Statistics`DescriptiveStatistics`"]; 

    meanx = \(∑\+\(n = 1\)\%\(Length[trial]\)\(trial[[n
              ]]\)[[1
            ]]\)\/Length[trial]\)meany = 
      (((∑_(n = 1)^(Length[trial]))trial[[n
              ]][[2
            ]])/Length)[trial]\(xs = Table[\(trial[\([n]\)]\)[\([1]\)], {n, 1, 6}]; 

    ys = Table[\(trial[\([n]\)]\)[\([2]\)], {n, 1, 6}]; \)

cov = 
      1/(Length[trial] - 1)*
        (∑_(n = 1)^(Length[trial]))(xs[[n]] - meanx)*
            (ys[[n]] - meany)beta1 = cov/Variance[xs]*1.0

StandardDeviation[xs]*1.0StandardDeviation[ys]r = cov/StandardDeviation[xs]/StandardDeviation[ys]*1.0

Ex3[x_] = Fit[trial, {1, x}, x]

Next we fit a line to the data and overlay the line and the data.

trialPlot = ListPlot[trial, AxesLabel->{"x","y"},PlotStyle->{PointSize[.02]},DisplayFunction->Identity];

trialext = Plot[Ex3[x],{x,0,5},AxesLabel->{"x","y"},DisplayFunction->Identity];

Show[trialPlot,trialext,DisplayFunction->$DisplayFunction];

data = trial;

SSres = 
      (∑_(n = 1)^(Length[data]))(((
            data[[n
                  ]][[2
                ]] - 
              Ex3[data[[n
                    ]][[1
                  ]]]))^2)

mean = 
      (((∑_(n = 1)^(Length[data]))data[[n
              ]][[2
            ]])/Length)[data]

SSreg = 
      (∑_(n = 1)^(Length[data]))(((
            Ex3[data[[n
                    ]][[1
                  ]]] - mean))^2)

SStot = SSres + SSreg

(SSreg/SStot)

Exercise 4:

a)

\(Clear[r, K]; 
f[t_] = K/\((1 + C\ Exp[\(-r\)\ t])\); 

    Dt[f[t], t, Constants -> {K, C, r}]\)Simplify[Dt[f[t], {t, 2}, Constants -> {K, C, r}]]

b)

f[t_] = K/(1 + Exp[-r (t - t0)])

c) error=<Y-KH,Y-KH>
	=<Y,Y-KH>-<KH,Y-KH>
	=<Y,Y>-<Y,KH>-(<KH,Y>-<KH,KH>)
	=<Y,Y>-K<Y,H>-K<H,Y>+K^2<H,H>
	=<Y,Y>-2K<Y,H>+K^2<H,H>

d) (δ/δ)Kerror=-2<Y,H>+2K<H,H>=0,
so K=(( < Y, H > )/( < H, H > ))

e) error=<Y,Y>-2K<Y,H>+K^2<H,H>
	=<Y,Y>-2(( < Y, H > )/( < H, H > ))<Y,H>+(( < Y, H > )/( < H, H > ))^2<H,H>
	=<Y,Y>-2(( < Y, H > ^2)/( < H, H > ))+(( < Y, H > ^2)/( < H, H > ))
	=<Y,Y>-(( < Y, H > ^2)/( < H, H > ))

Exercise 5:

\(f[x_] = 1 - 4  x; 
Clear[s]; 

    s[i_] := \((
		Clear[n, t]; 
		
        data = Table[{t, f[t] + Random[NormalDistribution[0, 0.25]]}, {t, 0, 
              10}]; 
		h[x_] = Fit[data, {1, x}, x]; 

        		{h[0], h[1] - h[0]}
		)\)\)

\(results = Table[s[i], {i, 1, 20}]; 

    intercepts = 
      Table[\(results[\([n]\)]\)[\([1]\)], {n, 1, Length[results]}]\)freq = 
      BinCounts[
        intercepts, {Min[intercepts], Max[intercepts], 
          (Max[intercepts] - Min[intercepts])/7}]midpoints = 
      Table[Min[intercepts] - 
          ((Max[intercepts] - Min[intercepts])/(2*7)) + 
          n (Max[intercepts] - Min[intercepts])/(7), {n, 1, 7}]BarChart[Transpose[{freq, midpoints}]];

slopes = 
      Table[results[[n]][[2]], {n, 1, Length[results]}]freq = 
      BinCounts[
        slopes, {Min[slopes], Max[slopes], (Max[slopes] - Min[slopes])/7}]
        midpoints = 
      Table[Min[slopes] - ((Max[slopes] - Min[slopes])/(2*7)) + 
          n (Max[slopes] - Min[slopes])/(7), {n, 1, 7}]BarChart[Transpose[{freq, midpoints}]];

Interpolating Exercise #7, p. 226 data

No7 = {{0, 1}, {1, 0}, {2, 1}, {3, 1}}\(p0 = 
      ListPlot[No7, PlotStyle -> {PointSize[.02]}, \ 
        AxesLabel -> {"Quarter", \ "Bushels"}, 
        DisplayFunction -> Identity]; 


    in3[x_] = \(Interpolation[No7, \ InterpolationOrder -> 3]\)[x]\)p4 = Plot[in3[x], {x, 0, 3}, DisplayFunction -> Identity]Show[p0, p4, DisplayFunction -> $DisplayFunction];

A couple of additional interpolations: we're not stuck with cubics!

in1[x_] = Interpolation[No7,  InterpolationOrder -> 1][x]p2 = Plot[in1[x], {x, 0, 3}, DisplayFunction -> Identity]\(Show[p0, p2, DisplayFunction -> $DisplayFunction]; 


    in2[x_] = \(Interpolation[No7, \ InterpolationOrder -> 2]\)[x]\)p3 = Plot[in2[x], {x, 0, 3}, DisplayFunction -> Identity]Show[p0, p3, DisplayFunction -> $DisplayFunction];

Part b)

\(Clear[m, v, a, b, c, d]; 
t3[x_] = x^3\ ; 
t2[x_] = x^2\ ; 

    t1[x_] = x; 


    m = {{t3[0], t2[0], t1[0], 1}, 
	\ \ \ \ \ 	{t3[1], t2[1], t1[1], 1}, 
        
	\ \ \ \ \ 	{t3[2], t2[2], t1[2], 1}, 

        	\ \ \ \ \ 	{t3[3], t2[3], t1[3], 1}}; 
v = {1, 0, 1, 1}; 

    s = LinearSolve[m, v]\)

\(Clear[m, v, a, b, c, d]; 

    m = {{t2[0], t1[0], 1}, 
	\ \ \ \ \ 	{t2[1], t1[1], 1}, 

        	\ \ \ \ \ 	{t2[2], t1[2], 1}}; 
v = {1, 0, 1}; 

    s2 = LinearSolve[m, v]\)\(p2 = 
      Plot[s2[\([1]\)] x^2 + s2[\([2]\)]\ x\  + s2[\([3]\)], {x, 0, 3}, 
        DisplayFunction -> Identity]
\)\(m = {{t2[1], t1[1], 1}, 
	\ \ \ \ \ 	{t2[2], t1[2], 1}, 

        	\ \ \ \ \ 	{t2[3], t1[3], 1}}; 
v = {0, 1, 1}; 

    s3 = LinearSolve[m, v]\)p3 = 
      Plot[s3[[1]] x^2 + s3[[2]] x  + s3[[3]], {x, 0, 3}, 
        DisplayFunction -> Identity]Show[p0, p2, p3, DisplayFunction -> $DisplayFunction];

Part 3)

\(Clear[m, v, a, b, c, d]; 

    m = {{4, 1, 0}, 
	\ \ \ \ \ 	{t2[2], t1[2], 1}, 

        	\ \ \ \ \ 	{t2[3], t1[3], 1}}; 

    v = {2\ s2[\([1]\)]*2 + \ s2[\([2]\)], 1, 1}; 
s3 = LinearSolve[m, v]\)p3 = 
      Plot[s3[[1]] x^2 + s3[[2]] x  + s3[[3]], {x, 0, 3}, 
        DisplayFunction -> Identity]Show[p0, p2, p3, DisplayFunction -> $DisplayFunction];

Exercise 8:

Regress[{{1, 1}, {2, 0}, {3, 2}, {4, 1}, {5, 3}, {6, 1}}, {1, x}, x]

Exercise 9:

Needs["Statistics`LinearRegression`"]\(data
       = {5, 
\(-2.9727122\), 
\(-8.6146953\), 
\(-5.8253055\), 

        3.25653629, 
10, 
8.11063825
, 
\(-.1189664\), 
\(-6.7605934\), 
        
\(-6.4994237\), 
\(-1\), 
4.2087802, 
5.37862736, 
2.58923753
        
, 
\(-2.0204683\), 
\(-6\), 
\(-6.8745703\), 
\(-3.1171016\), 

        3.52452539, 
7.73549171, 
5, 
\(-2.9727122\)
, 
\(-8.6146953\), 
        
\(-5.8253055\), 
3.25653629, 
10, 
8.11063825, 
\(-.1189664\), 
        
\(-6.7605934\)
, 
\(-6.4994237\), 
\(-1\), 
4.2087802, 

        5.37862736, 
2.58923753, 
\(-2.0204683\), 
\(-6\), 

        \(-6.8745703\)
, 
\(-3.1171016\), 
3.52452539, 
7.73549171, 
5, 
        
\(-2.9727122\), 
\(-8.6146953\), 
\(-5.8253055\)
, 
3.25653629, 
        
10, 
8.11063825, 
\(-.1189664\), 
\(-6.7605934\), 

        \(-6.4994237\), 
\(-1\)}; 
xs = Table[n/10.0, {n, 0, 50}]; 

    pairs = Transpose[{xs, data}]; \)

\(Clear[x]; 

    Regress[pairs, {0, Sin[π\ x], Cos[π\ x], Sin[2  π\ x], 
        Cos[2  π\ x], Sin[3  π\ x\ ], Cos[3  π\ x], 
        Sin[4  π\ x], Cos[4  π\ x], Sin[5  π\ x], 
        Cos[5  π\ x]}, x]\)

\(Clear[x]; 

    Regress[pairs, {0, Sin[π\ x], Sin[3  π\ x\ ], Cos[3  π\ x], 
        Cos[4  π\ x]}, x]\)

Project 4.5: Alligator Vent Snout Length

lengths
       = {4794, 3697, 7594, 3088, 4515, 4606, 3182, 4295, 3312, 3587, 6602, 
          4382, 4085, 4168, 4382}/100.0weights
       = {13032, 5091, 63906, 2794, 7984, 10995, 3312, 9002, 3587, 3809, 
          36503, 8393, 7984, 8310, 7011}/100.0Length[lengths]Length[weights]Regress[Transpose[{Log[lengths], Log[weights]}], {1, x}, x]

a0 = Exp[-8.47817238075708878]a1 = 3.43164627033031255

p1 = 
      ListPlot[Transpose[{lengths, weights}], 
        PlotStyle -> PointSize[0.02], DisplayFunction -> Identity]\(f[x_] = a0\ x^a1; 

    p2 = Plot[f[x], {x, Min[lengths], Max[lengths]}, 
        DisplayFunction -> Identity]\)Show[p1, p2, DisplayFunction -> $DisplayFunction]

residuals = 
      Table[f[lengths[[n]]] - weights[[n]], {n, 1, Length[lengths]}]ListPlot[Transpose[{lengths, residuals}], 
      PlotStyle -> PointSize[0.02], DisplayFunction -> $DisplayFunction]
      Mean[residuals]\(StandardDeviation[residuals]
\)