Data 609 Assignment #7

Week 13 Homework Assignment

Page B-17

Question 1

Build a numerical solution to Equations (15.8).

\[ \left.\begin{aligned} y_{n+1}&=120+\frac{1}{2}x_n\\ x_{n+1}&=60+\frac{1}{3}y_n \end{aligned}\right\rbrace \]

With:

\[\begin{aligned} x_0=100\\ y_0=200 \end{aligned}\]

Part A

Graph Results

# y_n+1:  Number of arms for country Y
f_1 <- function(x) 120 + 0.5 * x  

# x_n+1:  Number of arms for country X
f_2 <- function(y) 60 + 1/3 * y

# function to calculate number of arms for countries x and y
calc_weapons <- function(x0,y0, iter, func1, func2){
    x <- x0
    y <- y0
    t <- 0
    
    for (i in 1:iter){
        y <- append(y, func1(x[length(x)]))
        x <- append(x, func2(y[length(y)]))
        t <- append(t,i) 
    }
    
    data.frame(t=t,x=x,y=y) %>% gather("country","arms",2:3)
   
}

# calculate future arms based on initial values of x0=100, y0=200
df <- calc_weapons(100,200,20,f_1,f_2)

# plot
ggplot(df, aes(x=t,y=arms,col=country)) + geom_line() + theme_few() + scale_color_few() + 
    labs(title="Number of Arms ~ Time Period", x = "time", y= "arms") +
    theme(plot.title = element_text(hjust = 0.5))

Part B

Is an equilibruim value reached?

# data, wide format
df <- df %>% spread(country, arms)

# ~ equilibrium values, t=20
kable(tail(df,1), align="rrr", row.names=F, digits = 2)

t	x	y
20	120	180

Yes.

Assuming that initial weapons stocks of 100 and 200 for countries X and Y, respectively, therefore the equilibrium weapons values are 120 and 180.

Part C

Try other starting values.

Do you think the equilibrium value is stable?

# vectors of starting x and y values
x <- c(0,200,10,50)
y <- c(0,10,200,50)

# plot various (x,y) initial conditions
for (i in 1:length(x)) {
  df_name <- paste0("df",x[i],".",y[i])
  var_name <- paste0("g",x[i],".",y[i])
  assign(df_name,calc_weapons(x[i],y[i],20,f_1,f_2))
  
  x_equil <- eval(parse(text=df_name)) %>% filter(country == 'x', t == 20) %>%
      select(arms)
  
  y_equil <- eval(parse(text=df_name)) %>% filter(country == 'y', t == 20) %>%
      select(arms)
  
  assign(var_name,
         ggplot(eval(parse(text=df_name)), aes(x=t,y=arms,col=country)) +
           geom_line() + theme_few() + scale_color_few(guide=FALSE) +
           labs(title = paste0("Initial x,y: (",x[i],",",y[i],")"),x = "time", y= "arms",
                subtitle = paste0("x equil:",round(x_equil,1),", y equil:",round(y_equil,1) )) +
           theme(plot.title = element_text(hjust = 0.5),plot.subtitle = element_text(hjust = 0.5))
  )
}
# print plots in grid format
plot_grid(g0.0, g200.10, g10.200, g50.50, ncol = 2, labels = "AUTO",
          align = 'v', label_size = 14)

In the long-termm, the equilibrium values appear to be stable.

In the above plots, the weapons counts for countries X and Y converge to 120 and 180, respectively, despite varying initial.

Part D

Explore other values for the surbial coeffiecients of Countries X & Y.

Describe Results.

# vectors of various survival coefficents
a <- c(0.6,0.5,0.1,0.99) 
b <- c(0.33,0.4,0.05,0.25)

