Examen Grupal 1

Parte 1

1. Simulación de datos:

set.seed(2006) #semilla
n <- 300

# Predictores
Publicidad_TV <- round(runif(n, 0, 100))
Publicidad_Redes <- round(runif(n, 0, 80))
Tamano <- round(runif(n, 50, 500))
Competidores <- sample(1:8, n, replace = TRUE)
Zona <- factor(sample(c("Centro", "Norte", "Sur"), n, replace = TRUE, prob = c(0.45, 0.30, 0.25)), levels = c("Centro", "Norte", "Sur"))

# Coeficientes
b0 <- 50
b_TV <- 0.35
b_Red <- 0.55
b_Tam <- 0.04
b_Comp <- -3
b_ZNorte <- 4
b_ZSur <- -2
b_RZNorte <- 0.05
b_RZSur <- -0.10
sd_ruido <- 8

ruido <- rnorm(n, mean = 0, sd = sd_ruido)

# Variable dependiente
Ventas <- b0 + b_TV * Publicidad_TV + b_Red * Publicidad_Redes + b_Tam * Tamano + b_Comp * Competidores +
  ifelse(Zona == "Norte", b_ZNorte, ifelse(Zona == "Sur", b_ZSur, 0)) +
  ifelse(Zona == "Norte", b_RZNorte * Publicidad_Redes,  ifelse(Zona == "Sur", b_RZSur * Publicidad_Redes, 0)) +
  ruido

# Evitar valores negativos
Ventas <- round(pmax(Ventas, 0), 2)

# Conjunto de datos
datos <- data.frame(Ventas, Publicidad_TV, Publicidad_Redes, Tamano, Competidores, Zona)

head(datos)

##   Ventas Publicidad_TV Publicidad_Redes Tamano Competidores   Zona
## 1 100.27            89               39    110            5 Centro
## 2 109.90            88               33    107            2    Sur
## 3  65.53            21               24    356            8 Centro
## 4 102.03            51               70    319            5 Centro
## 5  84.31            20               72    223            1    Sur
## 6 102.24            78               44    157            2 Centro

2. Ajuste del modelo:

Se va a evaluar que modelo vamos a escoger entre: el modelo por subconjuntos y el modelo paso a paso.

A. Modelo por subconjuntos:

Se calculó el modelo saturado, en donde se encuentran todas las variables.

saturado <- Ventas ~ Publicidad_TV + Publicidad_Redes + Tamano + Competidores + Zona + Publicidad_Redes*Zona

reg <- lm(saturado, data = datos)

summary(reg)

## 
## Call:
## lm(formula = saturado, data = datos)
## 
## Residuals:
##      Min       1Q   Median       3Q      Max 
## -22.0186  -5.5952  -0.7356   5.0048  24.4161 
## 
## Coefficients:
##                             Estimate Std. Error t value Pr(>|t|)    
## (Intercept)                51.652858   2.127818  24.275   <2e-16 ***
## Publicidad_TV               0.344581   0.016282  21.163   <2e-16 ***
## Publicidad_Redes            0.546687   0.028511  19.175   <2e-16 ***
## Tamano                      0.038337   0.003758  10.202   <2e-16 ***
## Competidores               -2.978294   0.211964 -14.051   <2e-16 ***
## ZonaNorte                   2.513661   2.250508   1.117   0.2649    
## ZonaSur                    -5.063877   2.282717  -2.218   0.0273 *  
## Publicidad_Redes:ZonaNorte  0.048513   0.048990   0.990   0.3229    
## Publicidad_Redes:ZonaSur   -0.083027   0.048026  -1.729   0.0849 .  
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 8.25 on 291 degrees of freedom
## Multiple R-squared:  0.8486, Adjusted R-squared:  0.8444 
## F-statistic: 203.9 on 8 and 291 DF,  p-value: < 2.2e-16

Selección de modelo por subconjunto:

library(leaps)

ajuste <- regsubsets(
  saturado,
  data = datos,
  nvmax = 7,              
  method = "exhaustive")

s <- summary(ajuste)

names(s)

## [1] "which"  "rsq"    "rss"    "adjr2"  "cp"     "bic"    "outmat" "obj"

Se identificó el mejor modelo entre BIC y R^2 ajustado.

best_bic <- which.min(s$bic)
best_r2  <- which.max(s$adjr2)

best_bic

## [1] 6

best_r2

## [1] 7

Cuando son comparados, el mejor modelo resulta ser el de R^2 ajustado.

B. Modelo paso a paso:

Se utlizó el mismo modelo saturado del ajuste de modelo de subconjuntos, y se calculó el modelo nulo.

