Arvores de Regressão - XGBoost

Bibliotecas

library(MASS)         # Dados Boston
library(xgboost)      # Modelo XGBoost
library(dplyr)        # Manipulação de dados
library(rsample)      # Separação treino/teste
library(Metrics)      # Cálculo de RMSE
library(ggplot2)      # Gráficos

Avaliando, selecionando dados

data("Boston")
names(Boston)

 [1] "crim"    "zn"      "indus"   "chas"    "nox"     "rm"      "age"    
 [8] "dis"     "rad"     "tax"     "ptratio" "black"   "lstat"   "medv"   

dados <- Boston 

Treino e Teste com todas as variáveis

## Vamos criar os conjuntos de treino teste e desenvolver a arvore 
## com todas as variáveis.
library(caret)
set.seed(21)
indice <- createDataPartition(dados$medv, times=1, p=0.75, list=FALSE)
conj_treino <- dados[indice,]
conj_teste <- dados[-indice,] 
str(conj_treino)

'data.frame':   381 obs. of  14 variables:
 $ crim   : num  0.00632 0.02729 0.03237 0.06905 0.02985 ...
 $ zn     : num  18 0 0 0 0 12.5 12.5 12.5 12.5 12.5 ...
 $ indus  : num  2.31 7.07 2.18 2.18 2.18 7.87 7.87 7.87 7.87 7.87 ...
 $ chas   : int  0 0 0 0 0 0 0 0 0 0 ...
 $ nox    : num  0.538 0.469 0.458 0.458 0.458 0.524 0.524 0.524 0.524 0.524 ...
 $ rm     : num  6.58 7.18 7 7.15 6.43 ...
 $ age    : num  65.2 61.1 45.8 54.2 58.7 66.6 96.1 100 94.3 39 ...
 $ dis    : num  4.09 4.97 6.06 6.06 6.06 ...
 $ rad    : int  1 2 3 3 3 5 5 5 5 5 ...
 $ tax    : num  296 242 222 222 222 311 311 311 311 311 ...
 $ ptratio: num  15.3 17.8 18.7 18.7 18.7 15.2 15.2 15.2 15.2 15.2 ...
 $ black  : num  397 393 395 397 394 ...
 $ lstat  : num  4.98 4.03 2.94 5.33 5.21 ...
 $ medv   : num  24 34.7 33.4 36.2 28.7 22.9 27.1 16.5 15 21.7 ...

str(conj_teste)

'data.frame':   125 obs. of  14 variables:
 $ crim   : num  0.0273 0.17 0.1175 0.6274 0.8027 ...
 $ zn     : num  0 12.5 12.5 0 0 0 0 0 0 75 ...
 $ indus  : num  7.07 7.87 7.87 8.14 8.14 8.14 8.14 5.96 5.96 2.95 ...
 $ chas   : int  0 0 0 0 0 0 0 0 0 0 ...
 $ nox    : num  0.469 0.524 0.524 0.538 0.538 0.538 0.538 0.499 0.499 0.428 ...
 $ rm     : num  6.42 6 6.01 5.83 5.46 ...
 $ age    : num  78.9 85.9 82.9 56.5 36.6 91.7 82 61.4 30.2 21.8 ...
 $ dis    : num  4.97 6.59 6.23 4.5 3.8 ...
 $ rad    : int  2 5 5 4 4 4 4 5 5 3 ...
 $ tax    : num  242 311 311 307 307 307 307 279 279 252 ...
 $ ptratio: num  17.8 15.2 15.2 21 21 21 21 19.2 19.2 18.3 ...
 $ black  : num  397 387 397 396 289 ...
 $ lstat  : num  9.14 17.1 13.27 8.47 11.69 ...
 $ medv   : num  21.6 18.9 18.9 19.9 20.2 15.2 13.2 20 24.7 30.8 ...

Preparando os dados

x_treino <- model.matrix(medv ~ . , data = conj_treino)[, -1]
y_treino <- conj_treino$medv

x_teste <- model.matrix(medv ~ . , data = conj_teste)[, -1]
y_teste = conj_teste$medv

dtrain <- xgb.DMatrix(data = x_treino, label = y_treino)
dtest <- xgb.DMatrix(data = x_teste, label = y_teste)

Treinamento com validação cruzada e grid de parâmetros

set.seed(21)
# Grid de hiperparâmetros
grid <- expand.grid(
  eta = c(0.01, 0.1),
  max_depth = c(3, 6),
  nrounds = c(100, 200)
)

# Avaliar cada combinação com CV
resultados_cv <- list()

for (i in 1:nrow(grid)) {
  params <- list(
    objective = "reg:squarederror",
    eta = grid$eta[i],
    max_depth = grid$max_depth[i],
    verbosity = 0
  )
  
  cv <- xgb.cv(
    params = params,
    data = dtrain,
    nrounds = grid$nrounds[i],
    nfold = 5,
    metrics = "rmse",
    early_stopping_rounds = 10,
    verbose = 0
  )
  
  resultados_cv[[i]] <- list(
    rmse = min(cv$evaluation_log$test_rmse_mean),
    best_nrounds = cv$best_iteration,
    params = grid[i, ]
  )
}

# Melhor modelo
rmses <- sapply(resultados_cv, function(x) x$rmse)
melhor_indice <- which.min(rmses)
melhor_param <- resultados_cv[[melhor_indice]]$params
melhor_nrounds <- resultados_cv[[melhor_indice]]$best_nrounds

melhor_param

  eta max_depth nrounds
6 0.1         3     200

Modelo Final

# Treino final com os melhores parâmetros
final_model <- xgb.train(
  params = list(
    objective = "reg:squarederror",
    eta = melhor_param$eta,
    max_depth = melhor_param$max_depth
  ),
  data = dtrain,
  nrounds = melhor_nrounds,
  verbose = 0
)

Importancia das variáveis

# Importância das variáveis
importance_matrix <- xgb.importance(model = final_model)

# Gráfico
xgb.plot.importance(importance_matrix)

Previsões

conj_teste$prev <- predict(final_model, dtest)


ggplot(conj_teste, aes(x = prev, y = medv)) + 
  geom_point() + 
  geom_abline()

Calculando o RMSE

rmse_final <- rmse(y_teste, conj_teste$prev)
cat("RMSE no conjunto de teste:", rmse_final)

RMSE no conjunto de teste: 3.80707

caret::postResample(conj_teste$prev, conj_teste$medv)

     RMSE  Rsquared       MAE 
3.8070699 0.8497835 2.3451366 

Comparação com outro modelo (Regressão Linear)

ctrl <- trainControl(method = "cv", number = 5)

model_lm <- train(
  medv ~ ., data = conj_treino,
  method = "lm",
  trControl = ctrl
)

pred_lm <- predict(model_lm, newdata = conj_teste)
postResample(pred_lm, conj_teste$medv)

     RMSE  Rsquared       MAE 
5.9426142 0.6315418 3.9610503