ClearAll;
$DefaultFont = {"Times-Roman",10};
Needs["Statistics`DataManipulation`"];
Needs["Graphics`Graphics`"];
ucircpars = {0.5,0.022};mcircpars = {0.5,0.006};lcircpars = {0.5,0.015};
wheat = {{0,0}, {5,6}, {10,11}, {15,15}, {25,18}, 
		 {30,16}, {35,14}, {40,10}, {45,6}, {51,0}};
maize = {{12,0}, {15,9}, {20,20}, {25,29}, 
		 {30,35}, {35,38}, {45,30}, {50,7}, {51,0}};
w0[t_]:= t(t+17)(51-t)(5025 - 127 t + t^2);
m0[t_]:= t(t-12)(51-t)(1884 - 71 t + t^2);
approxw[t_] = Fit[wheat,{w0[t]},t];
approxm[t_] = Fit[maize,{m0[t]},t];
s = Abs[FindMinimum[-approxm[t],{t,37,37.1}][[1]]];
wheatscaled = {{0,0}, {5,6/s}, {10,11/s}, {15,15/s}, {25,18/s}, 
		 	   {30,16/s}, {35,14/s}, {40,10/s}, {45,6/s}, {51,0}};
maizescaled = {{12,0}, {15,9/s}, {20,20/s}, {25,29/s}, 
		 	   {30,35/s}, {35,38/s}, {45,30/s}, {50,7/s}, {51,0}};
appm[t_] = approxm[t]/s;
dappm[t_] = D[appm[t],t];
d2appm[t_] = D[appm[t],{t,2}];
opt = FindMinimum[-dappm[t],{t,12,14}];
tinf = t/.opt[[2]];
lcirc = Graphics[Disk[{tinf,0},lcircpars],
	AspectRatio->Automatic];
mcirc = Graphics[Disk[{tinf,dappm[tinf]},mcircpars],
	AspectRatio->Automatic];
ucirc = Graphics[Disk[{tinf,appm[tinf]},ucircpars],
	AspectRatio->Automatic];
Print[Factor[dappm[t]]];
Print[s];
plot1 = Plot[appm[t],{t,12,51}];
plot1a = Plot[appm[t],{t,0,12},PlotStyle->Dashing[{0.001,0.01}]];
plot2 = Plot[dappm[t],{t,12,51}];
plot2a = Plot[dappm[t],{t,0,12},PlotStyle->Dashing[{0.001,0.01}]];
plot3 = Plot[10 d2appm[t],{t,12,51}];
plot3a = Plot[10 d2appm[t],{t,0,12},PlotStyle->Dashing[{0.001,0.01}]];


upper = Show[plot1,plot1a,ucirc,AxesLabel->{"x","y"},
	PlotLabel->FontForm["y = F(x)",{"Courier",10}],
	Ticks->{{5,20,35,50},Automatic},
	PlotRange->{{0,52},{-0.5,1.05}}];
middle = Show[plot2,plot2a,mcirc,AxesLabel->{"x","y"},
	PlotLabel->FontForm["y = F'(x)",{"Courier",10}],
	Ticks->{{15,30,45},{-0.2,-0.1,0,0.1}},
	PlotRange->{{0,52},{-0.225,0.1}}];
lower = Show[plot3,plot3a,lcirc,AxesLabel->{"x","y"},
	PlotLabel->FontForm["y = 10 F''(x)",{"Courier",10}],
	Ticks->{{10,50},Automatic},
	PlotRange->{{0,52},{-0.42,0.42}}];
FindMinimum[-appm[t],{t,37,37.1}]
Show[GraphicsArray[{{upper},{middle},{lower}}],
	PlotLabel->"Figure 16.3"]