4.4 Modeling Nearly Exponential Data

Example 4.10

Colonial population data from 1610 to 1670:

({{t = years since 1610, 0, 10, 20, 30, 40, 50, 60}, {C = population (thousands), 0.35, 2.3, 4.6, 26.6, 50.4, 75.1, 111.9}})

Part 1

ColData = {{0,0.35},{10,2.3},{20,4.6},{30,26.6},{40,50.4},{50,75.1},{60,111.9}}

ColDataPlot = ListPlot[ColData, AxesLabel->{"t years (after 1610)", "Colonial Population (thousands)"},PlotStyle->Red, PlotMarkers->{"✶",16}, AxesOrigin->{0,0}, PlotLegends->{"Colonial Population Data",LegendMarkers->Automatic}]

RatioColData =Table[{StringForm[" `` to `` ",ColData[[ i]][[1]],ColData[[i+1]][[1]]],ColData[[i+1]][[2]]/ColData[[i]][[2]]},{i,1,Length[ColData]-1}];

TableForm[RatioColData ,TableHeadings->{None,{"Time Increment (years)","Ratios of D"}}]

Part 2

Clear[A,B,t]

Model = A*B^t;

fit = FindFit[ColData,Model,{A,B},t]

ColDataFunc = Function[{t},Evaluate[Model/.fit]]

ColDataFunc[t]

ColDataFuncPlot=Plot[ColDataFunc[t],{t,0,60}, PlotStyle->{Blue, Thickness[0.004]},PlotLegends->{"Best Fit Curve",LegendMarkers->Automatic}];

Show[ColDataFuncPlot,ColDataPlot]

OurError = Table[(ColDataFunc[ColData[[ i]][[1]]]-ColData[[ i]][[2]])^2,{i,1,Length[ColData]}]

Total[OurError]

BookFunc[t_]:=0.704*(1.100^t)

BookError = Table[(BookFunc[ColData[[ i]][[1]]]-ColData[[ i]][[2]])^2,{i,1,Length[ColData]}]

Total[BookError]

ColDataBookPlot=Plot[BookFunc[t],{t,0,60}, PlotStyle->{Magenta, Thickness[0.004]},PlotLegends->{"Book's Best Fit Line",LegendMarkers->Automatic}];

Show[ColDataFuncPlot,ColDataBookPlot,ColDataPlot]

Part 3

This is just a weird question....

Example 4.11

The data:

({{t= time in years since 1900, 10, 20, 40, 50, 70, 90, 100}, {E = life expectancy, 50.2, 56.3, 62.8, 66.3, 67.9, 72.7, 74.8}, {D = 80 - E, 29.8, 23.7, 17.2, 13.7, 12.1, 7.3, 5.2}})

Part 1

DLifeData = {{10,29.8},{20,23.7},{40,17.2},{50,13.7},{70,12.1},{90,7.3},{100,5.2}}

Model = A*B^t;

LifeFit = FindFit[DLifeData,Model,{A,B},t]

LifeFitFunc = Function[{t},Evaluate[Model/.LifeFit]]

LifeEDataPlot = ListPlot[DLifeData , AxesLabel->{"t years (after 1900)", "Life Expectancy"},PlotStyle->Red, PlotMarkers->{"✶",16}, AxesOrigin->{0,0}, PlotLegends->{"Life Expectancy",LegendMarkers->Automatic}];

LifeEDataFuncPlot=Plot[LifeFitFunc[t],{t,0,110}, PlotStyle->{Blue, Thickness[0.005]},PlotLegends->{"Best Fit Curve",LegendMarkers->Automatic}];

Show[LifeEDataPlot,LifeEDataFuncPlot, PlotRange->{{0,110},{0,35}}]

Part 2

ModLifeFitFunc [t_]:=80-LifeFitFunc[t]

ModLifeFitFunc[t]

Part 3

So we need to know the life expectancy in 2010, our function’s input is measured in years since 1900, so we need t=110. According to our model, this is 74.90 years.  Note that the model the book arrived at came up with a value of 75.19 years.

ModLifeFitFunc[110]

Part 4

ModLifeEDataFuncPlot=Plot[ModLifeFitFunc[t],{t,-5,110}, PlotStyle->{Blue, Thickness[0.005]},PlotLegends->{"80-Best Fit Curve",LegendMarkers->Automatic}];

ELifeData = {{10,50.2},{20,56.3},{40,62.8},{50,66.3},{70,67.9},{90,72.7},{100,74.8}}

