i) ¿Qué es Supervised Machine Learning y cuáles son algunas de sus aplicaciones en Inteligencia de Negocios?

Supervised Machine Learning es un conjunto de algoritmos y técnicas de aprendizaje supervisado, es decir, con datos que vienen etiquetados, su propósito principal es la generación de técnicas de aprendizaje automático para grandes conjuntos de datos que permita la predicción efectiva de valores futuros para variables de interés en muchos ámbitos profesionales. Así mismo, con estos algoritmos es posible aplicar técnicas de clasificación para distinguir entre varias clases de salidas dadas distintas variables de entrada, esto permite poder saber a que clase pertenecen ciertos conjuntos de variables de entradas, lo que es sumamente útil en el ámbito de Inteligencia de Negocios para distinguir entre pacientes enfermos y sanos o en la industria bancaria para distinguir entre clientes con altas posibilidades de pago tardío frente a los clientes más confiables.

ii) ¿Cuáles son los principales algoritmos de Supervised Machine Learning? Brevemente describir con tus propias palarbas 5 – 7 de los principales algoritmos de Supervised Machine Learning.

Los principales algoritmos de Supervised Machine Learing se pueden dividis principalmente para la parte predictoria o clasificatoria. Donde por un lado, la parte predictoria se encarga de modelar algoritmos que procesan un conjunto de entradas para predecir una variable de salida, en esta etapa algunos de los algoritmos más importantes son:

Redes neuronales: Es una red de capas, donde cada capa representa una variable y mediante iteacciones entre ellas se procesa y calcula una salida.

*Random Forest: Es un ensamble de varios árboles de decisión donde cada árbol se entrena con datos diferentes La y la decisión final del modelo se obtiene promediando las predicciones de los árboles.

Regresiones lineales: Permite modelar mediante coeficientes de regresión, una ecuación que permite predecir una salida. Los coeficientes de regresión es un valor que muestra que tanto influye cada variable independiente en la variable dependiente.

Árboles de decisión: Es una técnica de aprendizaje que muestra los resultados de seguir una serie de decisiones binarias para las variables independientes que representan un impacto significativo en la variable dependiente. La ruta de las decisiones binarias para cada variable independiente terminará prediciendo una salida.

Por otro lado, también tenemos algunos algoritmos para clasificación, por ejemplo…

Regresión logística: Modela la probabilidad de que una entrada pertenezca a una de las dos clases utilizando la función logística para producir un resultado entre 0 y 1.

Máquinas de Vectores de Soporte (SVM): Estos modelos bucan encontrar el hiperplano que mejor separa las clases en el espacio de características o variables independientes.

iii) ¿Qué es la R2 Ajustada? ¿Qué es la métrica RMSE? ¿Cuál es la diferencia entre la R2 Ajustada y la métrica RMSE?

Por un lado, la R2 ajustada representa una versión más ajustada del coeficiente de determinación que representa que porcentaje del los datos es explicada por el modelo en cuestión, por otro lado, el RMSE mide la desviación de los valores predichos por el modelo respecto a los valores reales. La diferencia entre uno y otro radica en que la R2 Ajustada se centra en la proporción de la variabilidad explicada por el modelo, ajustada por el número de predictores y el RMSE mide la diferencia promedio entre los valores predichos y reales.

Medidas de tendencia central

describe(df)

##          vars    n     mean       sd  median  trimmed     mad     min      max
## age         1 1338    39.21    14.05   39.00    39.01   17.79   18.00    64.00
## sex*        2 1338     1.51     0.50    2.00     1.51    0.00    1.00     2.00
## bmi         3 1338    30.67     6.10   30.40    30.50    6.23   16.00    53.10
## children    4 1338     1.09     1.21    1.00     0.94    1.48    0.00     5.00
## smoker*     5 1338     1.20     0.40    1.00     1.13    0.00    1.00     2.00
## region*     6 1338     2.52     1.10    3.00     2.52    1.48    1.00     4.00
## expenses    7 1338 13270.42 12110.01 9382.03 11076.02 7440.81 1121.87 63770.43
##             range  skew kurtosis     se
## age         46.00  0.06    -1.25   0.38
## sex*         1.00 -0.02    -2.00   0.01
## bmi         37.10  0.28    -0.06   0.17
## children     5.00  0.94     0.19   0.03
## smoker*      1.00  1.46     0.14   0.01
## region*      3.00 -0.04    -1.33   0.03
## expenses 62648.56  1.51     1.59 331.07

Podemos apreciar que la base de datos se trata de un conjunto de datos compuesto por 1,338 observaciones, abarcando variables que incluyen edad, sexo, índice de masa corporal (BMI), número de hijos (children), si es fumador o no (smoker), región geográfica (region), y gastos médicos individuales (expenses).

• Edad: La edad promedio de los individuos en el estudio es de 39.21 años, con una desviación estándar de 14.05 años. La mediana de la edad es de 39 años, lo que indica una distribución relativamente simétrica. La edad varía desde un mínimo de 18 años hasta un máximo de 64 años.

• Sexo: Representa el género de las personas.

• Índice de Masa Corporal (BMI): El BMI promedio es de 30.67, con una desviación estándar de 6.10, indicando variabilidad en los niveles de BMI entre los individuos. La mediana de 30.40 y una media casi igual de 30.50 sugieren una distribución bastante simétrica. Los valores de BMI varían entre 16.00 y 53.10.

• Número de Hijos: En promedio, los individuos tienen 1.09 hijos, con una variabilidad de 1.21. La mayoría de los individuos tienen 1 hijo, como lo indica la mediana de 1. El rango va de 0 a 5 hijos.

• Fumador: Representa si el individuo es fumador o no fumador.

• Región: Representa la región de la cual es el cliente.

