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 simulados

library(tidyverse)

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.65
table(datos$estrato)
## 
##  3  4  5 
## 15  4  5

Exploración gráfica

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()

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

Primero se estimas un modelo sencillo donde el precio depende solo del estrato (similar al modelo lineal simple visto en clase).

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-07

Modelo de regresión lineal múltiple

Ahora se incluye también la edad como predictor, para estudiar el efecto conjunto de la edad y el estrato sobre la disposición a pagar.

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-10
library(broom)
tidy(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.98

Diagnóstico básico del modelo

par(mfrow = c(2, 2))
plot(mod_multiple)

par(mfrow = c(1, 1))

Predicción para nuevos consumidores

nuevos_clientes <- tibble(
  edad    = c(20, 28, 32),
  estrato = c(3, 4, 5)
)

pred <- predict(mod_multiple,
                newdata = nuevos_clientes,
                interval = "prediction",
                level = 0.95)

bind_cols(nuevos_clientes, as_tibble(pred))
## # A tibble: 3 × 5
##    edad estrato   fit   lwr   upr
##   <dbl>   <dbl> <dbl> <dbl> <dbl>
## 1    20       3  13.1  9.80  16.4
## 2    28       4  19.4 16.2   22.7
## 3    32       5  24.7 21.2   28.2