Simulación: Disposición a pagar por un Termo premium
Jhon E. Garzón - Cod: 202508303 - Universidad del Valle - Maestría en Analítica e Inteligencia de Negocios
Contexto y preguntas de simulación
En esta simulación se pretende estudiar cuánto estarían dispuestas a pagar distintas personas por un termo de aluminio de calidad premium (similar a los termos Stanley) y cómo se relaciona ese precio con la edad y el estrato socioeconómico.
Siguiendo el ejercicio de Simulación propuesto del café, se plantea un pequeño cuestionario hipotético donde a cada participante le pregunte su edad, su estrato y el precio máximo que estaría dispuesto a pagar por el producto.
Datos:
# Datos base (24 personas)
datos <- tribble(
~id, ~edad, ~estrato, ~precio_usd, ~producto,
1, 19, 4, 16.00, "Termo premium aluminio",
2, 16, 3, 13.37, "Termo premium aluminio",
3, 24, 5, 20.49, "Termo premium aluminio",
4, 23, 5, 23.94, "Termo premium aluminio",
5, 23, 3, 13.91, "Termo premium aluminio",
6, 20, 4, 16.82, "Termo premium aluminio",
7, 19, 3, 11.33, "Termo premium aluminio",
8, 33, 3, 15.89, "Termo premium aluminio",
9, 18, 5, 23.78, "Termo premium aluminio",
10, 34, 3, 17.45, "Termo premium aluminio",
11, 29, 3, 15.23, "Termo premium aluminio",
12, 17, 3, 12.82, "Termo premium aluminio",
13, 16, 3, 12.53, "Termo premium aluminio",
14, 18, 3, 11.91, "Termo premium aluminio",
15, 22, 3, 11.05, "Termo premium aluminio",
16, 23, 4, 16.33, "Termo premium aluminio",
17, 32, 3, 17.53, "Termo premium aluminio",
18, 35, 5, 23.77, "Termo premium aluminio",
19, 16, 3, 11.85, "Termo premium aluminio",
20, 33, 3, 19.42, "Termo premium aluminio",
21, 22, 4, 18.20, "Termo premium aluminio",
22, 33, 5, 25.65, "Termo premium aluminio",
23, 29, 3, 14.41, "Termo premium aluminio",
24, 23, 3, 15.58, "Termo premium aluminio"
)
glimpse(datos)## Rows: 24
## Columns: 5
## $ id <dbl> 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, …
## $ edad <dbl> 19, 16, 24, 23, 23, 20, 19, 33, 18, 34, 29, 17, 16, 18, 22,…
## $ estrato <dbl> 4, 3, 5, 5, 3, 4, 3, 3, 5, 3, 3, 3, 3, 3, 3, 4, 3, 5, 3, 3,…
## $ precio_usd <dbl> 16.00, 13.37, 20.49, 23.94, 13.91, 16.82, 11.33, 15.89, 23.…
## $ producto <chr> "Termo premium aluminio", "Termo premium aluminio", "Termo …summary(datos$precio_usd)## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 11.05 13.23 15.95 16.64 18.50 25.65table(datos$estrato)##
## 3 4 5
## 15 4 5Exploración gráfica inicial
# Precio vs estrato
ggplot(datos, aes(x = estrato, y = precio_usd)) +
geom_jitter(width = 0.05, height = 0, alpha = 0.8, color = "darkorange") +
stat_summary(fun = mean, geom = "point", size = 3, color = "steelblue") +
labs(x = "Estrato socioeconómico",
y = "Precio dispuesto a pagar (USD)",
title = "Disposición a pagar por termo premium según estrato") +
theme_light()
# Precio vs edad, coloreado por estrato
ggplot(datos, aes(x = edad, y = precio_usd, color = factor(estrato))) +
geom_point(size = 2) +
geom_smooth(method = "lm", se = FALSE) +
scale_color_brewer(palette = "Dark2", name = "Estrato") +
labs(x = "Edad",
y = "Precio dispuesto a pagar (USD)",
title = "Relación entre edad, estrato y disposición a pagar") +
theme_minimal()
Modelo de regresión lineal simple (precio ~ estrato)
mod_simple <- lm(precio_usd ~ estrato, data = datos)
summary(mod_simple)##
## Call:
## lm(formula = precio_usd ~ estrato, data = datos)
##
## Residuals:
## Min 1Q Median 3Q Max
## -3.0176 -2.1446 -0.2139 1.2499 5.3524
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 0.8597 2.1511 0.40 0.693
## estrato 4.4026 0.5855 7.52 1.62e-07 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 2.33 on 22 degrees of freedom
## Multiple R-squared: 0.7199, Adjusted R-squared: 0.7072
## F-statistic: 56.55 on 1 and 22 DF, p-value: 1.623e-07Modelo de regresión lineal múltiple (precio ~ edad + estrato)
mod_multiple <- lm(precio_usd ~ edad + estrato, data = datos)
summary(mod_multiple)##
## Call:
## lm(formula = precio_usd ~ edad + estrato, data = datos)
##
## Residuals:
## Min 1Q Median 3Q Max
## -2.59867 -1.04069 -0.09177 0.80088 2.86797
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -4.82762 1.75407 -2.752 0.0119 *
## edad 0.27076 0.04946 5.474 1.97e-05 ***
## estrato 4.17320 0.38692 10.786 5.07e-10 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 1.531 on 21 degrees of freedom
## Multiple R-squared: 0.8846, Adjusted R-squared: 0.8736
## F-statistic: 80.49 on 2 and 21 DF, p-value: 1.423e-10tidy(mod_multiple, conf.int = TRUE)## # A tibble: 3 × 7
## term estimate std.error statistic p.value conf.low conf.high
## <chr> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 (Intercept) -4.83 1.75 -2.75 1.19e- 2 -8.48 -1.18
## 2 edad 0.271 0.0495 5.47 1.97e- 5 0.168 0.374
## 3 estrato 4.17 0.387 10.8 5.07e-10 3.37 4.98Preparación de datos:
Ahora se agrega al conjunto variables: usos_mensuales
(veces que la persona usaría el termo al mes) y
preferencia_uso (si lo usaría principalmente en “Casa” o
“Fuera de casa”).
set.seed(123)
# Creamos datos_ con las variables usadas en los códigos originales del café
datos_ <- datos %>%
mutate(
precio_dispuesto_pagar = precio_usd, # mismo precio en USD
usos_mensuales = round(rnorm(n(), mean = 25, sd = 8)), # frecuencia de uso del termo
preferencia_uso = sample(c("Casa", "Fuera de casa"), # lugar de uso preferido
size = n(),
replace = TRUE,
prob = c(0.6, 0.4))
)
summary(datos_$usos_mensuales)## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 9.00 20.75 24.50 24.96 29.00 39.00table(datos_$preferencia_uso)##
## Casa Fuera de casa
## 13 11Simulación (modelo inicial y nueva muestra)
Este bloque replica la idea de la simulación del café, pero usando
precio_dispuesto_pagar y usos_mensuales para
el termo premium.
# Simulación
modelo_inicial <- lm(precio_dispuesto_pagar ~ usos_mensuales, data = datos_)
summary(modelo_inicial)##
## Call:
## lm(formula = precio_dispuesto_pagar ~ usos_mensuales, data = datos_)
##
## Residuals:
## Min 1Q Median 3Q Max
## -6.0901 -3.4501 -0.6333 2.0498 8.7647
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 19.8156 3.0312 6.537 1.42e-06 ***
## usos_mensuales -0.1274 0.1163 -1.096 0.285
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 4.287 on 22 degrees of freedom
## Multiple R-squared: 0.05174, Adjusted R-squared: 0.00864
## F-statistic: 1.2 on 1 and 22 DF, p-value: 0.2851nueva_muestra <- data.frame(
usos_mensuales = rnorm(200,
mean = mean(datos_$usos_mensuales),
sd = sd(datos_$usos_mensuales))
)
# Usamos el modelo inicial para predecir 'precio_dispuesto_pagar' en la nueva muestra
# Ajustamos la magnitud del ruido a escala de USD (desviación estándar ~ 3 USD)
nueva_muestra$precio_dispuesto_pagar <- predict(modelo_inicial, nueva_muestra) +
rnorm(200, 0, 3)
# Gráfico de dispersión de la nueva muestra
ggplot(nueva_muestra, aes(x = usos_mensuales, y = precio_dispuesto_pagar)) +
geom_point(size = 3, alpha = 0.8, color = "darkgreen") +
theme_minimal() +
labs(title = "Simulación termo premium: usos al mes vs precio dispuesto a pagar",
x = "Usos al mes",
y = "Precio dispuesto a pagar (USD)")
KNN para preferencia de consumo
Aplicamos KNN para predecir preferencia_uso en la nueva
muestra, usando como predictores precio_dispuesto_pagar y
usos_mensuales.
# Escalamos las variables para asegurar que están en la misma escala
escala_datos <- scale(datos_[, c("precio_dispuesto_pagar", "usos_mensuales")])
escala_nueva_muestra <- scale(nueva_muestra[, c("precio_dispuesto_pagar", "usos_mensuales")])
# Predicción de la preferencia de consumo con KNN
nueva_muestra$preferencia_uso <- knn(
train = escala_datos,
test = escala_nueva_muestra,
cl = datos_$preferencia_uso,
k = 3 # Número de vecinos
)
nueva_muestra$preferencia_uso <- factor(nueva_muestra$preferencia_uso,
levels = c("Casa", "Fuera de casa"))
# Gráfico con color por preferencia de consumo
ggplot(nueva_muestra,
aes(x = usos_mensuales,
y = precio_dispuesto_pagar,
color = preferencia_uso)) +
geom_point(size = 3) +
theme_minimal() +
labs(title = "Relación entre uso mensual y precio dispuesto a pagar por termo premium",
x = "Usos al mes",
y = "Precio dispuesto a pagar (USD)",
color = "Preferencia de uso")
División entrenamiento/prueba y modelo con caret
Dividimos la muestra simulada en entrenamiento (80 %) y prueba (20 %)
y entrenamos un modelo de regresión lineal usando
caret.
# Dividir datos en conjunto de entrenamiento y prueba (80/20)
set.seed(123)
trainIndex <- createDataPartition(nueva_muestra$precio_dispuesto_pagar,
p = 0.8,
list = FALSE,
times = 1)
datos_entrenamiento <- nueva_muestra[trainIndex, ]
datos_prueba <- nueva_muestra[-trainIndex, ]
# Entrenar el modelo de regresión lineal
modelo <- train(
precio_dispuesto_pagar ~ usos_mensuales + preferencia_uso,
data = datos_entrenamiento,
method = "lm"
)
# Resumen del modelo
summary(modelo)##
## Call:
## lm(formula = .outcome ~ ., data = dat)
##
## Residuals:
## Min 1Q Median 3Q Max
## -8.568 -1.423 0.285 1.940 6.206
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 22.04127 0.92081 23.937 < 2e-16 ***
## usos_mensuales -0.15991 0.03204 -4.992 1.58e-06 ***
## `preferencia_usoFuera de casa` -1.90062 0.48790 -3.896 0.000145 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 2.914 on 157 degrees of freedom
## Multiple R-squared: 0.1879, Adjusted R-squared: 0.1776
## F-statistic: 18.16 on 2 and 157 DF, p-value: 8.019e-08Predicción en datos de prueba y visualización interactiva
# Realizar predicción en el conjunto de prueba
predicciones <- predict(modelo, datos_prueba)
# Visualizar relación de tazas_mensuales y precio_dispuesto_pagar con preferencia_consumo
g1 <- ggplot(datos_prueba,
aes(x = usos_mensuales,
y = precio_dispuesto_pagar,
color = preferencia_uso)) +
geom_point(size = 3) +
geom_smooth(method = "lm", se = FALSE) +
labs(title = "Relación entre uso mensual y precio dispuesto a pagar por termo premium",
x = "Usos al mes",
y = "Precio dispuesto a pagar (USD)",
color = "Preferencia de uso") +
theme_minimal()
plotly::ggplotly(g1)Distribución de las predicciones y pruebas adicionales
# Distribución de las predicciones
ggplot(data.frame(predicciones = predicciones), aes(x = predicciones)) +
geom_histogram(aes(y = ..density..), bins = 20,
fill = "skyblue", color = "black") +
geom_density(color = "blue", size = 1) +
geom_vline(aes(xintercept = mean(predicciones)),
color = "red", linetype = "dashed", size = 1) +
labs(title = "Distribución de la predicción de disposición a pagar por termo premium",
x = "Predicción de disposición a pagar (USD)",
y = "Densidad") +
theme_minimal()
# Resumen de las predicciones
summary(predicciones)## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 13.48 15.84 16.67 16.74 17.48 20.10# Normalidad de los residuos del modelo final
shapiro.test(residuals(modelo))##
## Shapiro-Wilk normality test
##
## data: residuals(modelo)
## W = 0.96226, p-value = 0.0002397# Prueba de homocedasticidad sobre el modelo lineal ajustado
bptest(modelo$finalModel)##
## studentized Breusch-Pagan test
##
## data: modelo$finalModel
## BP = 37.657, df = 2, p-value = 6.65e-09Predicción para un nuevo caso
# Realizar una predicción para un nuevo dato
nuevo_dato <- data.frame(
usos_mensuales = 20,
preferencia_uso = "Fuera de casa"
)
prediccion_nuevo <- predict(modelo, nuevo_dato)
cat("Predicción del precio dispuesto a pagar para el nuevo dato: ",
round(prediccion_nuevo, 2), "USD\n")## Predicción del precio dispuesto a pagar para el nuevo dato: 16.94 USD