• Gastos Médicos (Expenses): Los gastos médicos promedian 13,270.42, con una amplia variabilidad, reflejando diferencias significativas en los costos médicos entre individuos. La mediana de 9,382.03 es sustancialmente menor que la media, lo que indica una distribución sesgada hacia valores más bajos, aunque los gastos varían desde tan solo 1,121.87 hasta 63,770.43.

Este conjunto de datos revela una población con una variada distribución de edades, un BMI promedio que sugiere ligero sobrepeso, una familia promedio con al menos un hijo, y una predominancia de no fumadores. Los gastos médicos muestran una amplia gama y un sesgo hacia valores menores. Estas estadísticas proporcionan una visión integral de los factores que pueden influir en los gastos médicos individuales.

moda <- function(x) {
  tabla_frecuencias <- table(x)
  modas <- names(tabla_frecuencias[tabla_frecuencias == max(tabla_frecuencias)])
  if (is.numeric(x)) {
    modas <- as.numeric(modas)
  }
  return(modas)
}
# Usar sapply para aplicar la función moda a cada columna
modas_por_columna <- sapply(df, moda)

# Mostrar las modas de cada columna
modas_por_columna

## $age
## [1] 18
## 
## $sex
## [1] "male"
## 
## $bmi
## [1] 27.6 33.3
## 
## $children
## [1] 0
## 
## $smoker
## [1] "no"
## 
## $region
## [1] "southeast"
## 
## $expenses
## [1] 1639.56

Edad: La edad más frecuentemente observada en el conjunto de datos es 18 años, lo que indica que hay un número significativo de jóvenes adultos o recién adultos en la muestra.

Sexo: La moda indica que hay más individuos masculinos que femeninos en el conjunto de datos.

Índice de Masa Corporal (BMI): Hay dos modas para el BMI, 27.6 y 33.3, lo que sugiere una distribución bimodal en esta variable. Estos valores indican la presencia frecuente de personas en la categoría de sobrepeso (25-29.9) y obesidad clase 1 (30-34.9), según los estándares del BMI.

Número de Hijos: La mayoría de los individuos en el conjunto de datos no tienen hijos.

Fumador: La mayoría de las personas en este conjunto de datos son no fumadoras.

Región: La región del sureste es la más común entre los individuos en este conjunto de datos.

Gastos Médicos (Expenses): El gasto médico más frecuentemente observado es $1639.56.

Medidas de dispersión

# Función para calcular estadísticas
calcular_estadisticas <- function(columna) {
  rango <- max(columna, na.rm = TRUE) - min(columna, na.rm = TRUE)
  varianza <- var(columna, na.rm = TRUE)
  desviacion_std <- sd(columna, na.rm = TRUE)
  rango_iqr <- IQR(columna, na.rm = TRUE)
  
  c(Rango = rango, Varianza = varianza, `Desviación Estándar` = desviacion_std, `Rango Intercuartílico` = rango_iqr)
}

# Aplicar la función a cada columna numérica de df
estadisticas_df <- sapply(df, function(x) if(is.numeric(x)) calcular_estadisticas(x) else NA)

# Mostrar las estadísticas
estadisticas_df

## $age
##                 Rango              Varianza   Desviación Estándar 
##              46.00000             197.40139              14.04996 
## Rango Intercuartílico 
##              24.00000 
## 
## $sex
## [1] NA
## 
## $bmi
##                 Rango              Varianza   Desviación Estándar 
##             37.100000             37.190265              6.098382 
## Rango Intercuartílico 
##              8.400000 
## 
## $children
##                 Rango              Varianza   Desviación Estándar 
##              5.000000              1.453213              1.205493 
## Rango Intercuartílico 
##              2.000000 
## 
## $smoker
## [1] NA
## 
## $region
## [1] NA
## 
## $expenses
##                 Rango              Varianza   Desviación Estándar 
##              62648.56          146652372.23              12110.01 
## Rango Intercuartílico 
##              11899.63

Identificación de patrones, tendencias

#Comparación entre BMI y edad por sexo
ggplot(df, aes(x=age, y=bmi)) + geom_point(aes(color=sex)) + labs(title="BMI vs Edad por Sexo", x="Edad", y="BMI") + theme_minimal()

En este gráfico de BMI por edad y sexo se aprecia que el sexo no es un factor sumamente determimante para el BMI, sin embargo, se suele apreciar una ligera tendencia de incrementar el BMI a medida que las personas envejecen.

#BMI por sexo

ggplot(df, aes(x=sex, y=bmi, fill=sex)) + geom_boxplot() + labs(title="Distribución de BMI por Sexo", x="Sexo", y="BMI")

En esta comparación del BMI por sexo, se aprecia que los datos de ambos sexos tienen una disperción similar donde los hombres suelen tener un valor de BMI ligeramente más alto.

#Relación entre BMI y número de hijos
ggplot(df, aes(x=factor(children), y=bmi)) + geom_jitter(aes(color=sex), width=0.2) + labs(title="BMI por Número de Hijos y Sexo", x="Número de Hijos", y="BMI")

En la relación del BMI y el número de hijos, podemos apreciar que entre mayor cantidad de hijos se observa una ligera tendencia a incrementar su BMI.

Distribuciones de cada variable

  hist(df$age, 
     main = "Histograma de Edad", 
     xlab = "Edad", 
     ylab = "Frecuencia", 
     col = "blue", 
     border = "black")

hist(df$bmi, 
     main = "Histograma de Índice de masa corporal", 
     xlab = "Edad", 
     ylab = "Frecuencia", 
     col = "lightblue", 
     border = "black")

hist(df$children, 
     main = "Histograma de número de hijos", 
     xlab = "Edad", 
     ylab = "Frecuencia", 
     col = "green", 
     border = "black")

hist(df$expenses, 
     main = "Histograma de prima", 
     xlab = "Prima", 
     ylab = "Frecuencia", 
     col = "red", 
     border = "black")

