Generating the Figures in Primer 1 of Otto and Day

Inputs

<< Graphics`Graphics`

<< Graphics`MultipleListPlot`

<< Graphics`Arrow`

<<Graphics`PlotField`

<<Statistics`LinearRegression`

<<Statistics`NonlinearFit`

Off[General::"spell"]

Off[General::"spell1"]

Figure P1.1 - Functions for the logistic

D[(((E^(a n)) (1 + r))/((((E^(a K)) r)/(1 - (E^(a K)))) + (E^(a n)) (1 - (((E^(a K)) r)/(1 - (E^(a K))))))), 
          n] /. n -> 0 // Simplify

D[(((E^(a n)) (1 + r))/((((E^(a K)) r)/(1 - (E^(a K)))) + (E^(a n)) (1 - (((E^(a K)) r)/(1 - (E^(a K))))))), 
          n] /. n -> K // Simplify

DisplayTogether[
Plot[(1 + r) - r n/K /. 
            r -> 0.5 /. K -> 100, {n, 0, 
          300}], 
Plot[-r n^2/K^2 + (1 + r) /. 
            r -> 0.5 /. K -> 100, {n, 0, 300}, 
        PlotStyle -> 
          Dashing[{0.04}]], 
Plot[(1 + 
                  r) (Exp[-Log[(1 + r)] n /K]) /. 
            r -> 0.5 /. K -> 100, {n, 0, 300}, 
        PlotStyle -> 
          Dashing[{0.01}]], 
Plot[(((E^(a n)) (1 + r))/((((E^(a K)) r)/(1 - (E^(a K)))) + (E^(a n)) (1 - (((E^(a K)) r)/(1 - (E^(a K))))))) /. a -> -0.05 /. K -> 100 /. 
          r -> 0.5, {n, 0, 300}, 
        PlotStyle -> 
          Thickness[0.01]], 
PlotRange -> {{0, 
            250}, {-0.3, 1.55}}
]

Export["Fig.eps", %, "EPS"];

I like the following figure better (a sharper S-shaped function), but it generates more severe oscillations in Figure P1.8)

DisplayTogether[
Plot[(1 + r) - r n/K /. 
            r -> 0.5 /. K -> 100, {n, 0, 
          300}], 
Plot[-r n^2/K^2 + (1 + r) /. 
            r -> 0.5 /. K -> 100, {n, 0, 300}, 
        PlotStyle -> 
          Dashing[{0.04}]], 
Plot[(1 + 
                  r) (Exp[-Log[(1 + r)] n /K]) /. 
            r -> 0.5 /. K -> 100, {n, 0, 300}, 
        PlotStyle -> 
          Dashing[{0.01}]], 
Plot[(((E^(a n)) (1 + r))/((((E^(a K)) r)/(1 - (E^(a K)))) + (E^(a n)) (1 - (((E^(a K)) r)/(1 - (E^(a K))))))) /. a -> -0.1 /. K -> 100 /. 
          r -> 0.5, {n, 0, 300}, 
        PlotStyle -> 
          Thickness[0.01]], 
PlotRange -> {{0, 
            250}, {-0.3, 1.55}}
]

Figure P1.3 - Quadratic functions

DisplayTogether[
Plot[
        a x^2 + b x  + c /. {c -> 5, b -> -8, 
            a -> 2}, {x, -1, 5}], 
Plot[
        a x^2 + b x  + c /. {c -> -5, b -> +8, 
            a -> -2}, {x, -1, 5}, 
        PlotStyle -> Dashing[{0.01}]], 
Ticks -> 
        False
]

Export["Fig.eps", %, "EPS"];

Figure P1.4 - Exponential functions

DisplayTogether[
Plot[
        c Exp[a x] /. {c -> 1, a -> 1/20}, {x, 0, 
          30}], 
Plot[
        c Exp[a x] /. {c -> 1, a -> -1/10}, {x, 0, 30}, 
        PlotStyle -> Dashing[{0.01}]], 
      PlotRange -> {{0, 30}, {0, 5}}, 
Ticks -> 
        False,  AxesOrigin -> {0, 0}
]

Export["Fig.eps", %, "EPS"];

Figure P1.5 - Hyperbolic functions

D[(a x + c)/(b x + d ), x] /. x -> 0 // 
      Factor

DisplayTogether[
Plot[(a x + c)/(b x + 
                d ) /. {c -> 1, b -> 4, a -> 8, 
            d -> 1}, {x, 0, 
          5}], 
Plot[(a x + c)/(b x + 
                d ) /. {c -> 1, b -> 4, a -> 1, 
            d -> 1}, {x, 0, 5}, 
        PlotStyle -> Dashing[{0.01}]], 
Ticks -> 
        False, PlotRange -> {{0, 4}, {0, 2}}, 
      AxesOrigin -> {0, 0}
]

Export["Fig.eps", %, "EPS"];

Figure P1.6 - Bell-shaped functions

DisplayTogether[
Plot[
        h Exp[-(x - b)^2/a] /. {h -> 1, b -> 2, 
            a -> 1/3}, {x, 0, 5}], 
Plot[
        h Exp[-(x - b)^2/a] /. {h -> 1, b -> 2, 
            a -> 1}, {x, 0, 5}, 
        PlotStyle -> Dashing[{0.01}]], 
Ticks -> 
        False, PlotRange -> {{0, 4}, {0, 1.5}}, 
      AxesOrigin -> {0, 0}
]

Export["Fig.eps", %, "EPS"];

Figure P1.7 - S-shaped functions

DisplayTogether[
Plot[(c  Exp[
                  a x])/((1 - c)  + c  Exp[a x]) /. {c -> 
              0.01, a -> 1/10}, {x, 0, 
          100}], 
Plot[(c  Exp[
                  a x])/((1 - c)  + c  Exp[a x]) /. {c -> 
              0.99, a -> -1/10}, {x, 0, 100}, 
        PlotStyle -> 
          Dashing[{0.01}]], 
PlotRange -> 
        All]

Export["Fig.eps", %, "EPS"];

Figure P1.8 - Logistic Growth (Discrete Time)

Clear[num, num2, num3, num4,  r, K]
\(num[K_, r_, 
        t_] := \(num[K, r, 
          t] = 
		num[K, r, 
            t - 1] \((\((1 + r)\) - r\ num[K, r, t - 1]/K)\)\)\)
num[K_, r_, 0] :=  5.0

\(num2[K_, r_, 
        t_] := \(num2[K, r, t] = 
		If[
          test = num2[K, r, 
                t - 1] \((\(-r\)\ num2[K, r, t - 1]^2/K^2 + \((1 + r)\))\); 
          test > 0, \ test, 0]\)\)
num2[K_, r_, 0] :=  5.0

\(num3[K_, r_, 
        t_] := \(num3[K, r, 
          t] = 
		num3[K, r, 
            t - 1] \((\((1 + 
                  r)\)\ \((Exp[\(-Log[\((1 + r)\)]\)\ num3[K, r, t - 1]/
                      K])\))\)\)\)
num3[K_, r_, 0] := 5.0

\(num4[K_, r_, a_, 
        t_] := \(num4[K, r, a, 
          t] = 
		num4[K, r, a, 
            t - 1] \((\(E\^\(a\ num4[K, r, a, t - 1]\)\ \((1 + r)\)\)\/\(\(E\^\(a\ K\)\ r\)\/\(1 - E\^\(a\ K\)\) + E\^\(a\ num4[K, r, a, t - 1]\)\ \((1 - \(E\^\(a\ K\)\ r\)\/\(1 - E\^\(a\ K\)\))\)\))\)\)\)
num4[K_, r_, a_, 0] :=  5.0

\(DisplayTogether[
	\ \ \ ListPlot[
        Table[{t, num[100, 0.5, t]}, {t, 0, 50}], 
        PlotJoined -> True], 
	
      ListPlot[Table[{t, num2[100, 0.5, t]}, {t, 0, 50}], PlotJoined -> True, 
        PlotStyle -> Dashing[{0.04}]], 
	
      ListPlot[Table[{t, num3[100, 0.5, t]}, {t, 0, 50}], PlotJoined -> True, 
        PlotStyle -> Dashing[{0.01}]], 
	
      ListPlot[Table[{t, num4[100, 0.5, \(-0.015\), t]}, {t, 0, 50}], 
        PlotJoined -> True, 
        PlotStyle -> Thickness[0.01]], 
	
      ListPlot[Table[{t, num4[100, 0.5, \(-0.05\), t]}, {t, 0, 50}], 
        PlotJoined -> True, 
        PlotStyle -> 
          Thickness[0.01]], 
PlotRange -> {{0, 25}, {0, 
            110}}
]\)

Export["Fig.eps", %, "EPS"];

For higher values of r:

\(DisplayTogether[
	\ \ \ ListPlot[
        Table[{t, num[100, 2, t]}, {t, 0, 50}], 
        PlotJoined -> True], 
	
      ListPlot[Table[{t, num2[100, 2, t]}, {t, 0, 50}], PlotJoined -> True, 
        PlotStyle -> Dashing[{0.04}]], 
	
      ListPlot[Table[{t, num3[100, 2, t]}, {t, 0, 50}], PlotJoined -> True, 
        PlotStyle -> Dashing[{0.01}]], 
	
      ListPlot[Table[{t, num4[100, 2, \(-0.015\), t]}, {t, 0, 50}], 
        PlotJoined -> True, 
        PlotStyle -> Thickness[0.01]], 
	
      ListPlot[Table[{t, num4[100, 2, \(-0.05\), t]}, {t, 0, 50}], 
        PlotJoined -> True, 
        PlotStyle -> 
          Thickness[0.01]], 
PlotRange -> {{0, 15}, {0, 
            150}}
]\)

Export["Fig.eps", %, "EPS"];

Interestingly, the S-shaped function decouples the intrinsic growth rate (r) from the behavior of the model (sensitive to a):

\(DisplayTogether[
	
      ListPlot[Table[{t, num4[100, 0.1, \(-0.01\), t]}, {t, 0, 100}], 
        PlotJoined -> True, 
        PlotStyle -> Thickness[0.01]], 
	
      ListPlot[Table[{t, num4[100, 0.1, \(-0.5\), t]}, {t, 0, 100}], 
        PlotJoined -> True, 
        PlotStyle -> 
          Thickness[0.01]], 
PlotRange -> {{0, 100}, {0, 
            110}}
]\)

Figure P1.9 - Taylor series of exp[x]

Series[Exp[x], {x, 0, 10}]

Normal[Series[Exp[x], {x, 0, 1}]]

{Exp[x], Normal[Series[Exp[x], {x, 0, 1}]], 
      Normal[Series[Exp[x], {x, 0, 2}]], Normal[Series[Exp[x], {x, 0, 3}]], 
      Normal[Series[Exp[x], {x, 0, 6}]]}

Plot[{(E^x), 1 + x, 1 + x + ((x^2)/2), 
        1 + x + ((x^2)/2) + ((x^3)/6), 1 + x + ((x^2)/2) + ((x^3)/6) + ((x^4)/24)}, {x, 
        0, 3}, PlotStyle -> {Thickness[0.01], Dashing[{ .001, 0.01}], 
          Dashing[{ .005, 0.03}], Dashing[{ .02}], 
          Dashing[{ .04}]}]

Display["graphA.EPS", %, "EPS"]

Figure P1.10 - Taylor series of ln[x]

Series[Log[x], {x, 1, 6}]

Plot[{Log[x], (x - 1), (x - 1) - 
          (1/2) (((x - 1))^2), (x - 1) - (1/2) (((x - 1))^2) + 
          (1/3) (((x - 1))^3), (x - 1) - (1/2) (((x - 1))^2) + 
          (1/3) (((x - 1))^3) - (1/4) (((x - 1))^4)}, {x, 0, 3}, 
      PlotRange -> {-1.75, 1.75}, 
      PlotStyle -> {Thickness[0.01], Dashing[{ .001, 0.01}], 
          Dashing[{ .005, 0.03}], Dashing[{ .02}], 
          Dashing[{ .04}]}]

Display["graphB.EPS", %, "EPS"]

Figure P1.11 - Approximating the sine function

This rewrites the sine function as a Taylor Series up to k:

taylorsine[k_, a_] = 
      Sum[(D[Sin[x], {x, i}] /. x -> a)/(i!) (x - a)^
            i, {i, 0, k}]

DisplayTogether[
Plot[Sin[x], {x, 0, 4 Pi}, 
        PlotStyle -> Thickness[0.01]], 
Plot[
        taylorsine[0, 1], {x, 0, 4 Pi}, 
        PlotStyle -> Dashing[{0.005, 0.04}]], 
Plot[
        taylorsine[1, 1], {x, 0, 4 Pi}, 
        PlotStyle -> Dashing[{0.02, 0.02}]], 
Plot[
        taylorsine[2, 1], {x, 0, 4 Pi}, 
        PlotStyle -> Dashing[{0.04, 0.04}]], 
Plot[
        taylorsine[10, 1], {x, 0, 
          4 Pi}], 
PlotRange -> {{0, 
            2 Pi}, {-1.5, 1.5}}
]

D[Exp[x]/(1 + Exp[x]), x] /. x -> 0

Exp[x]/(1 + Exp[x]) /. x -> 0.1

1/(1 + x) /. x -> 0.1