WebR — Lema de Shephard e Concavidade da Função Custo

Carregando WebR...

# ============================================
# Lema de Shephard: verificacao numerica
# + Concavidade da funcao custo nos precos
# ============================================

# Cobb-Douglas: q = K^alpha * L^beta
alpha <- 1/3;  beta <- 2/3
q0 <- 10

# --- Funcao custo CD analitica ---
custo_cd <- function(w, v, q, a = alpha, b = beta) {
  s <- a + b
  kappa <- s * (a^(-a) * b^(-b))^(1/s)
  kappa * w^(b/s) * v^(a/s) * q^(1/s)
}

# --- Demandas condicionais analiticas ---
Lc_cd <- function(w, v, q, a = alpha, b = beta) {
  s <- a + b
  q^(1/s) * (b * v / (a * w))^(a/s)
}
Kc_cd <- function(w, v, q, a = alpha, b = beta) {
  s <- a + b
  q^(1/s) * (a * w / (b * v))^(b/s)
}

# --- Verificacao do Lema de Shephard ---
w0 <- 8; v0 <- 2; eps <- 1e-6

dC_dw_num <- (custo_cd(w0+eps, v0, q0) - custo_cd(w0-eps, v0, q0)) / (2*eps)
dC_dv_num <- (custo_cd(w0, v0+eps, q0) - custo_cd(w0, v0-eps, q0)) / (2*eps)

Lc_analitico <- Lc_cd(w0, v0, q0)
Kc_analitico <- Kc_cd(w0, v0, q0)

cat("====== LEMA DE SHEPHARD: VERIFICACAO ======\n")
cat("Parametros: alpha =", alpha, " beta =", beta, " q =", q0, "\n")
cat("Precos: w =", w0, " v =", v0, "\n\n")
cat("dC/dw (numerico):  ", round(dC_dw_num, 4), "\n")
cat("L^c (analitico):   ", round(Lc_analitico, 4), "\n")
cat("Diferenca:         ", round(abs(dC_dw_num - Lc_analitico), 8), "\n\n")
cat("dC/dv (numerico):  ", round(dC_dv_num, 4), "\n")
cat("K^c (analitico):   ", round(Kc_analitico, 4), "\n")
cat("Diferenca:         ", round(abs(dC_dv_num - Kc_analitico), 8), "\n\n")
cat("=> Lema de Shephard verificado!\n\n")

# --- Grafico: Concavidade de C(w, v0, q0) em w ---
par(mfrow = c(1, 2), mar = c(4.5, 4.5, 3, 1), bg = "#f8f9fa")

# Painel 1: C como funcao de w (fixando v)
w_seq <- seq(1, 20, length = 200)
C_w <- sapply(w_seq, function(w) custo_cd(w, v0, q0))

# Tangente no ponto w0 (pelo Lema, inclinacao = L^c)
tangente_w <- custo_cd(w0, v0, q0) + Lc_analitico * (w_seq - w0)

plot(w_seq, C_w, type = "l", lwd = 3, col = "#0d6efd",
     xlab = "w (salario)", ylab = "C(w, v0, q)",
     main = "Concavidade em w", cex.lab = 1.1)
lines(w_seq, tangente_w, lwd = 2, col = "#dc3545", lty = 2)
points(w0, custo_cd(w0, v0, q0), pch = 19, col = "#dc3545", cex = 1.5)
text(w0, custo_cd(w0, v0, q0), paste0("  w=", w0, "\n  incl = L^c = ", round(Lc_analitico, 2)),
     pos = 4, cex = 0.8, col = "#dc3545")
legend("topleft", legend = c("C(w, v0, q)", "Tangente (Shephard)"),
       col = c("#0d6efd", "#dc3545"), lwd = c(3, 2), lty = c(1, 2),
       cex = 0.85, bg = "white")

# Painel 2: C como funcao de v (fixando w)
v_seq <- seq(0.5, 15, length = 200)
C_v <- sapply(v_seq, function(v) custo_cd(w0, v, q0))

tangente_v <- custo_cd(w0, v0, q0) + Kc_analitico * (v_seq - v0)

plot(v_seq, C_v, type = "l", lwd = 3, col = "#198754",
     xlab = "v (custo do capital)", ylab = "C(w0, v, q)",
     main = "Concavidade em v", cex.lab = 1.1)
lines(v_seq, tangente_v, lwd = 2, col = "#dc3545", lty = 2)
points(v0, custo_cd(w0, v0, q0), pch = 19, col = "#dc3545", cex = 1.5)
text(v0, custo_cd(w0, v0, q0), paste0("  v=", v0, "\n  incl = K^c = ", round(Kc_analitico, 2)),
     pos = 4, cex = 0.8, col = "#dc3545")
legend("topleft", legend = c("C(w0, v, q)", "Tangente (Shephard)"),
       col = c("#198754", "#dc3545"), lwd = c(3, 2), lty = c(1, 2),
       cex = 0.85, bg = "white")

(Aguardando WebR...)