En las distribuciones de los datos para cada variable, se aprecia que la prima de gastos esta sesgada a la izquierda, es decir, la mayoría de los datos son de primas de bajo valor económico, por lo que será recomendable realizar una transformación para normalizar dicha distribución. Esto mismo sucede en el número de hijos, donde la mayoría de personas suelen tener pocos hijos. En cuanto a al distribución del índice de masa corporal, se observa que los datos están distribuidos normalmente.

Relaciones entre variables independientes y la dependiente

# Relaciones entre variables independientes y la dependiente

ggplot(df, aes(x=age, y=expenses, color=sex)) +
  geom_point(alpha=0.5) +
  labs(title="Gastos vs. Edad, Diferenciados por Sexo", x="Edad", y="Gastos Médicos") +
  theme_minimal()

ggplot(df, aes(x=sex, y=expenses, color=sex)) +
  geom_point(position = position_jitterdodge(), alpha=0.5) +
  labs(title="Gastos Médicos Diferenciados por Sexo", x="Sexo", y="Gastos Médicos") +
  theme_minimal()

ggplot(df, aes(x=bmi, y=expenses, color=smoker)) +
  geom_point(alpha=0.5) +
  labs(title="Gastos vs. BMI, Diferenciados por Fumadores", x="BMI", y="Gastos Médicos") +
  theme_minimal()

ggplot(df, aes(x=factor(children), y=expenses)) +
  geom_point(position = position_jitter(width = 0.2), aes(color=factor(children)), alpha=0.5) +
  labs(title="Gastos vs. Número de Hijos", x="Número de Hijos", y="Gastos Médicos") +
  theme_minimal()

ggplot(df, aes(x=region, y=expenses, color=region)) +
  geom_point(position = position_jitter(width = 0.2), alpha=0.5) +
  labs(title="Gastos Médicos Diferenciados por Región", x="Región", y="Gastos Médicos") +
  theme_minimal()

ggplot(df, aes(x=region, y=expenses, fill=region)) + 
  geom_boxplot() +
  scale_fill_brewer(palette="Pastel1") +
  labs(title="Gastos por Región", x="Región", y="Gastos Médicos") +
  theme_minimal()

ggplot(df, aes(x=sex, y=expenses, fill=sex)) + 
  geom_boxplot() +
  scale_fill_brewer(palette="Set1") +
  labs(title="Gastos por Sexo", x="Sexo", y="Gastos Médicos") +
  theme_minimal()

ggplot(df, aes(x=smoker, y=expenses, fill=smoker)) + 
  geom_boxplot() +
  scale_fill_brewer(palette="Set2") +
  labs(title="Gastos por Fumador", x="Fumador", y="Gastos Médicos") +
  theme_minimal()

ggplot(df, aes(x=as.factor(children), y=expenses)) +
  geom_boxplot(aes(fill=as.factor(children))) +
  scale_fill_brewer(palette="Pastel1") + 
  labs(title="Gastos Médicos por Número de Hijos",
       x="Número de Hijos",
       y="Gastos Médicos") +
  theme_minimal()

Las relaciones de cada variable independiente muestra algunos insights interesantes, por ejemplo, se observa que la región no es un factor estrechamente relacionado con la prima del seguro, como también el sexo, sin embargo, el número de hijos y la edad de las personas parecen ser variables relacionadas positivamente con la vairable dependiente. Es sumamente notorio ver la influencia que tiene el fumar en el costo del seguro, pues se observa un patrón evidente donde las personas que suman suelen tener primas más caras.

Correlación entre variables

# Correlación entre variables
# Correlation
model.matrix(~0+., data=df) %>% 
  cor(use="pairwise.complete.obs") %>% 
  ggcorrplot(show.diag = F, type="lower", lab=TRUE, lab_size=2, 
             colors = c("#1B9E77", "white", "#D95F02")) 

En esta matriz de correlaciones entre las variables independientes, se observa que no hay correlación entre estas, por lo que se cumple el supuesto de independencia de las variables para los modelos de regresiones, es decir, es poco probable que existan problemas de multicolinealidad.

Evaluación del modelo

AIC(ols_model)  

## [1] 27123.48

AIC(log_ols_model) 

## [1] 1410.047

De acuerdo con los resultados del AIC, el modelo con logaritmos parece ser que tiene una mejor capacidad poredictiva, lo cual tiene sentido debido a las distribuciones anormales que se encontraron en el análisis exploratorio de los datos. Las normalizaciones aplicadas a algunas variables permiten que el modelo se ajsute mejor y tenga una mejor capacidad predictiva.

RMSE_ols_model     <- sqrt(mean(ols_model$residuals^2))
RMSE_log_ols_model <- sqrt(mean(log_ols_model$residuals^2))

RMSE_ols_model

## [1] 6068.772

RMSE_log_ols_model

## [1] 0.4351707

En cuanto al error mínimo cuadrado, el modelo de logaritmos tiene un valor sumamente inferior que respalda su mejor capacidad predictiva.

Pruebas de diagnóstico

vif(log_ols_model) 

##          log(age)          log(bmi) as.factor(smoker)          children 
##          1.023662          1.084219          1.072588          1.007884

bptest(log_ols_model)

## 
##  studentized Breusch-Pagan test
## 
## data:  log_ols_model
## BP = 79.894, df = 4, p-value < 2.2e-16

shapiro.test(resid(log_ols_model))

## 
##  Shapiro-Wilk normality test
## 
## data:  resid(log_ols_model)
## W = 0.7389, p-value < 2.2e-16

#Gráfico de residuos
hist(log_ols_model$residuals)

Transformaciones a las variables

#Quitar outliers

df2=df
df2 <- df2[!(df$expenses < (quantile(df$expenses, 0.25) - 1.5 * IQR(df$expenses)) | df$expenses > (quantile(df$expenses, 0.75) + 1.5 * IQR(df$expenses))), ]
# Para 'age'
df2 <- df2[!(df$age < (quantile(df$age, 0.25) - 1.5*IQR(df$age)) | df$age > (quantile(df$age, 0.75) + 1.5*IQR(df$age))),]

# Para 'bmi'
df2 <- df2[!(df$bmi < (quantile(df$bmi, 0.25) - 1.5*IQR(df$bmi)) | df$bmi > (quantile(df$bmi, 0.75) + 1.5*IQR(df$bmi))),]

log_ols_model2 <- lm(log(expenses) ~ log(age) + log(bmi) + as.factor(smoker) + children  , data = df2)
summary(log_ols_model)

## 
## Call:
## lm(formula = log(expenses) ~ log(age) + log(bmi) + as.factor(smoker) + 
##     children, data = df)
## 
## Residuals:
##      Min       1Q   Median       3Q      Max 
## -0.73765 -0.18524 -0.08124  0.02947  2.24392 
## 
## Coefficients:
##                      Estimate Std. Error t value Pr(>|t|)    
## (Intercept)           3.40936    0.24249  14.060  < 2e-16 ***
## log(age)              1.34353    0.03264  41.163  < 2e-16 ***
## log(bmi)              0.13081    0.06617   1.977   0.0483 *  
## as.factor(smoker)yes  1.30216    0.04115  31.646  < 2e-16 ***
## children              0.08576    0.01043   8.220  5.3e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 0.4361 on 1186 degrees of freedom
## Multiple R-squared:  0.6993, Adjusted R-squared:  0.6983 
## F-statistic: 689.7 on 4 and 1186 DF,  p-value: < 2.2e-16

Para corregir los problemas anteriormente encontrados, se optó por quitar los datos Outliers que sesgan a algunas variables del modelo.

bptest(log_ols_model2)

## 
##  studentized Breusch-Pagan test
## 
## data:  log_ols_model2
## BP = 75.24, df = 4, p-value = 1.773e-15

shapiro.test(resid(log_ols_model2))

## 
##  Shapiro-Wilk normality test
## 
## data:  resid(log_ols_model2)
## W = 0.69358, p-value < 2.2e-16

Weight OLS

weights <- 1 / log(df2$expenses)

# Ajustar el modelo WLS
log_ols_wls_model <- lm(log(expenses) ~ log(age) + log(bmi) + as.factor(smoker) + children, data = df2, weights = weights)

# Ver el resumen del modelo
summary(log_ols_wls_model)

## 
## Call:
## lm(formula = log(expenses) ~ log(age) + log(bmi) + as.factor(smoker) + 
##     children, data = df2, weights = weights)
## 
## Weighted Residuals:
##      Min       1Q   Median       3Q      Max 
## -0.22687 -0.04532 -0.01595  0.01621  0.74026 
## 
## Coefficients:
##                      Estimate Std. Error t value Pr(>|t|)    
## (Intercept)          3.351724   0.212186  15.796   <2e-16 ***
## log(age)             1.422077   0.029058  48.940   <2e-16 ***
## log(bmi)             0.049728   0.058220   0.854    0.393    
## as.factor(smoker)yes 1.279863   0.041505  30.837   <2e-16 ***
## children             0.091877   0.009305   9.874   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 0.1274 on 1126 degrees of freedom
##   (53 observations deleted due to missingness)
## Multiple R-squared:  0.7592, Adjusted R-squared:  0.7583 
## F-statistic: 887.4 on 4 and 1126 DF,  p-value: < 2.2e-16

Este nuevo modelo sigue mostrando resultados muy parecidos al primer modelo, sin embargo, se mejoró la R cuadrada y la variable de peso corporal perdió significancia estadística.

bptest(log_ols_wls_model)

## 
##  studentized Breusch-Pagan test
## 
## data:  log_ols_wls_model
## BP = 11.771, df = 4, p-value = 0.01914

shapiro.test(resid(log_ols_wls_model))

## 
##  Shapiro-Wilk normality test
## 
## data:  resid(log_ols_wls_model)
## W = 0.67331, p-value < 2.2e-16

hist(log_ols_wls_model$residuals)

#RMSE

RMSE_log_ols_wls_model <- sqrt(mean(log_ols_wls_model$residuals^2))
RMSE_log_ols_wls_model

## [1] 0.390953

Cross Validation

df2 <- na.omit(df2)  # Limpia el dataframe de NA
df2_alt <- df2 %>% dplyr::select(expenses, age,bmi,smoker,children)

df2$expenses= log(df2$expenses )
df2$age= log(df2$age )
df2$bmi= log(df2$bmi )

set.seed(123)
partition <- createDataPartition(y = df2$expenses, p = 0.7, list = FALSE)
train = df2[partition, ]
test = df2[-partition, ]
train2 = df2[partition, ]
test2 = df2[-partition, ]

La validación cruzada permite dividir el conjunto de datos en subconjuntos de entrenamiento y prueba para poder tener datos distintos con los cuales comprobar la capacidad de predicción del modelo en comparación al entrenamiento del mismo.

XGBoost Regresión

# define explanatory variables (X's) and dependent variable (Y) in training set
train_x = data.matrix(train[, -7])
train_y = train[,7]

# define explanatory variables (X's) and dependent variable (Y) in testing set
test_x = data.matrix(train[, -7])
test_y = train[, 7]

# define final training and testing sets
xgb_train = xgb.DMatrix(data = train_x, label = train_y)
xgb_test  = xgb.DMatrix(data = test_x, label = test_y)

# Lets fit XGBoost regression model and display RMSE for both training and testing data at each round
watchlist = list(train=xgb_train, test=xgb_test)
model_xgb = xgb.train(data=xgb_train, max.depth=3, watchlist=watchlist, nrounds=70)

## [1]  train-rmse:5.893701 test-rmse:5.893701 
## [2]  train-rmse:4.146337 test-rmse:4.146337 
## [3]  train-rmse:2.926488 test-rmse:2.926488 
## [4]  train-rmse:2.071960 test-rmse:2.071960 
## [5]  train-rmse:1.479140 test-rmse:1.479140 
## [6]  train-rmse:1.072780 test-rmse:1.072780 
## [7]  train-rmse:0.797338 test-rmse:0.797338 
## [8]  train-rmse:0.616903 test-rmse:0.616903 
## [9]  train-rmse:0.502248 test-rmse:0.502248 
## [10] train-rmse:0.433278 test-rmse:0.433278 
## [11] train-rmse:0.393131 test-rmse:0.393131 
## [12] train-rmse:0.370336 test-rmse:0.370336 
## [13] train-rmse:0.355950 test-rmse:0.355950 
## [14] train-rmse:0.348553 test-rmse:0.348553 
## [15] train-rmse:0.343831 test-rmse:0.343831 
## [16] train-rmse:0.338843 test-rmse:0.338843 
## [17] train-rmse:0.334898 test-rmse:0.334898 
## [18] train-rmse:0.331781 test-rmse:0.331781 
## [19] train-rmse:0.329272 test-rmse:0.329272 
## [20] train-rmse:0.328168 test-rmse:0.328168 
## [21] train-rmse:0.325709 test-rmse:0.325709 
## [22] train-rmse:0.322696 test-rmse:0.322696 
## [23] train-rmse:0.320312 test-rmse:0.320312 
## [24] train-rmse:0.318257 test-rmse:0.318257 
## [25] train-rmse:0.316940 test-rmse:0.316940 
## [26] train-rmse:0.315047 test-rmse:0.315047 
## [27] train-rmse:0.313476 test-rmse:0.313476 
## [28] train-rmse:0.309481 test-rmse:0.309481 
## [29] train-rmse:0.308494 test-rmse:0.308494 
## [30] train-rmse:0.308048 test-rmse:0.308048 
## [31] train-rmse:0.306446 test-rmse:0.306446 
## [32] train-rmse:0.302774 test-rmse:0.302774 
## [33] train-rmse:0.301287 test-rmse:0.301287 
## [34] train-rmse:0.300636 test-rmse:0.300636 
## [35] train-rmse:0.299763 test-rmse:0.299763 
## [36] train-rmse:0.296936 test-rmse:0.296936 
## [37] train-rmse:0.295638 test-rmse:0.295638 
## [38] train-rmse:0.295129 test-rmse:0.295129 
## [39] train-rmse:0.294046 test-rmse:0.294046 
## [40] train-rmse:0.293564 test-rmse:0.293564 
## [41] train-rmse:0.293201 test-rmse:0.293201 
## [42] train-rmse:0.290426 test-rmse:0.290426 
## [43] train-rmse:0.289572 test-rmse:0.289572 
## [44] train-rmse:0.288200 test-rmse:0.288200 
## [45] train-rmse:0.284922 test-rmse:0.284922 
## [46] train-rmse:0.284153 test-rmse:0.284153 
## [47] train-rmse:0.282600 test-rmse:0.282600 
## [48] train-rmse:0.280748 test-rmse:0.280748 
## [49] train-rmse:0.280357 test-rmse:0.280357 
## [50] train-rmse:0.279848 test-rmse:0.279848 
## [51] train-rmse:0.278802 test-rmse:0.278802 
## [52] train-rmse:0.277189 test-rmse:0.277189 
## [53] train-rmse:0.276742 test-rmse:0.276742 
## [54] train-rmse:0.275960 test-rmse:0.275960 
## [55] train-rmse:0.273845 test-rmse:0.273845 
## [56] train-rmse:0.272900 test-rmse:0.272900 
## [57] train-rmse:0.272006 test-rmse:0.272006 
## [58] train-rmse:0.270044 test-rmse:0.270044 
## [59] train-rmse:0.269023 test-rmse:0.269023 
## [60] train-rmse:0.268472 test-rmse:0.268472 
## [61] train-rmse:0.267644 test-rmse:0.267644 
## [62] train-rmse:0.263392 test-rmse:0.263392 
## [63] train-rmse:0.261552 test-rmse:0.261552 
## [64] train-rmse:0.261288 test-rmse:0.261288 
## [65] train-rmse:0.260638 test-rmse:0.260638 
## [66] train-rmse:0.258681 test-rmse:0.258681 
## [67] train-rmse:0.257493 test-rmse:0.257493 
## [68] train-rmse:0.257118 test-rmse:0.257118 
## [69] train-rmse:0.255843 test-rmse:0.255843 
## [70] train-rmse:0.253668 test-rmse:0.253668

# the more the number of rounds selected, the longer the time to display the results. 

# Looks like the lowest RMSE for both training and test dataset is achieved at 59 round. 
# Lets estimate our final regression model
reg_xgb = xgboost(data = xgb_train, max.depth = 3, nrounds = 59, verbose = 0) # setting verbose = 0 avoids to display the training and testing error for each round. 
prediction_xgb_test<-predict(reg_xgb, xgb_test)
RMSE_SVM <- rmse(prediction_xgb_test, test$expenses)

## Warning in actual - predicted: longer object length is not a multiple of
## shorter object length

# Lets do some diagnostic check of regression residuals 
xgb_reg_residuals<-test$expenses - prediction_xgb_test

## Warning in test$expenses - prediction_xgb_test: longer object length is not a
## multiple of shorter object length

plot(xgb_reg_residuals, xlab= "Dependent Variable", ylab = "Residuals", main = 'XGBoost Regression Residuals')
abline(0,0)

# Plot first 3 trees of model
xgb.plot.tree(model=reg_xgb, trees=0:2)

importance_matrix <- xgb.importance(model = reg_xgb)
xgb.plot.importance(importance_matrix, xlab = "Explanatory Variables X's Importance")

En el primer modelo de Machine Learning, XGBoost Regresion, se pueden apreciar los resultados de los RMSE que arrojó cada uno de los árboles que se corrieron, donde el modelo terminó mejorando drásticamente dicha métrica con el aprendizaje de cada árbol que se iba corriendo. Por otro lado, también se muestran los 3 primeros árboles de todas las iteraciones que se hicieron para los árboles que el modelo fue mejorando. Así mismo, en el último gráfico se aprecian las variables ordenadas por importancia para el modelo, donde se descubrió que las variables de edad, fumador y BMI son las variables independientes con más peso en la predicción del modelo.

# Cálculo del RMSE
RMSE_XGB <- rmse(test$expenses, prediction_xgb_test)

# Imprimir el RMSE
print(RMSE_XGB)

## [1] 1.005894

Árboles de decisión

decision_tree_model <- rpart(expenses ~ age +  bmi + children + smoker, data = train)

# summary(decision_tree_regression)
plot(decision_tree_model, compress = TRUE)
text(decision_tree_model, use.n = TRUE)

rpart.plot(decision_tree_model)

summary(decision_tree_model)

## Call:
## rpart(formula = expenses ~ age + bmi + children + smoker, data = train)
##   n= 795 
## 
##           CP nsplit rel error    xerror       xstd
## 1 0.38090491      0 1.0000000 1.0018793 0.04070209
## 2 0.09428235      1 0.6190951 0.6540772 0.03984000
## 3 0.09194721      2 0.5248127 0.4896507 0.03914209
## 4 0.07144592      3 0.4328655 0.4191936 0.03779117
## 5 0.04035494      4 0.3614196 0.3634279 0.03629955
## 6 0.03823495      5 0.3210647 0.3485871 0.03587664
## 7 0.02805870      6 0.2828297 0.3015303 0.03279548
## 8 0.01056219      7 0.2547710 0.2805371 0.03288270
## 9 0.01000000      8 0.2442088 0.2718327 0.03370972
## 
## Variable importance
##      age   smoker children      bmi 
##       66       26        6        2 
## 
## Node number 1: 795 observations,    complexity param=0.3809049
##   mean=8.855187, MSE=0.5709164 
##   left son=2 (199 obs) right son=3 (596 obs)
##   Primary splits:
##       age      < 3.276967 to the left,  improve=0.38090490, (0 missing)
##       smoker   splits as  LR,           improve=0.19005740, (0 missing)
##       children < 1.5      to the left,  improve=0.04470957, (0 missing)
##       bmi      < 2.884785 to the left,  improve=0.01004442, (0 missing)
##   Surrogate splits:
##       bmi < 2.884785 to the left,  agree=0.757, adj=0.03, (0 split)
## 
## Node number 2: 199 observations,    complexity param=0.09194721
##   mean=8.048154, MSE=0.6420251 
##   left son=4 (185 obs) right son=5 (14 obs)
##   Primary splits:
##       smoker   splits as  LR,           improve=0.32664280, (0 missing)
##       children < 1.5      to the left,  improve=0.15387360, (0 missing)
##       age      < 3.113268 to the left,  improve=0.07109083, (0 missing)
##       bmi      < 3.526356 to the right, improve=0.04657472, (0 missing)
## 
## Node number 3: 596 observations,    complexity param=0.09428235
##   mean=9.124649, MSE=0.257099 
##   left son=6 (198 obs) right son=7 (398 obs)
##   Primary splits:
##       age      < 3.650574 to the left,  improve=0.279269500, (0 missing)
##       smoker   splits as  LR,           improve=0.277637200, (0 missing)
##       bmi      < 3.362108 to the right, improve=0.014616760, (0 missing)
##       children < 2.5      to the left,  improve=0.009387482, (0 missing)
##   Surrogate splits:
##       bmi < 2.898636 to the left,  agree=0.674, adj=0.02, (0 split)
## 
## Node number 4: 185 observations,    complexity param=0.03823495
##   mean=7.922177, MSE=0.4637137 
##   left son=8 (154 obs) right son=9 (31 obs)
##   Primary splits:
##       children < 1.5      to the left,  improve=0.20229190, (0 missing)
##       age      < 3.113268 to the left,  improve=0.09361404, (0 missing)
##       bmi      < 3.526356 to the right, improve=0.02513615, (0 missing)
## 
## Node number 5: 14 observations
##   mean=9.712848, MSE=0.01736352 
## 
## Node number 6: 198 observations,    complexity param=0.07144592
##   mean=8.744748, MSE=0.3134059 
##   left son=12 (173 obs) right son=13 (25 obs)
##   Primary splits:
##       smoker   splits as  LR,           improve=0.52257040, (0 missing)
##       bmi      < 3.365569 to the right, improve=0.06569681, (0 missing)
##       children < 0.5      to the left,  improve=0.03644128, (0 missing)
##       age      < 3.481122 to the left,  improve=0.01126302, (0 missing)
## 
## Node number 7: 398 observations,    complexity param=0.04035494
##   mean=9.313645, MSE=0.1215676 
##   left son=14 (363 obs) right son=15 (35 obs)
##   Primary splits:
##       smoker   splits as  LR,           improve=0.37856080, (0 missing)
##       age      < 3.839394 to the left,  improve=0.16197320, (0 missing)
##       bmi      < 3.344625 to the right, improve=0.02571866, (0 missing)
##       children < 2.5      to the left,  improve=0.01552624, (0 missing)
## 
## Node number 8: 154 observations,    complexity param=0.01056219
##   mean=7.784762, MSE=0.3439052 
##   left son=16 (105 obs) right son=17 (49 obs)
##   Primary splits:
##       age      < 3.113268 to the left,  improve=0.090517850, (0 missing)
##       bmi      < 3.526356 to the right, improve=0.017829780, (0 missing)
##       children < 0.5      to the left,  improve=0.007516446, (0 missing)
##   Surrogate splits:
##       bmi < 3.725647 to the left,  agree=0.695, adj=0.041, (0 split)
## 
## Node number 9: 31 observations
##   mean=8.60482, MSE=0.4990842 
## 
## Node number 12: 173 observations
##   mean=8.590906, MSE=0.169994 
## 
## Node number 13: 25 observations
##   mean=9.809329, MSE=0.008705127 
## 
## Node number 14: 363 observations,    complexity param=0.0280587
##   mean=9.247033, MSE=0.08200723 
##   left son=28 (151 obs) right son=29 (212 obs)
##   Primary splits:
##       age      < 3.901922 to the left,  improve=0.42780750, (0 missing)
##       children < 0.5      to the right, improve=0.03561129, (0 missing)
##       bmi      < 3.617651 to the left,  improve=0.01323277, (0 missing)
##   Surrogate splits:
##       children < 0.5      to the right, agree=0.650, adj=0.159, (0 split)
##       bmi      < 2.998226 to the left,  agree=0.587, adj=0.007, (0 split)
## 
## Node number 15: 35 observations
##   mean=10.00451, MSE=0.00854337 
## 
## Node number 16: 105 observations
##   mean=7.664234, MSE=0.3171459 
## 
## Node number 17: 49 observations
##   mean=8.043038, MSE=0.3034107 
## 
## Node number 28: 151 observations
##   mean=9.025095, MSE=0.06050519 
## 
## Node number 29: 212 observations
##   mean=9.40511, MSE=0.03725047

En el modelo de predicción del seguro de salud utilizando árboles de decisión, se ha aplicado una transformación logarítmica a variables clave para capturar mejor las relaciones no lineales y estabilizar la varianza. Específicamente, las transformaciones logarítmicas se han aplicado a la edad, al índice de masa corporal (BMI) y a los gastos del seguro de salud (expenses).

Los nodos terminales del árbol presentan valores logarítmicos que predicen los gastos de seguro de salud. Estos valores, una vez retransformados a su escala original exponenciando los números, representan los gastos de seguro esperados para los grupos correspondientes. Por ejemplo, un valor de nodo terminal de 7.7 corresponde a exp(7.7) en la escala de gastos original, lo cual es aproximadamente $2,201.64.

A continuación, se proporciona una interpretación de los nodos terminales con valores retransformados:

• Para individuos no fumadores con menos de dos hijos y menores a 22 años(transformado logarítmicamente), los gastos previstos son aproximadamente $208, indicando que factores como la juventud y no fumar están asociados con costos más bajos.

• Para aquellos menores a 35 años ( transformado logarítmicamente) pero que son fumadores, los costos son ligeramente mayores, con gastos previstos en torno a $891.

• En el grupo de edad mayores a 35 años (transformado logarítmicamente), que son fumadores, el modelo prevé gastos mayores, aproximadamente $1023, destacando cómo la edad y el hecho de fumar incrementa los costos predichos del seguro de salud.

Estos valores pronosticados sugieren una relación directa entre la edad y los costos del seguro, con los gastos aumentando con la edad. Además, el hecho de no fumar es un factor consistente a través de los grupos para mantener los costos relativamente más bajos. Estos son algunos de los nodos terminales más importantes que describen el comportamiento de los datos y cómo se comporta el modelo al predecir variables.

### RMSE of DECISION TREE REGRESSION
decision_tree_prediction <- predict(decision_tree_model,test)
RMSE_tree <- rmse(decision_tree_prediction, test$expenses)
RMSE_tree

## [1] 0.376174

Random Forest

rf_model <- randomForest(expenses ~  age + bmi + children + smoker, data= train, proximity=TRUE)
# random_forest<-randomForest(MEDV~.,data=train_alt,importance=TRUE, proximity=TRUE) 
print(rf_model) ### the train data set model accuracy is around 85%.

## 
## Call:
##  randomForest(formula = expenses ~ age + bmi + children + smoker,      data = train, proximity = TRUE) 
##                Type of random forest: regression
##                      Number of trees: 500
## No. of variables tried at each split: 1
## 
##           Mean of squared residuals: 0.1975525
##                     % Var explained: 65.4

# Prediction & Confusion Matrix – test data
rf_prediction <- predict(rf_model,test)

# confusionMatrix(rf_prediction_train_data, train$MEDV) # a confusion matrix is essentially a table that categorizes predictions against actual values.
RMSE_rf <- rmse(rf_prediction, test$expenses)


# Evalute Variables' Importance
# How to interpret varImpPlot()? The higher the value of mean decrease accuracy, the higher the importance of the variable in the model. 
# In other words, mean decrease accuracy represents how much removing each variable reduces the accuracy of the model.
varImpPlot(rf_model, n.var = 5, main = "Top 10 - Variable") # It displays a variable importance plot from the random forest model. 

importance(rf_model)                                        # It is worth mentioning that IncNodePurity by how much the model error increases by dropping each of the specified explanatory variables. 

##          IncNodePurity
## age          148.47066
## bmi           19.23523
## children      19.81647
## smoker        69.04689

                                                            # Briefly, varImpPlot() indicates each variable's importance in explaining the performance of the dependent variable (Y).

El análisis de Random Forest se ha aplicado para comprender y predecir los factores que influyen en los gastos del seguro de salud. Se ha construido utilizando un conjunto de datos de entrenamiento con 500 árboles en el bosque, considerando un solo predictor en cada división de los árboles. El modelo ha demostrado ser capaz de explicar aproximadamente el 65.4% de la variabilidad en los gastos de seguro, lo que indica una habilidad considerable para capturar las tendencias y patrones subyacentes en los datos.

La importancia de las variables, medida por el aumento promedio en la pureza del nodo (IncNodePurity), revela que la ‘edad’ es la variable más significativa, seguida por ‘si la persona es fumadora’, en la determinación de los gastos. El ‘índice de masa corporal’ y el ‘número de hijos’ también contribuyen a la predicción, pero en menor medida.

En resumen, el Random Forest identifica a la ‘edad’ y ‘si la persona es fumadora’ como los principales predictores de los costos de los seguros de salud. El modelo destaca cómo estas variables están estrechamente vinculadas con los gastos.

RMSE_rf

## [1] 0.4324175

Redes Neuronales

df2 <- na.omit(df2)  # Limpia el dataframe de NA
df2_alt <- df2 %>% dplyr::select(expenses, age,bmi,smoker,children)

df2$expenses= log(df2$expenses )
df2$age= log(df2$age )
df2$bmi= log(df2$bmi )

set.seed(123)
partition <- createDataPartition(y = df2$expenses, p = 0.7, list = FALSE)
train = df2[partition, ]
test = df2[-partition, ]
train2 = df2[partition, ]
test2 = df2[-partition, ]

# Lets estimate a Neural Network Regression

train2 <- train2 %>%
  mutate(smoker = if_else(smoker == "yes", 1, 0))
test2 <- test2 %>%
  mutate(smoker = if_else(smoker == "yes", 1, 0))

nn_model <- neuralnet(expenses ~ age +  bmi + children + smoker, data = train2, hidden = c(5, 3), linear.output = TRUE) 

# Plot the neural network 
plot(nn_model)


nn_predictions <- neuralnet::compute(nn_model, test2)
nn_predictions_values <- nn_predictions$net.result


actual_values <- test2$expenses


# Calcular el RMSE
rmse_NN <- Metrics::rmse(actual_values, nn_predictions_values)

El modelo de red neuronal, incorpora una arquitectura de dos capas ocultas, con cinco neuronas en la primera capa y tres en la segunda. Este diseño de red se eligió para capturar la complejidad del conjunto de datos mientras se mantenía una estructura eficiente para evitar el sobreajuste.

Tras un proceso de entrenamiento iterativo, en el que el modelo aprendió de los datos en 670 pasos, se ha alcanzado un error de 0.16. Este valor de error, que mide la diferencia promedio entre las predicciones de nuestro modelo y los valores reales, es una métrica clave de desempeño. Un error de 0.16, en el contexto de del rango de los datos, indica que el modelo es capaz de hacer predicciones con un alto grado de precisión.

En términos más prácticos, esto significa que nuestro modelo puede predecir con fiabilidad, basándose en las entradas proporcionadas.

# Imprimir el RMSE
print(rmse_NN)

## [1] 0.03888752

RMSE de todos los modelos

# Crear el data.frame
rmse_df <- data.frame(
  Modelo = c("RMSE de log_ols_model", "RMSE de log_ols_wls_model", "RMSE de XGB", "RMSE de Tree", "RMSE de RF", "RMSE de NN"),
  RMSE = c(RMSE_log_ols_model, RMSE_log_ols_wls_model, RMSE_XGB, RMSE_tree, RMSE_rf, rmse_NN)
)

# Imprimir el data.frame creado
print(rmse_df)

##                      Modelo       RMSE
## 1     RMSE de log_ols_model 0.43517072
## 2 RMSE de log_ols_wls_model 0.39095301
## 3               RMSE de XGB 1.00589420
## 4              RMSE de Tree 0.37617398
## 5                RMSE de RF 0.43241751
## 6                RMSE de NN 0.03888752

En este código se creo un data frame con los RMSE de todos los modelos para calcular cuál es el que menor comete errores al predecir los conjuntos de prueba del conjunto de datos original. Al analizar dichos resultados, se concluye fácilmente que el modelo de redes neuronales es el más apropiado para la predicción de los datos de Health Insurence, esto basado en las buenas métricas que arrojó en su modelo en sí y en su RMSE más bajo que el de todos los demás modelo.

# Crear el gráfico de barras
ggplot(rmse_df, aes(x = Modelo, y = RMSE, fill = Modelo)) +
  geom_bar(stat = "identity", show.legend = FALSE) + 
  theme_minimal() +
  theme(axis.text.x = element_text(angle = 45, hjust = 1)) +
  labs(title = "Comparación de RMSE por Modelo",
       x = "Modelo",
       y = "RMSE") +
  geom_text(aes(label = round(RMSE, 2)), vjust = -0.5, size = 3.5)

EDA

Basándonos en el exploratorio de datos, se ha concluido que varias variables presentan distribuciones anormales, las cuales fueron normalizadas mediante transformaciones logarítmicas. Además, se detectaron múltiples outliers que influían negativamente en la interpretación de nuestros modelos. Este análisis profundo permitió entender mejor la dinámica de cada variable y su interacción con la variable dependiente, lo cual facilitó la creación de un modelo más preciso y con mayor capacidad predictiva. También se observó una baja correlación entre las variables, lo cual descarta la preocupación por multicolinealidad y respalda el supuesto de independencia entre las variables explicativas.

No obstante, las irregularidades en las distribuciones de las variables independientes y la naturaleza de los datos transversales llevaron a anticipar potenciales problemas de heteroscedasticidad y anormalidad de residuales, los cuales se confirmaron durante la estimación de los modelos de regresión lineal. Estos desafíos se disminuyeron mediante transformaciones de las variables y la aplicación de un modelo de regresión lineal ponderado, mejorando así la fiabilidad de los resultados.

Modelo seleccionado