ELifeEDataPlot = ListPlot[ELifeData , AxesLabel->{"t years (after 1900)", "Life Expectancy"},PlotStyle->Red, PlotMarkers->{"✶",16}, AxesOrigin->{0,0}, PlotLegends->{"Life Expectancy",LegendMarkers->Automatic}];

Show[ELifeEDataPlot,ModLifeEDataFuncPlot, PlotRange->{{0,110},{0,80}}]

Part 5

To find the time at which life expectancy reaches 40 years, we must not that at t=0, which is 1900, the life expectancy was 50.2 years and increasing afterwards, so the 40 year life expectancy must occur before 1900.  The NSolve command below gives t=-8.11 years, which would be approximately 1892.

NSolve[ModLifeFitFunc[t]==40.0,t,Reals]

Plot[{ModLifeFitFunc[t],40},{t,-10,10}, PlotStyle->{{Blue, Thickness[0.005]},{Red, Dashed,Thickness[0.004]}},PlotLegends->{"80-Best Fit Curve","40 year mark",LegendMarkers->Automatic}, AxesOrigin->{0,0}, PlotRange->{{-10,2},{0,60}}]

Exercise 3

ConvertFourthData = {{1,70},{2,60},{3,53},{4,46},{5,41},{6,37},{7,34},{8,32}};

Part a.

Clear[A,B]

Model = A*B^t;

ConvertFourthFit = FindFit[ConvertFourthData,Model,{A,B},t]

ConvertFourthFitFunc = Function[{t},Evaluate[Model/.ConvertFourthFit]]

From the work above, we see that the model is P(D) = 76.8544*(0.8874^D).

Part b.

ConvertFourthDataFuncPlot=Plot[ConvertFourthFitFunc[D],{D,0,15}, PlotStyle->{Blue, Thickness[0.005]},PlotLegends->{"Best Fit Curve",LegendMarkers->Automatic}];

ConvertFourthDataPlot = ListPlot[ConvertFourthData , AxesLabel->{"D = distance (yards)", "Probability (%)"},PlotStyle->Red, PlotMarkers->{"✶",16}, AxesOrigin->{0,0}, PlotLegends->{"Probability Data (%)",LegendMarkers->Automatic}];

Show[ConvertFourthDataFuncPlot,ConvertFourthDataPlot , AxesOrigin->{0,0}, PlotRange->{{0,11},{0,80}}, AxesLabel->{"D = distance (yards)", "Probability (%)"}]

Part c.

We simply evaluate our function at D=10, which gives an output of 23.35%, which is below the 28% mentioned in the book.

ConvertFourthFitFunc[10]

Exercise 6

The cost of scientific journals has gotten ridiculous, in fact Europe has started to crack down on the pricing, hopefully we will follow suit!  The following is a table of the cost of chemistry and physics periodicals t years after 1980.

({{t= years since 1980, C =cost in $}, {0, 140}, {5, 250}, {10, 410}, {15, 780}, {20, 1300}, {22, 1520}})

JournalData = {{0,140},{5,250},{10,410},{15,780},{20,1300},{22,1520}}

Part a.

Clear[A,B]

Model = A*B^t;

JournalDataFit = FindFit[JournalData,Model,{A,B},t]

JournalDataFitFunc = Function[{t},Evaluate[Model/.JournalDataFit]]

The function is: c(t) = 154.952*(1.11052^t) where t is measured in years since 1980.

Part b.

JournalDataFuncPlot=Plot[JournalDataFitFunc[t],{t,0,24}, PlotStyle->{Blue, Thickness[0.005]},PlotLegends->{"Best Fit Curve",LegendMarkers->Automatic}];

JournalDataPlot = ListPlot[JournalData , AxesLabel->{"t = years since 1980", "Cost (in $)"},PlotStyle->Red, PlotMarkers->{"✶",16}, AxesOrigin->{0,0}, PlotLegends->{"Journal Cost",LegendMarkers->Automatic}];

Show[JournalDataFuncPlot,JournalDataPlot  , AxesOrigin->{0,0},  AxesLabel->{"t = years since 1980", "Cost (in $)"}]

Part c.

From the model, the exponential base is 1.11052, which means that there is an 11% annual growth on the price of these journals.

Part d.

We simply need to evaluate the function 40 years after 1980, which rounded to the nearest dollar gives $10,262.

JournalDataFitFunc[40]