5 Regressão LASSO

A regressçao ridge mantém todas as variáveis no modelo final, memso quando \(k\) é grande. Isso pode ser um problema na interpretação do modelo, por conta da quantidade de variáveis e pelos baixos coeficientes. O lasso pe uma alternativa à regressão ridge que permite obter um modelo final com um subconjunto de variáveis.

Para rodar a regressão Lasso na linguagem R, usaremos o pacote glmnet.

library(readxl)

dados <- read_excel("dados_pinus.xlsx")

5.0.1 Variáveis

Para ilustrar a regressão ridge, vamos começar com um exemplo em que queremos estudar a relação entre DAP (variável preditora \(X_{1}\)) e Volume (variável dependente Y) com uma amostra de 250 arvores.

Local: Empresa Duratex Florestal SP
Amostra: 20 arvores
IAF : Indice Aerea Foliar
DAF : Distribuição Angular da Folha
GAP :
IDADE : Idade em Meses da arvore
DAP : Diâmetro a Altura do Peito (1.30 metros do solo)
ALTURA : Altura da arvore
ÁEREA BASAL : Area Basal da arvore

5.1 Modelo Regressão LASSO Geral

## Modelo Regressão LASSO Geral

library(caret)
library(glmnet)

set.seed(123)
train_index_lasso <- createDataPartition(dados$VOLUME, p = 0.9, list = FALSE)
dados_treino_lasso <- dados[train_index_lasso, ]
dados_teste_lasso  <- dados[-train_index_lasso, ]

x_train_lasso <- model.matrix(VOLUME ~ ., dados_treino_lasso)[, -1]
y_train_lasso <- dados_treino_lasso$VOLUME

x_test_lasso <- model.matrix(VOLUME ~ ., dados_teste_lasso)[, -1]
y_test_lasso <- dados_teste_lasso$VOLUME

# Validação cruzada LASSO
cv_lasso <- cv.glmnet(
  x_train_lasso,
  y_train_lasso,
  alpha = 1,
  standardize = TRUE
)

best_lambda_lasso <- cv_lasso$lambda.min

modelo_lasso <- glmnet(
  x_train_lasso,
  y_train_lasso,
  alpha = 1,
  lambda = best_lambda_lasso,
  standardize = TRUE
)

# Predição
y_pred_lasso <- predict(modelo_lasso, newx = x_test_lasso)

# Métricas
R2_lasso <- cor(y_test_lasso, y_pred_lasso)^2
rmse_lasso <- sqrt(mean((y_test_lasso - y_pred_lasso)^2))
mae_lasso <- mean(abs(y_test_lasso - y_pred_lasso))
mape_lasso <- mean(abs((y_test_lasso - y_pred_lasso) / y_test_lasso)) * 100

# Variáveis selecionadas
coef_lasso <- coef(modelo_lasso)
variaveis_lasso <- rownames(coef_lasso)[
  coef_lasso[, 1] != 0 & rownames(coef_lasso) != "(Intercept)"
]

# ---------------- AIC e BIC ---------------- #
y_fitted_lasso <- predict(modelo_lasso, newx = x_train_lasso)
RSS_lasso <- sum((y_train_lasso - y_fitted_lasso)^2)

df_lasso <- modelo_lasso$df[modelo_lasso$lambda == best_lambda_lasso]
n <- length(y_train_lasso)

AIC_lasso <- n * log(RSS_lasso / n) + 2 * (df_lasso + 1)
BIC_lasso <- n * log(RSS_lasso / n) + log(n) * (df_lasso + 1)

# Resultados
cat("\n--- Modelo LASSO  ---\n")


--- Modelo LASSO  ---

cat(
  "R² =", R2_lasso,
  "\nRMSE =", rmse_lasso,
  "\nMAE =", mae_lasso,
  "\nMAPE =", mape_lasso,
  "\nAIC =", AIC_lasso,
  "\nBIC =", BIC_lasso
)

R² = 0.9199676 
RMSE = 12.2659 
MAE = 10.5483 
MAPE = 23.57098 
AIC = 1055.38 
BIC = 1075.903

cat(
  "\nVariáveis selecionadas:",
  paste(variaveis_lasso, collapse = ", "),
  "\n"
)


Variáveis selecionadas: IDADE, DAP, ALTURA, DAF, AREA_BASAL

5.2 Lasso Trace Plot

library(dplyr)
library(tidyr)
library(ggplot2)
library(glmnet)


lasso_seq <- glmnet(x_train_lasso, 
                    y_train_lasso, 
                    alpha = 1, 
                    standardize = TRUE)

# Índice do lambda ótimo
id_best <- which.min(abs(lasso_seq$lambda - best_lambda_lasso))

# Coeficientes no lambda ótimo
coef_best <- as.matrix(lasso_seq$beta)[, id_best]

# Variáveis selecionadas (≠ 0)
vars_selected <- names(coef_best[coef_best != 0])

# Construir data frame dos coeficientes ao longo do caminho
df_lasso_path <- as.data.frame(t(as.matrix(lasso_seq$beta)))
df_lasso_path$log_lambda <- log(lasso_seq$lambda)

# Manter apenas variáveis selecionadas no modelo final
df_lasso_path <- df_lasso_path %>%
  select(log_lambda, all_of(vars_selected)) %>%
  pivot_longer(
    cols = -log_lambda,
    names_to = "Variavel",
    values_to = "Coeficiente"
  )

# Gráfico LASSO TRACE – MODELO ESCOLHIDO
ggplot(
  df_lasso_path,
  aes(x = log_lambda, y = Coeficiente, color = Variavel)
) +
  geom_line(size = 1.3) +
  geom_vline(
    xintercept = log(best_lambda_lasso),
    linetype = "dashed",
    linewidth = 1,
    color = "black"
  ) +
  labs(
    title = "LASSO Trace Plot",
    subtitle = expression(paste(
      ""
    )),
    x = expression(log(lambda)),
    y = "Coeficiente"
  ) +
  scale_color_brewer(palette = "Dark2") +
  theme_minimal(base_size = 14) +
  theme(
    plot.title = element_text(face = "bold", size = 16),
    plot.subtitle = element_text(size = 13, color = "gray40"),
    legend.title = element_blank(),
    panel.grid.minor = element_blank()
  )

5.3 MODELO MLP (REDE NEURAL)

library(caret)
library(nnet)
library(dplyr)


set.seed(123)

train_index_nn <- createDataPartition(dados$VOLUME, p = 0.9, list = FALSE)

dados_treino_nn <- dados[train_index_nn, ]
dados_teste_nn  <- dados[-train_index_nn, ]

preproc <- preProcess(dados_treino_nn[, -which(names(dados) == "VOLUME")],
                      method = c("center", "scale"))

x_train_nn <- predict(preproc, dados_treino_nn)
x_test_nn  <- predict(preproc, dados_teste_nn)



set.seed(123)

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

grid_mlp <- expand.grid(
  size = c(3, 5, 7),
  decay = c(0.001, 0.01, 0.1)
)

modelo_mlp <- train(
  VOLUME ~ .,
  data = x_train_nn,
  method = "nnet",
  tuneGrid = grid_mlp,
  trControl = ctrl,
  linout = TRUE,
  trace = FALSE,
  maxit = 500
)


y_pred_mlp <- predict(modelo_mlp, newdata = x_test_nn)

R2_mlp   <- cor(dados_teste_nn$VOLUME, y_pred_mlp)^2
rmse_mlp <- RMSE(y_pred_mlp, dados_teste_nn$VOLUME)
mae_mlp  <- MAE(y_pred_mlp, dados_teste_nn$VOLUME)



cat("\n--- REDE NEURAL (MLP) ---\n")


--- REDE NEURAL (MLP) ---

cat("R²:", R2_mlp,
    "\nRMSE:", rmse_mlp,
    "\nMAE:", mae_mlp,
    "\nMelhores parâmetros:",
    "\nNeurônios ocultos:", modelo_mlp$bestTune$size,
    "\nDecay:", modelo_mlp$bestTune$decay,
    "\n")

R²: 0.9180618 
RMSE: 12.37432 
MAE: 10.42029 
Melhores parâmetros: 
Neurônios ocultos: 3 
Decay: 0.1