inst/doc/horizontal-merger-simulations.R

In mergersim: Merger Simulation and Calibration

## ----include = FALSE----------------------------------------------------------
knitr::opts_chunk$set(
  collapse = TRUE,
  comment = "#>"
)

## ----setup--------------------------------------------------------------------
library(mergersim)

## -----------------------------------------------------------------------------
library(BB)
library(rootSolve)
library(numDeriv)

## -----------------------------------------------------------------------------
alpha_true  <- -0.9
delta_true <- c(.81,.93,.82)
c_j <- c(.05,.31,.30)

## -----------------------------------------------------------------------------
own_pre = diag(3)
own_post <- own_pre
own_post[1,2] <- 1
own_post[2,1] <- 1

## -----------------------------------------------------------------------------
x0 <- c_j*1.1
out1 <- multiroot(f = bertrand_foc, start = x0, 
                  own = own_pre, alpha= alpha_true, 
                  delta = delta_true, cost = c_j)

p1 <- out1$root
p1
share1 <- (exp(delta_true + alpha_true*p1))/(1+sum(exp(delta_true + alpha_true*p1)))
share1

## -----------------------------------------------------------------------------
x0 <- c_j*1.1
out1_post <- multiroot(f = bertrand_foc ,start = x0, 
                  own = own_post, alpha= alpha_true, 
                  delta = delta_true, cost = c_j)

p1_post <- out1_post$root
p1_post
share1_post <- (exp(delta_true + alpha_true*p1_post))/(1+sum(exp(delta_true + alpha_true*p1_post)))
share1_post

# margins. Note that multi-product firm sets same level margins.
(p1_post - c_j)
(p1_post - c_j)/p1_post

# price effect
(p1_post - p1)/p1_post


## ----results = "hide", warning=FALSE------------------------------------------
x00 <- c(-1)
wt_vector <- c(1,1,1)

out1 <- optim(f = bertrand_calibrate, par = x00, 
                   own = own_pre, price = p1, 
                   shares = share1, cost  = c_j,
                   weight = wt_vector,
              method = "Brent",lower = -10, upper = -.1)




## -----------------------------------------------------------------------------

# note that this optimization recovers the true demand parameters
out1$par
alpha_true

delta_cal <- log(share1) - log(1-sum(share1)) - out1$par*p1
delta_cal
delta_true

## ----eval = TRUE--------------------------------------------------------------
c_obs <- c_j
c_obs[3] <- NA
c_obs

## ----results = "hide", warning=FALSE------------------------------------------
x00 <- c(-1)
wt_vector <- c(1,1)

out1b <- optim(f = bertrand_calibrate, par = x00, 
                   own = own_pre, price = p1, 
                   shares = share1, cost  = c_obs,
                   weight = wt_vector,
               method = "Brent",lower = -10, upper = -.1)



## -----------------------------------------------------------------------------

# this optimization recovers the true demand parameters
out1b$par
alpha_true

delta_cal <- log(share1) - log(1-sum(share1)) - out1b$par*p1
delta_cal
delta_true

## ----eval = TRUE--------------------------------------------------------------
share2 <- (exp(delta_true + alpha_true*c_j))/(1+sum(exp(delta_true + alpha_true*c_j)))

p2 <- c_j + log(1 - own_pre%*%share2)/(alpha_true*own_pre%*%share2)
p2_post <- c_j + log(1 - own_post%*%share2)/(alpha_true*own_post%*%share2)

(p2_post - p2)/p2

## -----------------------------------------------------------------------------
c_obs <- c_j
c_obs[3] <- NA
c_obs

## -----------------------------------------------------------------------------
wt_vector <- c(1,1)

result4 <- BBoptim(f = ssa_calibrate, par = c(-.2),
                    lower = c(-Inf), upper = c(-0.0001),
                    own=own_pre, price = p2, share = share2,
                    cost = c_obs, weight = wt_vector)

alpha4 <- result4$par
alpha4       # recover true value

## -----------------------------------------------------------------------------
cost4 <- p2 - log(1 - own_pre%*%share2) / (alpha4*own_pre%*%share2)
cost4

## -----------------------------------------------------------------------------
c_j

## -----------------------------------------------------------------------------
p4 <- cost4 + log(1 - own_pre%*%share2)/(alpha4*own_pre%*%share2)
p4_post <- cost4 + log(1 - own_post%*%share2)/(alpha4*own_post%*%share2)

(p4_post - p4)/p4

## -----------------------------------------------------------------------------
1/(p4[1] - c_obs[1]) * log(1 - share2[1]) / share2[1]

## -----------------------------------------------------------------------------
x0 <- c_j*1.5

out3 <- multiroot(f = bargain_foc, start = x0, own = own_pre, 
                  alpha = alpha_true, delta = delta_true, cost = c_j,
                  lambda = 0.5)
p3 <- out3$root
share3 <- (exp(delta_true + alpha_true*p3))/(1+sum(exp(delta_true + alpha_true*p3)))

print(p3)
print(share3)


## ----eval = TRUE--------------------------------------------------------------
J <- length(c_j)
alpha_start <- -1.2
delta_start <- rep(1,J)
x00 <- c(alpha_start,delta_start)
wt_vector <- rep(1, times = J*2)


bargain_calibrate(param = x00, 
                       own = own_pre, price = p3, 
                       shares = share3, cost  = c_j,
                       weight = wt_vector, lambda = 0.5)


out3 <- BBoptim(f = bargain_calibrate, par = x00, 
                own = own_pre, price = p3, 
                shares = share3, cost  = c_j,
                weight = wt_vector, lambda = 0.5)

# check if we recovered correct demand parameters
# finding good initial values is important.
alpha3 <- out3$par[1]
delta3 <- out3$par[2:4]
alpha_true
alpha3
delta_true
delta3

## -----------------------------------------------------------------------------
x0 <- c_j*1.5

out4 <- multiroot(f = ssbargain_foc, start = x0, own = own_pre, 
                       alpha = alpha_true, delta = delta_true, 
                  cost = c_j, lambda = 0.5)
p4 <- out4$root
share4 <- (exp(delta_true + alpha_true*c_j))/(1+sum(exp(delta_true + alpha_true*c_j)))

print(p4)
print(share4)


## -----------------------------------------------------------------------------
alpha_start <- -1.2
delta_start <- rep(1,J)
x00 <- c(alpha_start,delta_start)
wt_vector <- rep(1, times = J*2)

out4 <- BBoptim(f = ssbargain_calibrate, par = x00, 
                own = own_pre, price = p4, 
                shares = share4, cost  = c_j,
                weight = wt_vector, lambda = 0.5)

# check if we recovered correct demand parameters
# finding good initial values is important.
alpha4 <- out4$par[1]
delta4 <- out4$par[2:4]
alpha_true
alpha4
delta_true
delta4

## -----------------------------------------------------------------------------
K1 <- 2

B1 <- 1 * matrix( c(1,0,
               1,0,
               0,1),
             ncol = K1, nrow = J, byrow = TRUE)
a1 <- B1    # rows of a should sum to 1 to facilitate interpretation.
mu1 <- rep(1.0,K1) # nesting parameters all 1 simplifies to logit
mu2 <- c(0.8,0.8)

## ----results = "hide"---------------------------------------------------------

x0 <- p1*1.1

out1 <- BBoptim(fn = bertrand_foc, par = x0, 
                own = own_pre, alpha = alpha_true, 
                delta = delta_true, cost = c_j, sumFOC = TRUE)

p_R1 <- out1$par

## ----eval = FALSE-------------------------------------------------------------
#  # Equilibrium prices are the same as we had from logit model before
#  p_R1
#  p1
#  

## ----results = "hide"---------------------------------------------------------

x0 <- p1*1.1

out2 <- BBoptim(fn = bertrand_foc, par = x0, 
                own = own_pre, alpha = alpha_true, 
                delta = delta_true, cost = c_j,
                nest_allocation=a1, mu=mu2,
                sumFOC = TRUE)

p_R2 <- out2$par

## -----------------------------------------------------------------------------
# Equilibrium prices are different than logit result
p_R2
  

## -----------------------------------------------------------------------------
diversions <- diversion_calc(price=p_R2,alpha=alpha_true,delta=delta_true,
                             nest_allocation=a1,mu=mu2)

diversions
rowSums(diversions) # each row should sum to <1 because of outside option

## -----------------------------------------------------------------------------
diversions2 <- diversion_calc(price=p_R2,alpha=alpha_true, delta=delta_true,
                              nest_allocation=a1, mu=mu2, marginal = TRUE)

diversions2
rowSums(diversions2) # each row should sum to <1 because of outside option