saturado <- Ventas ~ Publicidad_TV + Publicidad_Redes*Zona + Competidores + Tamano
reg <- lm(saturado, data = datos)
nulo <- lm(Ventas ~ 1, data = datos)

Forward stepwise selection:

step_forward <- step(nulo,
                     scope = list(lower = ~1, upper = formula(reg)),
                     direction = "forward",
                     k = log(nrow(datos)),
                     trace = FALSE)

Backward stepwise selection:

step_backward <- step(reg,
                      direction = "backward",
                      k = log(nrow(datos)),
                      trace = FALSE)

Hybrid:

step_both <- step(nulo,
                  scope = list(lower = ~1, upper = formula(reg)),
                  direction = "both",
                  k = log(nrow(datos)),
                  trace = FALSE)

Modelo final (Hybrid):

modelo1 <- step_both
summary(modelo1)

## 
## Call:
## lm(formula = Ventas ~ Publicidad_Redes + Publicidad_TV + Competidores + 
##     Tamano + Zona, data = datos)
## 
## Residuals:
##      Min       1Q   Median       3Q      Max 
## -22.3644  -5.5982  -0.8404   5.2552  24.8053 
## 
## Coefficients:
##                   Estimate Std. Error t value Pr(>|t|)    
## (Intercept)      52.149172   1.917401  27.198  < 2e-16 ***
## Publicidad_Redes  0.536932   0.020095  26.720  < 2e-16 ***
## Publicidad_TV     0.342088   0.016340  20.935  < 2e-16 ***
## Competidores     -2.952375   0.212861 -13.870  < 2e-16 ***
## Tamano            0.038092   0.003781  10.075  < 2e-16 ***
## ZonaNorte         4.300413   1.156619   3.718  0.00024 ***
## ZonaSur          -8.393525   1.184874  -7.084 1.05e-11 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 8.304 on 293 degrees of freedom
## Multiple R-squared:  0.8456, Adjusted R-squared:  0.8424 
## F-statistic: 267.4 on 6 and 293 DF,  p-value: < 2.2e-16

3. Interpretación de salida:

En el modelo final tenemos un intercepto de 52.14, lo que sugiere que ese es el valor esperado de ventas cuando todas las variables son 0 y la zona es la base o centro. El coeficiente de “Publicidad_Redes” lo podemos interpretar como: por cada unidad adicional invertida en publicidad en redes sociales, las ventas aumentan en promedio 0.54 unidades, manteniendo las demás variables constantes. Mientras que el coeficiente de “Publicidad_TV” nos deja saber que por cada unidad adicional invertida en publicidad televisiva, las ventas aumentan en promedio 0.34 unidades, manteniendo las demás variables constantes. En cuanto a la variable de competidores, como es de esperarse, tiene una relación negativa y por cada competidor adicional en el mercado, las ventas reducen en promedio 2.95 unidades, manteniendo las demás variables constantes. En referencia a la variable tamaño, con un coeficiente de 0.038, nos deja saber que mientras más grande una tienda, mayores ventas tiene. Por cada unidad adicional en el tamaño del negocio, las ventas aumentan en promedio o.038 unidades si se mantienen las demás variables constantes. Las empresas ubicadas en la zona norte tienen un promedio 4.30 unidades más de ventas que las de la zona centro, controlando por las demás variables. Mientras que la zona sur tiene un promedio de -8.39 unidades menos de ventas que las del centro.

Por otro lado tenemos el valor de “Adjusted R-squared”, este nos deja saber que el modelo seleccionado explica el 84.26% de la variación en las ventas y que sus predicciones difieren de las ventas reales + o - 8.30 unidades.

4. Evaluación de los supuestos:

a. Normalidad

library(ggplot2)
library(broom)


df  <- data.frame(
 yhat = fitted.values(modelo1),
 res  = rstandard(modelo1))

ggplot(df, aes(sample = res)) +
  stat_qq(color = "blue") +
  stat_qq_line(linewidth = 1) +  
  labs(x = "Cuantiles teóricos", y = "Cuantiles muestrales") +
  theme_minimal(base_size = 14)

Prueba Shapiro-Wilk:

shapiro.test(df$res)

## 
##  Shapiro-Wilk normality test
## 
## data:  df$res
## W = 0.99426, p-value = 0.3188

Cuando analizamos el supuesto de normalidad por medio de la gráfica, podemos decir que se cumple el supuesto ya que los puntos están bien cerca a la línea del modelo y no hay desviaciones. Si tomamos en consideración la Prueba Shapiro-Wilks, también cumple el supuesto de normalidad porque el p-value es mayor que 0.05 y no se rechazaría la hipótesis nula de normalidad, los residuos del modelo se distrubuyen de forma aproximadamente normal.

