Week 1

Page 8: #10

Your grandparents have an annuity. The value of the annuity increases each month by an automatic deposit of 1% interest on the previous month’s balance. Your grandparents withdraw $1000 at the beginning of each month for living expenses. Currently they have $50,000 in the annuity. Model the annuity with a dynamical system. Will the annuity run out of money? When?

Solution

Let \(a_n\) be the value of account after \(n\) months

\(a_{n+1}=1.01 \times a_n-1000\)

\(a_0 = 50000\)

bal <- 50000
n <- 0
df <- data.frame(month = n, balance = bal)

# while loop until balance goes below $1000
while(bal > 1000){
  bal <- 1.01 * bal - 1000
  n <- n + 1
  df <- rbind(df, data.frame(month = n, balance = bal))
}
knitr::kable(df)
month balance
0 50000.0000
1 49500.0000
2 48995.0000
3 48484.9500
4 47969.7995
5 47449.4975
6 46923.9925
7 46393.2324
8 45857.1647
9 45315.7364
10 44768.8937
11 44216.5827
12 43658.7485
13 43095.3360
14 42526.2893
15 41951.5522
16 41371.0678
17 40784.7784
18 40192.6262
19 39594.5525
20 38990.4980
21 38380.4030
22 37764.2070
23 37141.8491
24 36513.2676
25 35878.4002
26 35237.1843
27 34589.5561
28 33935.4517
29 33274.8062
30 32607.5542
31 31933.6298
32 31252.9661
33 30565.4957
34 29871.1507
35 29169.8622
36 28461.5608
37 27746.1764
38 27023.6382
39 26293.8746
40 25556.8133
41 24812.3815
42 24060.5053
43 23301.1103
44 22534.1214
45 21759.4626
46 20977.0573
47 20186.8278
48 19388.6961
49 18582.5831
50 17768.4089
51 16946.0930
52 16115.5539
53 15276.7095
54 14429.4766
55 13573.7713
56 12709.5090
57 11836.6041
58 10954.9702
59 10064.5199
60 9165.1651
61 8256.8167
62 7339.3849
63 6412.7787
64 5476.9065
65 4531.6756
66 3576.9923
67 2612.7623
68 1638.8899
69 655.2788 
plot(df,type = "o", col = "red", main = "Grandparent's Annuity")

Annuity runs out in month 69

Page 17: #9

The data in the accompanying table show the speed \(n\) (in increments of 5 mph) of an automobile and the associated distance \(a_n\) in feet required to stop it once the brakes are applied. For instance, \(n = 6\) (representing 6 × 5 = 30 mph) requires a stopping distances of \(a_6 = 47 ft\).

  1. Calculate and plot the change \(\Delta a_n\) versus nn. Does the graph reasonably approximate a linear relationship?

  2. Based on your conclusions in part (a), find a difference equation model for the stopping distance data. Test your model by plotting the errors in the predicted values against \(n\). Discuss the appropriateness of the model.

n 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16
\(a_n\) 3 6 11 21 32 47 65 87 112 140 171 204 241 282 325 376

Solution

  1. We know,

\[\Delta a_n = a_{n+1} - a_n\]

n <- (seq(1, 16))
an <- c(3, 6, 11, 21, 32, 47, 65, 87, 112, 140, 171, 204, 241, 282, 325, 376)
df <- data.frame(n, an)

# add column with delta_an
(df$delta_an <- c(diff(an), NA))
##  [1]  3  5 10 11 15 18 22 25 28 31 33 37 41 43 51 NA
# plot
plot(df$n, df$delta_an, type = "o", xlab = "n", ylab = "delta_an")

Yes, the graph reasonably approximate a linear relationship.

# find intercept using lm fumction
df.lm <- lm(delta_an ~ n, data = df)
df.lm$coefficients
## (Intercept)           n 
##   -1.104762    3.246429

The difference equation model for the stopping distance data:

\[\Delta a_{n}= 3.246n - 1.105\]

or,

\[a_{n+1}= a_n + 3.246n - 1.105\]

# functon for the model
model <- function(n, an, slope, intercept)
{
    est_an <- an + slope * n + intercept
    return(est_an)
}

# first observation will stay the same
n <- 1
est_an <- 3
my_est <- 3

# apply model function for remaining observations
for(i in 2:length(df$an))
{
  my_est[i] <- model(n,est_an, df.lm$coefficients[2], df.lm$coefficients[1])
  n <- n + 1
  est_an <- my_est[i]
}

df$est_an <-c(my_est)
df$est_an <- round(df$est_an, 3)
df$error <- c(df$an - df$est_an)
df
##     n  an delta_an  est_an  error
## 1   1   3        3   3.000  0.000
## 2   2   6        5   5.142  0.858
## 3   3  11       10  10.530  0.470
## 4   4  21       11  19.164  1.836
## 5   5  32       15  31.045  0.955
## 6   6  47       18  46.173  0.827
## 7   7  65       22  64.546  0.454
## 8   8  87       25  86.167  0.833
## 9   9 112       28 111.033  0.967
## 10 10 140       31 139.146  0.854
## 11 11 171       33 170.506  0.494
## 12 12 204       37 205.112 -1.112
## 13 13 241       41 242.964 -1.964
## 14 14 282       43 284.063 -2.063
## 15 15 325       51 328.408 -3.408
## 16 16 376       NA 376.000  0.000
plot(df$n, df$error)

The model may not be appropriate, the errors do not appear to be normal, as the speed increases the error seems to increase aswell.

Week 2

Page 69: #12

A company with a fleet of trucks faces increasing maintenance costs as the age and mileage of the trucks increase

  • Problem you would like to study: Benefit of replacing the fleet with a new on by leasing or financing vs operating with aging fleet.

  • Variables:

    • Size of the fleet.

    • Operating cost of current fleet.

    • Salvage value of current fleet.

    • Financing cost for new fleet .

    • Operating cost of new fleet.

    • Depreciation

    • Savings on maintenance with new fleet.

  • Variable that may be neglected: For simplicity of the model difference in maintenance based on truck make and model may be neglected.

  • Variables might be considered as constants initially: Size of the fleet and fuel cost may be considered as constants initially.

  • Identify any submodels you would want to study in detail: Submodel I Would like to study is return on investment on each individual truck

  • Identify any data you would want collected: I would like to collect historical data on maintenance with age and mileage.

Page 79: #11

\(y alpha x^3\)

y 0 1 2 6 14 24 37 58 82 114
x 1 2 3 4 5 6 7 8 9 10

Solution

y <- c(0,1,2,6,14,24,37,58,82,114)
x <- c(seq(1,10))
dfq11 <- data.frame(x,y)

dfq11$x3 <- x^3

dfq11$k <- dfq11$y/dfq11$x3

dfq11$prop <- dfq11$x3 * dfq11$k

dfq11$m_k <- mean(dfq11$k)
pred <-  dfq11$m_k * dfq11$x3

library(ggplot2)
## Warning: package 'ggplot2' was built under R version 3.3.3
ggplot(dfq11) + geom_line(aes(x, y), colour="blue") + geom_line(aes(x, y=pred), colour="red") + labs(title="Proportionality, Blue = Actual, Red = Predicted")

This data set supports the stated proportionality model.