# plots for various survival coefficients
for (i in 1:length(a)) {
  df_name <- paste0("df",a[i],"_",b[i])
  var_name <- paste0("g",a[i],"_",b[i])
  assign("f1", function(x) 120+ a[i]*x )
  assign("f2", function(x) 60+ b[i]*x )
  assign(df_name,calc_weapons(100,200,20,f1,f2))
  
  x_equil <- eval(parse(text=df_name)) %>% filter(country == 'x', t == 20) %>%
      select(arms)
  
  y_equil <- eval(parse(text=df_name)) %>% filter(country == 'y', t == 20) %>%
      select(arms)

  assign(var_name,
         ggplot(eval(parse(text=df_name)), aes(x=t,y=arms,col=country)) +
              geom_line() + theme_few() + scale_color_few(guide=FALSE) + 
              labs(title = paste0("Coeff: (",b[i],",",a[i],")"),x = "time", y= "arms",
                   subtitle = paste0("x equil:",round(x_equil,1),", y equil:",round(y_equil,1) )) + 
             theme(plot.title = element_text(hjust = 0.5),plot.subtitle = element_text(hjust = 0.5))
 )
}
# print plots in grid format
plot_grid(g0.6_0.33, g0.5_0.4, g0.1_0.05, g0.99_0.25, ncol = 2, labels = "AUTO",
          align = 'v', label_size = 14)

Based on the above plots, we see that equilibrium values are highly sensitive, assuming survival coefficients used in our models.

Page B-25

Question 1

Show that when the demand curve is very steep, a tax added to each item sold will fall primarily on cumsumers

Steep Demand Curve

# average supply slope, steep demand
supply <- bezier(c(1, 8, 9), c(1, 5, 9))
demand <- bezier(c(4, 5, 6), c(10,1,0.002))

# add $2 tax and update supply curve
tax <- 2
supply_tax <- list(x=supply$x,y=supply$y + tax)

# save to df
df <- data.frame(q=supply$x, p=supply$y, type="supply") %>%
    rbind(data.frame(q=demand$x, p=demand$y,type="demand")) %>%
    rbind(data.frame(q=supply_tax$x, p=supply_tax$y,type="supply w tax"))

# calculate intersection points
X1 <- curve_intersect(supply, demand)
X2 <- curve_intersect(supply_tax,demand)
X1_lab <- paste0("(",round(X1$x,2),", ",round(X1$y,2),")")
X2_lab <- paste0("(",round(X2$x,2),", ",round(X2$y,2),")")

# plot
ggplot(df, aes(x=q,y=p, colour=type)) + geom_line() + 
    annotate("text",x=X1$x, y=X1$y-0.4, label = X1_lab ) +
    annotate("text",x=X2$x, y=X2$y-0.4, label = X2_lab) +  theme_few() + scale_color_few() + 
    geom_point(x=X1$x, y=X1$y, col="black") + geom_point(x=X2$x, y=X2$y, col="black") +
    labs(title="Steep Demand Curve with $2 Tax") + 
    scale_x_continuous(breaks =seq(0,10,2)) + scale_y_continuous(breaks =seq(0,10,2))

With a flatter demand curve, the consumer shares a smaller percentage of the tax burden.

In the above example, the consumers takes on $1.77 of the $2 tax burden or roughly 88.6%.

Now Show that when the demand curve is more nearly horizontal, the taz is paud mostly by the insustry.

Flat Demand Curve

# average supply slope, flatter demnd
supply <- bezier(c(1, 8, 9), c(1, 5, 9))
demand <- bezier(c(1,3, 6, 8, 9), c(9.7,9.5,9.3,9.1,8.6))

# add $2 tax and update supply curve
tax <- 2
supply_tax <- list(x=supply$x,y=supply$y + tax)

# save to df
df <- data.frame(q=supply$x, p=supply$y, type="supply") %>%
    rbind(data.frame(q=demand$x, p=demand$y,type="demand")) %>%
    rbind(data.frame(q=supply_tax$x, p=supply_tax$y,type="supply w tax"))

# calculate intersection points
X1 <- curve_intersect(supply, demand)
X2 <- curve_intersect(supply_tax,demand)
X1_lab <- paste0("(",round(X1$x,2),", ",round(X1$y,2),")")
X2_lab <- paste0("(",round(X2$x,2),", ",round(X2$y,2),")")

# plot
ggplot(df, aes(x=q,y=p, colour=type)) + geom_line() + 
    annotate("text",x=X1$x-0.5, y=X1$y-0.7, label = X1_lab) + 
    annotate("text",x=X2$x-0.3, y=X2$y-0.5, label = X2_lab) + theme_few() + scale_color_few() + 
    geom_point(x=X1$x, y=X1$y, col="black") +  geom_point(x=X2$x, y=X2$y, col="black") +
    labs(title="Flat Demand Curve with $2 Tax") + 
    scale_x_continuous(breaks =seq(0,10,2)) + scale_y_continuous(breaks =seq(0,10,2))  

