Examen 1
Julio Clemente, Eleazar Ramos
2025-11-07
Ejercicio 1
Una cadena de tiendas minoristas con presencia en todo Puerto Rico desea entender qué factores impulsan las ventas mensuales de sus sucursales. Cada tienda decide de forma autónoma cuánto invertir en publicidad televisiva y en redes sociales, lo que genera grandes variaciones en sus resultados. Además, las ventas pueden diferir según el tamaño físico del local y la competencia cercana, pues las tiendas grandes suelen tener mayor flujo de clientes, mientras que aquellas ubicadas en zonas con más competidores enfrentan mayores desafíos. La gerencia quiere usar un modelo de regresión lineal múltiple para cuantificar el impacto de estas variables y orientar futuras decisiones de inversión en mercadeo.
Simulación de datos
set.seed(4008)
n <- 300 #numero de tiendas
Publicidad_TV <- runif(n, 10, 100) #gasto mensual en TV en miles de dolares
Publicidad_Redes <- runif(n, 5, 80) #gasto mensual en redes sociales
Tamano <- runif(n, 100, 1000) # tamano en metro cuadrado
Competidores <- sample(1:6, n, replace = TRUE) # numero de competidores
Zona <- factor(sample(c("Centro", "Norte", "Sur"), n, replace = TRUE))
Zona <- relevel(Zona, ref = "Centro")
# Coeficientes elegidos
b0 <- 50
b_tv <- 0.35
b_redes <- 0.55
b_tam <- 0.04
b_comp <- 3
a_norte <- 3
a_sur <- 1
b_redes_norte <- 0.05
b_redes_sur <- -0.20
sd_error <- 6
# Construcción de formula de Ventas
#Dummies
efecto_zona <- ifelse(Zona == "Norte", a_norte,
ifelse(Zona == "Sur", a_sur, 0))
interaccion <- ifelse(Zona == "Norte", b_redes_norte * Publicidad_Redes,
ifelse(Zona == "Sur", b_redes_sur * Publicidad_Redes, 0))
#Formula de ventas
Ventas <- b0 +
b_tv * Publicidad_TV +
b_redes * Publicidad_Redes +
b_tam * Tamano +
b_comp * Competidores +
efecto_zona +
interaccion +
rnorm(n, 0, sd_error) #error
#Datos
datos <- data.frame(Ventas, Publicidad_TV, Publicidad_Redes, Tamano, Competidores, Zona)Model matrix con dummies
modelo <- model.matrix(Ventas ~ Publicidad_TV + Publicidad_Redes + Tamano
+Competidores + Zona +
Publicidad_Redes:Zona, data= datos)
#conversion a dataframe para poder utilizarlo en regsubsets
modelo <- as.data.frame(modelo)
modelo <- modelo[-1]
modelo_nuevo <- cbind(Ventas=datos$Ventas,modelo)Modelo saturado
reg <- lm(Ventas ~ Publicidad_TV + Publicidad_Redes + Tamano + Competidores + Zona +
Publicidad_Redes:Zona, data=datos)
summary(reg)##
## Call:
## lm(formula = Ventas ~ Publicidad_TV + Publicidad_Redes + Tamano +
## Competidores + Zona + Publicidad_Redes:Zona, data = datos)
##
## Residuals:
## Min 1Q Median 3Q Max
## -18.7515 -3.7074 -0.1065 3.8472 17.2080
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 52.052622 1.801721 28.890 < 2e-16 ***
## Publicidad_TV 0.356104 0.012928 27.546 < 2e-16 ***
## Publicidad_Redes 0.551749 0.027900 19.776 < 2e-16 ***
## Tamano 0.038702 0.001452 26.657 < 2e-16 ***
## Competidores 2.602730 0.202852 12.831 < 2e-16 ***
## ZonaNorte 0.209001 1.849858 0.113 0.9101
## ZonaSur 0.582941 2.162977 0.270 0.7877
## Publicidad_Redes:ZonaNorte 0.085620 0.038308 2.235 0.0262 *
## Publicidad_Redes:ZonaSur -0.227939 0.045896 -4.966 1.16e-06 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 5.954 on 291 degrees of freedom
## Multiple R-squared: 0.9147, Adjusted R-squared: 0.9124
## F-statistic: 390.1 on 8 and 291 DF, p-value: < 2.2e-16Modelo por subconjuntos
ajuste <- regsubsets( Ventas~.,
data = modelo_nuevo,
nvmax = 8,
method = "exhaustive")
s <- summary(ajuste)Graficos BIC y R2
Interpretación
En este caso, ambos modelos, tanto BIC como R2, resultaron en un ideal de 6 variables.Por lo cual, cualquiera de los dos modelos se puede utilizar para el modelo de regresión final.
Variables de modelo R2
coef_best <- coef(ajuste, best_r2)
vars_best <-names(coef_best)
vars_best## [1] "(Intercept)" "Publicidad_TV"
## [3] "Publicidad_Redes" "Tamano"
## [5] "Competidores" "`Publicidad_Redes:ZonaNorte`"
## [7] "`Publicidad_Redes:ZonaSur`"Modelo Final utilizando variables de modelo R2
f_final <- as.formula(paste("Ventas ~",
paste(vars_best[-1], collapse = " + ")))
modelo_final <- lm(f_final, data = modelo_nuevo)
summary(modelo_final)##
## Call:
## lm(formula = f_final, data = modelo_nuevo)
##
## Residuals:
## Min 1Q Median 3Q Max
## -18.7413 -3.7591 -0.1369 3.9133 17.2781
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 52.234528 1.541599 33.883 < 2e-16 ***
## Publicidad_TV 0.356234 0.012805 27.819 < 2e-16 ***
## Publicidad_Redes 0.547692 0.019857 27.582 < 2e-16 ***
## Tamano 0.038719 0.001438 26.921 < 2e-16 ***
## Competidores 2.605768 0.201802 12.913 < 2e-16 ***
## `Publicidad_Redes:ZonaNorte` 0.089658 0.016445 5.452 1.06e-07 ***
## `Publicidad_Redes:ZonaSur` -0.216678 0.018927 -11.448 < 2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 5.935 on 293 degrees of freedom
## Multiple R-squared: 0.9147, Adjusted R-squared: 0.9129
## F-statistic: 523.5 on 6 and 293 DF, p-value: < 2.2e-16Interpretación
El modelo de regresión ajustado logra explicar un 91.3% de la variabilidad de las ventas mensuales de las tiendas. Además, todas las variables evaluadas resultaron ser significativas para las ventas. Logramos ver que por cada mil dólares invertidos en publicidad televisiva, las ventas aumentan por un promedio de 0.36 en miles de dólares, mientras que por cada mil dólares invertidos en publicidad en las redes en la zona central, las ventas aumentan $550. El tamaño de la tienda también resultó significativo ya que logramos ver que por cada metro cuadrado adicional, las ventas aumentan por $39. Además, en este modelo logramos ver diferencias por área. Podemos ver que la interacción entre la inversión en publicidad por redes sociales tiene un efecto positivo en el área Norte si lo comparamos al área centro (0.55+0.09), en cambio, en la zona sur, la interacción tiene un efecto negativo en comparación al área centro (0.55-0.22). Evaluando el modelo, podemos determinar que la empresa debería considerar estrategias más enfocadas en las redes en el área norte ya que es donde es más efectiva. Mientras tanto, en el área sur, debería adoptar otro tipo de estrategia para así regular los niveles de impacto en las ventas cuando se compare con las otras áreas.
Supuestos de modelo:
Gráfico para visualizar normalidad de los datos
df1 <- data.frame(
yhat1 = fitted.values(modelo_final),
res1 = rstandard(modelo_final)
)
library(ggplot2)
ggplot(df1, aes(sample = res1)) +
stat_qq(color = "blue") +
stat_qq_line(linewidth = 1) +
labs(x = "Cuantiles teóricos", y = "Cuantiles muestrales") +
theme_minimal(base_size = 14)
Prueba de shapiro para comprobar normalidad
shapiro.test(df1$res1)##
## Shapiro-Wilk normality test
##
## data: df1$res1
## W = 0.99805, p-value = 0.9806Interpretación
Visualmente, logramos observar que los datos siguen en su mayoría una distribución normal ya que se acercan bastante a la línea que mide la misma. Además, la prueba shapiro confirma que los datos siguen una distribución ya que el valor del pvalue es mayor que 0.05 y el valor de W se encuentra en el 99% del rango de confianza lo cual afirma el supuesto.
Gráfico para visualizar homocedasticidad
ggplot(df1, aes(x = yhat1, y = res1)) +
geom_point(alpha = 0.6, color = "blue") +
geom_hline(yintercept = 0, linetype = "dashed", color = "grey40") +
labs(x = "Valores ajustados", y = "Residuales estandarizados") +
theme_minimal(base_size = 14)
Prueba bp para comprobar varianza constante
bptest(modelo_final)##
## studentized Breusch-Pagan test
##
## data: modelo_final
## BP = 6.9211, df = 6, p-value = 0.3282Interpretación
Visualmente, logramos comprobar que los datos siguen una varianza constante ya que se encuentran posicionados bastante relacionados entre si y la dispersión no es muy lejana. Cuando pasamos a la prueba Breush-Pagan, logramos afirmar que la varianza es constante ya que el pvalue resultó mayor a 0.05. El modelo cuenta con un comportamiento adecuado.
Gráfico para visualizar independencia
df3 <- data.frame(res3 = rstandard(modelo_final)) %>%
mutate(orden = 1:length(res3))
ggplot(df3, aes(x = orden, y = res3)) +
geom_point(alpha = 0.6, color = "blue") +
geom_hline(yintercept = 0, linetype = "dashed", color = "grey40") +
labs(x = "Orden/tiempo", y = "Residuales estandarizados") +
theme_minimal(base_size = 14)
Prueba dw para comprobar independencia
dwtest(modelo_final)##
## Durbin-Watson test
##
## data: modelo_final
## DW = 1.9849, p-value = 0.4513
## alternative hypothesis: true autocorrelation is greater than 0Interpretación
Visualmente, los datos no siguen ningún patrón en expecífico pero si se notan bastante cercanos entre si. Sin embargo, cuando se realizó la prueba Durbin-Watson, se logró comprobar que los datos si son independientes ya que el pvalue resultó mayor a 0.05 y el valor de DW resultó cercano a 2 el cual afirma la hipótesis de que los datos son independientes.
Ejercicio 2:
Una institución financiera desea identificar qué factores influyen en la aprobación de solicitudes de crédito personal. La dirección del banco sospecha que la probabilidad de aprobación depende de características financieras y demográficas de los solicitantes, como su nivel de ingresos, el grado de endeudamiento, la edad y la solidez de su historial crediticio. Además, se considera relevante si el cliente ofrece una garantía real al momento de solicitar el préstamo. El objetivo es utilizar un modelo de regresión logística que permita estimar la probabilidad de aprobación y determinar qué variables aumentan o reducen las posibilidades de que una solicitud sea aceptada. Con esta información, la gerencia podrá diseñar políticas crediticias más claras y transparentes, equilibrando el riesgo con la oportunidad de captar nuevos clientes.
set.seed(4008) #seleccionando la semilla para que las simulaciones resulten en los mismos números.(2005 + 2003)Variables simuladas
n <- 600 #Tamaño de muestra
Ingreso <- round(runif(n, 4, 5), 2) #en miles de $$$, asumiendo una media de $4,000 de ingreso mensual.
Deuda <- round(runif(n, 0, 1), 2) #Nivel de endeudamiento en porcentaje.
Edad <- round(rnorm(n, mean = 40, sd = 10), 0)
Historial <- factor(sample(c("Buena", "Regular", "Mala"), n, replace = TRUE)) #Historial crediticio del aplicante.
Garantia <- factor(sample(c("Sí", "No"), n, replace = TRUE)) #Si ofrece grantía real al momento de aplicar.
# Dummies
HistorialRegular <- ifelse(Historial == "Regular", 1, 0)
HistorialMala <- ifelse(Historial == "Mala", 1, 0)
GarantiaNo <- ifelse(Garantia == "No", 1, 0)
# Coeficientes elegidos dentro de los rangos sugeridos
b0 <- -3.5
b1 <- 0.07
b2 <- -2.3
b3 <- 0.12
a1 <- -1.0
a2 <- -2.0
b4 <- 1.0
b5_reg <- -0.6
b5_mal <- -1.0
# Error
error <- rnorm(n, 0, 0.75)
# Modelo
eta <- b0 + b1 * Ingreso + b2 * Deuda + b3 * Edad +
a1 * HistorialRegular + a2 * HistorialMala +
b4 * GarantiaNo +
b5_reg * (Deuda * HistorialRegular) +
b5_mal * (Deuda * HistorialMala) +
error
# Probabilidad de aprobación
p <- 1/(1 + exp(-eta))
# Variable que deseamos explicar
Aprobado <- ifelse(runif(n) < p, 1, 0)
# Data frame
datos <- data.frame(Aprobado, Ingreso, Deuda, Edad, Historial, Garantia)
head(datos)## Aprobado Ingreso Deuda Edad Historial Garantia
## 1 1 4.13 0.71 61 Regular No
## 2 0 4.23 0.53 36 Mala Sí
## 3 0 4.21 0.08 46 Regular No
## 4 0 4.04 0.30 30 Buena No
## 5 1 4.91 0.30 50 Regular Sí
## 6 0 4.41 0.89 40 Regular NoAjuste de modelo
modelo1 <- glm(Aprobado ~ Ingreso + Edad + Garantia + Deuda*Historial, family = binomial, data=datos)
coefs <- summary(modelo1)$coefficientsTabla de resultados
Se crea una tabla que nos calcule los valores de los Odds Ratios de cada logit para una interpretación más fácil.
tabla_mod1 <- data.frame(
Termino = rownames(coefs),
Logit = round(coefs[, 1], 3),
Odds_Ratio = round(exp(coefs[, 1]), 3),
row.names = NULL)
tabla_mod1## Termino Logit Odds_Ratio
## 1 (Intercept) -6.566 0.001
## 2 Ingreso 0.836 2.308
## 3 Edad 0.137 1.147
## 4 GarantiaSí -0.962 0.382
## 5 Deuda -2.903 0.055
## 6 HistorialMala -2.341 0.096
## 7 HistorialRegular -1.580 0.206
## 8 Deuda:HistorialMala 0.246 1.279
## 9 Deuda:HistorialRegular 0.602 1.826Interpretaciones:
Intercepto: (OR = 0.001) indica que, en ausencia de los demás factores (no hay Ingreso, Edad es 0, no tiene Garantía, no tiene Deudas y tiene Historial malo), la probabilidad base de que una solicitud sea aprobada es muy baja. Este intercepto no es el más útil por sí solo, dado a que es raro que alguien que no tenga ingresos solicite un préstamo, y es imposible solicitar un préstamo si acabas de nacer.
Ingreso: Por cada unidad adicional en el ingreso (por cada $1,000 más al mes), la probabilidad de aprobación aumenta en aproximadamente 131% respecto a no ser aprobado (2.308 − 1 = 1.308), manteniendo constantes las demás variables numéricas, y asumiendo que las variables categóricas son iguales a la referencia.
Edad: Por cada año adicional de edad, la probabilidad de aprobación aumenta en 14.7% respecto a no ser aprobado (1.147 − 1 = 0.147), manteniendo constantes las demás variables numéricas, y asumiendo que las variables categóricas son iguales a la referencia.
Garantía: Los solicitantes con garantía presentan una probabilidad de aprobación 61.8% menor que aquellos sin garantía (1 − 0.382 = 0.618), manteniendo constantes las variables numéricas, y asumiendo que las variables categóricas son iguales a la referencia.
Deuda: Por cada aumento de una unidad en la proporción de deuda, la probabilidad de aprobación disminuye en 94.5% respecto a no ser aprobado (1 − 0.055 = 0.945), manteniendo constantes las demás variables numéricas, y asumiendo que las variables categóricas son iguales a la referencia.
Historial crediticio “Regular”: Tener un historial regular reduce la probabilidad de aprobación en 79.4% respecto a quienes tienen un historial bueno (1 − 0.206 = 0.794), manteniendo constantes las variables numéricas, y asumiendo que las variables categóricas son iguales a la referencia.
Historial crediticio “Malo”: Tener un historial malo reduce la probabilidad de aprobación en 90.4% respecto a quienes tienen un historial bueno (1 − 0.096 = 0.904), manteniendo constantes las variables numéricas, y asumiendo que las variables categóricas son iguales a la referencia.
Interacción de Deuda e Historial Regular: Cuando el solicitante tiene historial regular, el efecto negativo de la deuda se disminuye un poco. La probabilidad de aprobación aumenta en 82.6% adicional (1.826 − 1 = 0.826) respecto al efecto original de la deuda, manteniendo constantes las demás variables numéricas, y asumiendo que las variables categóricas son iguales a la referencia.
Interacción Deuda × Historial Malo: Cuando el solicitante tiene historial malo, el efecto negativo de la deuda disminuye por un 27.9% adicional (1.279 − 1 = 0.279) respecto al efecto original de la deuda, manteniendo constantes las demás variables numéricas, y asumiendo que las variables categóricas son iguales a la referencia.