b. Varianza constante

ggplot(df, aes(x = yhat, y = res)) +
  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 Breusch-Pagan:

library(lmtest)
bptest(modelo1)

## 
##  studentized Breusch-Pagan test
## 
## data:  modelo1
## BP = 3.8952, df = 6, p-value = 0.6909

Para que se cumpla el supuesto de varianza constante por el gráfico, la nube de puntos debe permanecer constante alrededor del 0 y en este caso podemos ver eso mismo en la gráfica. Además tiene la misma cantidad de valores para la Y, dos positivos y dos negativos, algo que respalda que los puntos se encuentran constantes alrededor del cero. Igualmente, podemos acompañar el análisis del gráfico con la Prueba Breusch-Pagan. Aquí tendriamos que H0 = la varianza es constante y que H1 = la varianza no es constante. Tenemos un p-value de 0.06996, no se rechaza la hipótesis nula y podemos decir que el modelo cumple con el supuesto de varianza constante de acuerdo al gráfico y a la Prueba Breusch-Pagan.

c. Independencia

library(ggplot2)
library(tidyverse)

df1 <- data.frame(
  res   =  rstandard(modelo1)) %>%
  mutate(orden = 1:length(res))   
  

ggplot(df1, aes(x = orden, y = res)) +
  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 Durbin-Watson:

dwtest(modelo1)

## 
##  Durbin-Watson test
## 
## data:  modelo1
## DW = 1.9985, p-value = 0.4993
## alternative hypothesis: true autocorrelation is greater than 0

Para que se cumpla el supuesto de independencia por el gráfico, la nube de puntos debe permanecer constante alrededor del 0 y en este caso podemos ver eso mismo en la gráfica. Además tiene la misma cantidad de valores para la Y, dos positivos y dos negativos, algo que respalda que los puntos se encuentran constantes alrededor del cero.Para que se cumpla el supuesto de varianza constante por el gráfico, la nube de puntos debe permanecer constante alrededor del 0 y en este caso podemos ver eso mismo en la gráfica. Además tiene la misma cantidad de valores para la Y, dos positivos y dos negativos, algo que respalda que los puntos se encuentran constantes alrededor del cero al igual que ocurrión en el supuesto de varianza constante. Por otro lado, podemos evaluar la Prueba Durbin Watson, teniendo en cuenta que H0 = independencia y que H1 = dependencia. El resultado es un p-value de 0.4993 que es mayor a 0.05 y podemos decir que cumple con el supuesto de independencia también.

Parte 2

Simulación de datos:

set.seed(2006) #semilla

n <- 600
# Predictores
Ingreso <- pmax(0, round(rlnorm(n, meanlog = log(60), sdlog = 0.80),1))
Deuda <- pmax(0, round(runif(n, 0, 1), 2))
Edad <-  pmax(0, round(rlnorm(n, meanlog = log(45), sdlog = 0.10)))
Historial <- factor(
  sample(c("Buena", "Regular", "Mala"), n, replace = TRUE, prob = c(0.50, 0.25, 0.20)),
  levels = c("Buena", "Regular", "Mala"))
Garantia <- factor(
  sample(c("No", "Si"), n, replace = TRUE, prob = c(0.70, 0.30)),
  levels = c("No", "Si"))
  
# Coeficientes
b0 <- -5
b_Ing <- 0.07
b_Deuda <- -1.5
b_Edad <- 0.13
b_HReg <- -0.2
b_HMal <- -2.2
b_Gar <- 0.9
b_DHReg <- -0.1
b_DHMal <- -1.1
sd_error <- 0.73

error <- rnorm(n, mean = 0, sd = sd_error)
  
# Variable dependiente
eta <- b0 + b_Ing * Ingreso + b_Deuda * Deuda + b_Edad * Edad + ifelse(Historial == "Regular", b_HReg , 0) + ifelse(Historial == "Mala", b_HMal, 0) + ifelse(Garantia == "No", b_Gar, 0) + ifelse(Historial == "Regular", b_DHReg * Deuda, 0) + ifelse(Historial == "Mala", b_DHMal * Deuda, 0) +
  error

p <- 1 / (1+exp(-eta))

Aprobado <- rbinom(n, 1, p)

# Conjunto de datos
datos2 <- data.frame(Aprobado, Ingreso, Deuda, Edad, Historial, Garantia)

head(datos2)

##   Aprobado Ingreso Deuda Edad Historial Garantia
## 1        1   158.6  0.42   48      Mala       Si
## 2        0    31.6  0.79   46   Regular       Si
## 3        1    30.5  0.06   44      Mala       Si
## 4        1    92.4  0.25   46   Regular       No
## 5        1    40.5  0.98   46     Buena       No
## 6        1    62.8  0.45   50     Buena       No