With a flatter demand curve, the consumer shares a smaller percentage of the tax burden.

In the example above, the consumer pays $0.27 of the $2 tax burden, or 13.3%.

In other words, the industry takes on primary responsibility for the tax.

What if the supply curve is very steep?

Steep Supply

# steep supply slope, average demnd
supply <- bezier(c(3,4,5), c(.01,.02,10))
demand <- bezier(c(1,3,9), c(9, 3, 1))

# add $2 tax and update supply curve
tax <- 2
supply_tax <- list(x=supply$x,y=supply$y + tax)

# save to df
df <- data.frame(q=supply$x, p=supply$y, type="supply") %>%
    rbind(data.frame(q=demand$x, p=demand$y,type="demand")) %>%
    rbind(data.frame(q=supply_tax$x, p=supply_tax$y,type="supply w tax"))

# calculate intersection points
X1 <- curve_intersect(supply, demand)
X2 <- curve_intersect(supply_tax,demand)
X1_lab <- paste0("(",round(X1$x,2),", ",round(X1$y,2),")")
X2_lab <- paste0("(",round(X2$x,2),", ",round(X2$y,2),")")

# plot
ggplot(df, aes(x=q,y=p, colour=type)) + geom_line() + 
    annotate("text",x=X1$x+0.8, y=X1$y, label = X1_lab) + 
    annotate("text",x=X2$x-0.8, y=X2$y, label = X2_lab) + theme_few() + scale_color_few() + 
    geom_point(x=X1$x, y=X1$y, col="black") +  geom_point(x=X2$x, y=X2$y, col="black") +
    labs(title="Steep Supply Curve with $2 Tax") + 
    scale_x_continuous(breaks =seq(0,10,2)) + scale_y_continuous(breaks =seq(0,10,2))  

With a steep supply curve, the consumer shares a smaller percentage of the tax burden.

In the example above, the consumer pays $0.31 of the $2 tax burden, or 15.5%.

The Industry bears primary responsibility for the tax in this approach

What if the supply curve is nearly horizontal ?

Flat Supply Curve

# flatter supply slope, average demnd
supply <- bezier(c(1,3,4,5,9), c(4.9,5,5.2,5.3,5.6))
demand <- bezier(c(1,3,9), c(9, 3, 1))

# add $2 tax and update supply curve
tax <- 2
supply_tax <- list(x=supply$x,y=supply$y + tax)

# save to df
df <- data.frame(q=supply$x, p=supply$y, type="supply") %>%
    rbind(data.frame(q=demand$x, p=demand$y,type="demand")) %>%
    rbind(data.frame(q=supply_tax$x, p=supply_tax$y,type="supply w tax"))

# calculate intersection points
X1 <- curve_intersect(supply, demand)
X2 <- curve_intersect(supply_tax,demand)
X1_lab <- paste0("(",round(X1$x,2),", ",round(X1$y,2),")")
X2_lab <- paste0("(",round(X2$x,2),", ",round(X2$y,2),")")

# plot
ggplot(df, aes(x=q,y=p, colour=type)) + geom_line() +
    annotate("text",x=X1$x+0.8, y=X1$y-0.4, label = X1_lab) + 
    annotate("text",x=X2$x, y=X2$y-0.5, label = X2_lab) + theme_few() + scale_color_few() + 
    geom_point(x=X1$x, y=X1$y, col="black") +  geom_point(x=X2$x, y=X2$y, col="black") +
    labs(title="Flat Supply Curve with $2 Tax") + 
    scale_x_continuous(breaks =seq(0,10,2)) + scale_y_continuous(breaks =seq(0,10,2))  

With a flatter supply curve, the consumer shares a larger proportion of the tax burden.

In the example above, the consumer pays $1.89 of the $2 tax burden, or 94.5%.

Week 14 Homework Assignment

Page B-17

Question 1

A company is assembling a team to carry out a series of operations. There are four members of the team: A, B, C and D, and four operations to be carried out. Each team member can carry out exactly one operation. All four operations must be carried out successfully for the overall project to succeed, however the probability of a particular team member succeeding in a particular operation varies, as shown in the table below. For example, if the team members were assigned to operations in the order ABCD, then the overall probability of successful completion of the project is (0.9)(0.6)(0.85)(0.7) = 0.3213. If there is any possible way that the team can be arranged such that the overall probability of success exceeds 45%, then the manager will approve the project. Will the manager approve the project? If yes, what is the arrangement of the team that gives the highest probability of success?

a <- c(0.9, 0.8, 0.9, 0.85)
b <- c(0.7, 0.6, 0.8, 0.7)
c <- c(0.85, 0.7, 0.85, 0.8)
d <- c(0.75, 0.7, 0.75, 0.7)
dat <- rbind(a,b,c,d)
colnames(dat) <- c(1,2,3,4)
dat

##      1   2    3    4
## a 0.90 0.8 0.90 0.85
## b 0.70 0.6 0.80 0.70
## c 0.85 0.7 0.85 0.80
## d 0.75 0.7 0.75 0.70

p_45 <- c()
row_names <- rownames(dat)
P <- combinat::permn(row_names)

for(p in P){
  success_rate <- dat[p[1],1] * dat[p[2],2] * dat[p[3],3] * dat[p[4],4]
  success_summary <- cat(p," => ", success_rate, "= (",dat[p[1],1],"*",dat[p[2],2],"*",dat[p[3],3],"*",dat[p[4],4],")")
  print(success_summary)
  if(success_rate >= 0.45){
    p_45 <- c(p_45, success_summary)
  }
}  

## a b c d  =>  0.3213 = ( 0.9 * 0.6 * 0.85 * 0.7 )NULL
## a b d c  =>  0.324 = ( 0.9 * 0.6 * 0.75 * 0.8 )NULL
## a d b c  =>  0.4032 = ( 0.9 * 0.7 * 0.8 * 0.8 )NULL
## d a b c  =>  0.384 = ( 0.75 * 0.8 * 0.8 * 0.8 )NULL
## d a c b  =>  0.357 = ( 0.75 * 0.8 * 0.85 * 0.7 )NULL
## a d c b  =>  0.37485 = ( 0.9 * 0.7 * 0.85 * 0.7 )NULL
## a c d b  =>  0.33075 = ( 0.9 * 0.7 * 0.75 * 0.7 )NULL
## a c b d  =>  0.3528 = ( 0.9 * 0.7 * 0.8 * 0.7 )NULL
## c a b d  =>  0.3808 = ( 0.85 * 0.8 * 0.8 * 0.7 )NULL
## c a d b  =>  0.357 = ( 0.85 * 0.8 * 0.75 * 0.7 )NULL
## c d a b  =>  0.37485 = ( 0.85 * 0.7 * 0.9 * 0.7 )NULL
## d c a b  =>  0.33075 = ( 0.75 * 0.7 * 0.9 * 0.7 )NULL
## d c b a  =>  0.357 = ( 0.75 * 0.7 * 0.8 * 0.85 )NULL
## c d b a  =>  0.4046 = ( 0.85 * 0.7 * 0.8 * 0.85 )NULL
## c b d a  =>  0.325125 = ( 0.85 * 0.6 * 0.75 * 0.85 )NULL
## c b a d  =>  0.3213 = ( 0.85 * 0.6 * 0.9 * 0.7 )NULL
## b c a d  =>  0.3087 = ( 0.7 * 0.7 * 0.9 * 0.7 )NULL
## b c d a  =>  0.312375 = ( 0.7 * 0.7 * 0.75 * 0.85 )NULL
## b d c a  =>  0.354025 = ( 0.7 * 0.7 * 0.85 * 0.85 )NULL
## d b c a  =>  0.325125 = ( 0.75 * 0.6 * 0.85 * 0.85 )NULL
## d b a c  =>  0.324 = ( 0.75 * 0.6 * 0.9 * 0.8 )NULL
## b d a c  =>  0.3528 = ( 0.7 * 0.7 * 0.9 * 0.8 )NULL
## b a d c  =>  0.336 = ( 0.7 * 0.8 * 0.75 * 0.8 )NULL
## b a c d  =>  0.3332 = ( 0.7 * 0.8 * 0.85 * 0.7 )NULL

print(p_45)

## NULL

There are no additional nodes left to expand.

Thereore, we have found the maximum probability solution CDBA.