2. Ajuste del modelo:

modelo2 <- glm(Aprobado ~ Ingreso + Edad + Deuda*Historial + Garantia, family = binomial, data = datos2)

coefs <- summary(modelo2)$coefficients

#Tabla
tabla_modelo <- data.frame(
  Termino = rownames(coefs),
  Logit = round(coefs[, "Estimate"], 3),
  Odds_Ratio = round(exp(coefs[, "Estimate"]), 3),
  row.names = NULL,
  check.names = FALSE
)

tabla_modelo

##                  Termino  Logit Odds_Ratio
## 1            (Intercept) -3.673      0.025
## 2                Ingreso  0.058      1.060
## 3                   Edad  0.126      1.135
## 4                  Deuda -1.219      0.295
## 5       HistorialRegular -1.007      0.365
## 6          HistorialMala -2.685      0.068
## 7             GarantiaSi -1.402      0.246
## 8 Deuda:HistorialRegular  0.641      1.898
## 9    Deuda:HistorialMala -0.043      0.957

3. Interpretación de salida:

Intercepto: odds ratio -> Cuando todas las variables son 0, la probabilidad de que aprueben la solicitud de crédito personal es baja, ya que el resultado dio menor a 1.
Ingreso:odds ratio -> Por cada unidad adicional de ingreso en dólares, las probabilidades de que le aprueben la solicitud de crédito personal, aumentan un 6% (1.060 - 1 = 0.06) manteniendo todo lo demás constante.
Edad:odds ratio -> Por cada año adicional, las probabilidades de que le aprueben la solicitud de crédito personal, aumentan un 13.5% (1.135 - 1 = 0.135) manteniendo todo lo demás constante.
Deuda:odds ratio -> Por cada unidad adicional de deuda que tenga el solicitante, las probabilidades de que le aprueben el crédito personal, se reducen un 70.5% (1 - 0.295 = 0.705) manteniendo todo lo demás constante.
HistorialRegular:odds ratio -> El que la persona que solicita el crédito personal tenga un historial regular, reduce las probabilidades por un 63.5% (1 - 0.365 = 0.635) manteniendo lo demás constante.
HistorialMala:odds ratio -> El que la persona que solicita el crédito personal tenga un historial malo, reduce las probabilidades de que le aprueben el crédito personal por un 93.2% (1 - 0.068 = 0.932) manteniendo lo demás constante.
Garantía:odds ratio -> Tener garantía reduce las probabilidades de que se apruebe el crédito personal por un 75.4% (1 - 0.246 = 0.754) manteniendo lo demás constante.
Deuda_HistorialRegular:odds ratio -> Cuando se considera un solicitante con historial regular, el efecto de la deuda aumenta la proabibilidad según el odds ratio de 90% (1.898 - 1 = 0.898) manteniendo todo lo demás constante.
Deuda_HistorialMala:odds ratio -> Se puede interpretar que en personas con deuda e historial malo, no cambia mucho el efecto de si le aprueban el crédito personal o no, ya que el odds ratio es de 4.3% (1 - 0.957 = 0.043) lo interpretaríamos como un factor que no influiría en si le aprueban el crédito o no.

Examen Grupal 1

Génesis Ortiz y Meraly Desiderio

2025-11-04

Parte 1

1. Simulación de datos:

2. Ajuste del modelo:

Se va a evaluar que modelo vamos a escoger entre: el modelo por subconjuntos y el modelo paso a paso.

A. Modelo por subconjuntos:

Se calculó el modelo saturado, en donde se encuentran todas las variables.

Selección de modelo por subconjunto:

Se identificó el mejor modelo entre BIC y R^2 ajustado.

Cuando son comparados, el mejor modelo resulta ser el de R^2 ajustado.

B. Modelo paso a paso:

Se utlizó el mismo modelo saturado del ajuste de modelo de subconjuntos, y se calculó el modelo nulo.

Forward stepwise selection:

Backward stepwise selection:

Hybrid:

Modelo final (Hybrid):

3. Interpretación de salida:

Por otro lado tenemos el valor de “Adjusted R-squared”, este nos deja saber que el modelo seleccionado explica el 84.26% de la variación en las ventas y que sus predicciones difieren de las ventas reales + o - 8.30 unidades.

4. Evaluación de los supuestos:

a. Normalidad

Prueba Shapiro-Wilk:

b. Varianza constante

Prueba Breusch-Pagan:

c. Independencia

Prueba Durbin-Watson:

Parte 2

Simulación de datos:

2. Ajuste del modelo:

3. Interpretación de salida: