start e end

Qual a média mensal de horas dormidas e que horas costumo acordar, em média, mensalmente ao longo desses anos?

dy1 <- sleep %>% 
  complete(start = seq.Date(min(as.Date(start)), max(as.Date(start)), by="day")) %>%
  mutate(dif_sleep_hours = as.numeric(end - start)/60) %>% 
  mutate(dif_sleep_hours = zoo::rollmean(dif_sleep_hours, k =  30, fill = NA)) %>%
  plot_dygraph(order.by = .$start, feature =  'dif_sleep_hours')

dy2 <- sleep %>% 
  complete(start = seq.Date(min(as.Date(start)), max(as.Date(start)), by="day")) %>%
  mutate(end_hour = hour(end)) %>% 
  mutate(end_hour = zoo::rollmean(end_hour, k =  30, fill = NA)) %>%
  plot_dygraph(order.by = .$start, feature =  'end_hour')

window_start e window_stop

Quanto tempo costumo usar o modo “soneca” ao longo da semana? E aos finais de semana?

p <- sleep %>% 
  mutate(mood = ifelse(is.na(mood), "NA", as.character(mood)) %>% 
           factor(levels = c("Ruim", "NA", "Bom"))) %>% 
  mutate(nap_minutes = (window_stop - window_start) / 30,
         final_de_semana = lubridate::wday(start) %in% c(1, 7)) %>% 
  count(mood, final_de_semana, nap_minutes) %>% 
  group_by(mood, final_de_semana) %>% 
  mutate(
    fnap_minutes = case_when(
      nap_minutes == 0 ~ "Sem modo soneca",
      nap_minutes == 20 ~ "20 minutos",
      nap_minutes == 30 ~ "30 minutos",
      nap_minutes == 60 ~ "1 hora"),
    fnap_minutes = reorder(fnap_minutes, nap_minutes),
    final_de_semana = ifelse(final_de_semana == T, "Final de semena", "Dia de semana"),
    label = paste0( n, " (", round(n/sum(n)*100, 2), "%)")
  ) %>% 
  ggplot(aes(x = fnap_minutes, y = n, label = label, fill = mood))+
  geom_bar(stat = "identity", alpha = 0.8)+
  scale_fill_viridis_d(end = 0.7, direction = 1)+
  # ggrepel::geom_label_repel(aes(label = label))+
  labs(x = "", y = "")+
  facet_wrap(~final_de_semana)+
  theme(axis.text.x = element_text(angle = 30, hjust=1))

p %>% plotly::ggplotly() %>% plotly::config(displayModeBar = F)

Como era de se esperar, os dias em que mood=="Ruim" ocorrem mais quando o modo soneca não é ativado pois acaba mesmo sendo menos propício a voltar a dormir. Outro detalhe é que muitas vezes usei o soneca por um tempo muito prolongado! (😱 pelo menos mood=="Bom" na maioria desses casos!)

Já nos finais de semana, ocorre pouquíssimo mood== "Ruim" e praticamente não há uso do alarme e quando há, não utiliza soneca.

weather_type e alarm_mode

Será que o humor ao acordar esta relacionado com o tipo de clima ou com o modo utilizado no alarme?

p1 <- plot_cat(sleep, cat_feature="weather_type", 
               title = "Tipo de clima", label = F)+ 
  theme(axis.text.x = element_text(angle = 30, hjust=1))

p2 <- plot_cat(sleep, cat_feature="alarm_mode", 
               title = "Modo de alarme", label = F, legend = "right")

p1 | p2

Nota-se que não existem evidências estatisticas para afimar que essas features (sozinhas) estão associadas à target, porém como serão utilizados modelos baseados em árvores que experimentam diversas combinações de features, vamos manter na base e deixar o modelo decidir como usar.

sleep_quality e time_in_bed_seconds

A qualidade de sono e o tempo da cama estão normalmente distribuídos em torno de uma média?

p1 <- sleep %>% plot_num("sleep_quality")
p2 <- sleep %>% plot_num("time_in_bed_seconds", legend = "right")

p1 | p2

Existem alguns registros em que o tempo na cama é menor que 10.000 segundos (~3horas) o que corresponde aos pequenos cochilos que registrei no app. Não foram muitos registros mas talvez seja útil na modelagem pois existem ocorrências de humor (mood) Bom e Ruim ali.

Como a correlação de spearman entre estas duas feautures é muito alta (0.8705) é possível notar que baixa qualidade do sono esta altamente correlacionada com o tempo na cama.

Mais uma pergunta sobre estas features: Como a média mensal da qualidade do sono e do tempo na cama em horas estão distribuídos ao longo do tempo?

dy1 <- sleep %>% 
  complete(start = seq.Date(min(as.Date(start)),
                            max(as.Date(start)), by="day")) %>%
  mutate(sleep_quality = zoo::rollmean(sleep_quality, k =  30, fill = NA)) %>%
  plot_dygraph(order.by = .$start, feature =  'sleep_quality')

dy2 <- sleep %>% 
  complete(start = seq.Date(min(as.Date(start)), 
                            max(as.Date(start)), by="day")) %>%
  mutate(time_in_bed_seconds = 
           zoo::rollmean(time_in_bed_seconds, k =  30, fill = NA)) %>%
  mutate(time_in_bed_seconds = time_in_bed_seconds / 60 / 60) %>% 
  plot_dygraph(order.by = .$start, feature =  'time_in_bed_seconds')

Default

Os parâmetros default foram definidos baseados na documentação oficial do pacote rpart em https://cran.r-project.org/web/packages/rpart/rpart.pdf e o de/para para definição dos parâmetros na página do pacote parsnip em https://parsnip.tidymodels.org/reference/decision_tree.html

tree_model_bas <- decision_tree(
  cost_complexity = 0.01, # cp
  tree_depth = 30,        # maxdepth
  min_n = 20              # minsplit
) %>% 
  set_engine("rpart") %>%
  set_mode("classification")

Definir o objeto workflow:

tree_wflow_bas <- workflow() %>% 
  add_recipe(sleep_recipe) %>% 
  add_model(tree_model_bas) 

Ajustar modelo via validação cruzada:

tree_res_bas <- fit_resamples(
  tree_wflow_bas,
  sleep_folds,
  metrics = metric_set(pr_auc, roc_auc, mn_log_loss),
  control = control_resamples(save_pred = TRUE)
)
# Salvar "cache" da otimizacao 
saveRDS(tree_res_bas, "tree_res_bas.rds")

Finalizar o modelo:

# Finalizar workflow com parametros selecionados (default nesse caso)
tree_final_wflow_bas <- 
  finalize_workflow(
    tree_wflow_bas,
    select_best(tree_res_bas, metric = 'mn_log_loss') 
  )

# Realizar ajuste final nos dados de treino
tree_final_fit_bas <- tree_final_wflow_bas %>% last_fit(sleep_split) 

# Coletar previsões nos dados de teste
tree_test_preds_bas <- collect_predictions(tree_final_fit_bas)

Vejamos como ficou o modelo baseline:

tre_model_bas <- 
  tree_final_fit_bas$.workflow[[1]] %>% 
  pull_workflow_fit()

rattle::fancyRpartPlot(tre_model_bas$fit, sub = NULL, cex = 0.6)

Note que o modelo default se baseia nas features time_before_sleep_seconds e steps. Talvez, com outra combinação de parâmetros seja possível conseguir um modelo uma árvore um pouco maior com resultado igual/melhor.

Como são apenas duas features, é possível visualizar os regras de classificação a partir de um gráfio de dispersão

sleep_train %>%
  ggplot(aes(time_before_sleep_seconds, steps)) +
  parttree::geom_parttree(data = tre_model_bas$fit, alpha = 0.3) +
  geom_jitter(aes(color = mood), alpha = 0.7) +
  scale_color_viridis_d(end = 0.8, direction = 1)

Vamos avaliar desempenho do modelo nos dados de teste:

tree_test_preds_bas %>% 
  mutate(mood = factor(mood, levels = c("Ruim", "Bom"), ordered = TRUE)) %>% 
  conf_mat_plot()

O modelo não esta muito bom… mas também não esta muito ruim para começar! 😅

Coram 5/8 acertos para classe de interesse, vamos tentar fazer o tunning deste modelo!

Tunning

Definir o modelo que será utilizado:

tree_model_tun <- decision_tree(
  min_n = tune(),
  cost_complexity = tune(), 
  tree_depth = tune()
) %>%
  set_engine("rpart") %>%
  set_mode("classification")
# tree_model_tun %>% translate()

Definir o objeto workflow:

tree_wflow_tun <- workflow() %>% 
  add_recipe(sleep_recipe) %>% 
  add_model(tree_model_tun) 

O grid utilizado foi alterado para tentar previnir que a árvore tenha apenas o nó raiz pois o grid default, combinado com o threshold, estava gerando um “cotoco”.

• min_n: [1, 5]
• cost_complexity: (transformed scale): [-10, -1]
• tree_depth: [10, 20]

Definir um grid aleatório para otimização dos hiperparâmetros:

tree_params <- 
  tree_model_tun %>% 
  parameters() %>%
  update(
    min_n = min_n(c(1, 5)), 
    cost_complexity = cost_complexity(),
    tree_depth = tree_depth(c(10, 20)) 
  )

tree_grid <-grid_regular(tree_params, levels = 3)

Ajustar modelo:

tree_res_tun <- 
  tree_wflow_tun %>% 
  tune_grid(
    resamples = sleep_folds,
    grid = tree_grid,
    metrics = metric_set(roc_auc, mn_log_loss, pr_auc),
    control = control_grid(save_pred = TRUE)
  )

# Salvar cache da otimizacao 
# saveRDS(tree_res_tun, "tree_res_tun.rds")

Impacto de cada hiperparâmetro no resultado das métricas cálculadas para cada modelo:

id_best_model <- 
  show_best(tree_res_tun, metric = 'mn_log_loss') %>%
  slice(1) %>% 
  pull(.config)

plot_tree_tun <- 
  tree_res_tun %>% 
  collect_metrics() %>% 
  mutate(best_model = if_else(.config == id_best_model, 
                              "BestModel", "Try")
         # cost_complexity = log(cost_complexity)-10
  ) %>% 
  select(.metric, mean, best_model,
         cost_complexity:min_n) %>%
  pivot_longer(cost_complexity:min_n,
               values_to = "value",
               names_to = "parameter"
  ) %>% 
  mutate(parameter = case_when(
    parameter == "cost_complexity" ~ "Cost-Complexity Parameter",
    parameter == "tree_depth" ~ "Tree Depth",
    parameter == "min_n" ~ "Minimal Node Size",
    
  ))%>% {
    ggplot(., aes(value, mean, color = best_model)) +
      geom_point(alpha = 0.6, show.legend = FALSE) +
      geom_point(data = subset(., best_model == 'BestModel'), 
                 size = 4, shape = 3)+
      scale_color_manual(values = c("red", "black"))+
      facet_grid(.metric~parameter, scales = "free") +
      labs(x = NULL, y = NULL)
  }
# Codigo para mesmo grafico sem cor para melhor modelo:
# autoplot(tree_res_tun)

plot_tree_tun %>% 
  plotly::ggplotly()%>% 
  plotly::layout(showlegend = FALSE) %>% 
  plotly::config(displayModeBar = F)

5 Melhores resultados:

show_best(tree_res_tun, metric = 'mn_log_loss') %>% 
  select(-.estimator, -n, -.config)

## # A tibble: 5 x 6
##   cost_complexity tree_depth min_n .metric      mean std_err
##             <dbl>      <int> <int> <chr>       <dbl>   <dbl>
## 1             0.1         10     1 mn_log_loss  1.64   0.212
## 2             0.1         15     1 mn_log_loss  1.64   0.212
## 3             0.1         20     1 mn_log_loss  1.64   0.212
## 4             0.1         10     3 mn_log_loss  1.64   0.212
## 5             0.1         15     3 mn_log_loss  1.64   0.212

Finalizar o modelo com o conjunto de parâmetros encontrados no processo de otimização:

# finalizar workflow definindo modelo final
tree_final_wflow_tun <- 
  finalize_workflow(
    tree_wflow_tun,
    select_best(tree_res_tun, metric = 'mn_log_loss') )

# Realizar ajuste final nos dados de treino
tree_final_fit_tun <- tree_final_wflow_tun %>% last_fit(sleep_split) 

# Coletar previsões nos dados de teste
tree_test_preds_tun <- collect_predictions(tree_final_fit_tun)

Vejamos como ficou foi o ajuste do modelo utilizando a configuração obtida no após o tunning final:

tre_model_tun <- pull_workflow_fit(tree_final_fit_tun$.workflow[[1]])

rattle::fancyRpartPlot(tre_model_tun$fit, sub = NULL, cex = 0.6)

Avaliar desempenho do modelo nos dados de teste:

tree_test_preds_tun %>% 
  mutate(mood = factor(mood, levels = c("Ruim", "Bom"), ordered = TRUE)) %>%
  conf_mat_plot()

Ao comparar o modelo default com o modelo após o tunning é possível notar que o número de verdadeiros positivos foi menor porém o número de fasos positivos tbm foi menor devido ao elevado trs_fbeta encontrado (maximizando F0.5).

No geral, o modelo tunado ficou pior que o modelo default mas como o modelo de árvore de deciões costuma ser bem instável, ainda mais em um cenário de dados desbalanceados vamos apenas guardar estes resultados e dar mais um passo, combinando diversas árvore de decisões!

Default

Os parâmetros default foram definidos baseados na documentação oficial do pacote ranger em https://cran.r-project.org/web/packages/ranger/ranger.pdf e o de/para para definição dos parâmetros na página do pacote parsnip em https://parsnip.tidymodels.org/reference/rand_forest.html

# raiz quadrada do numero de features 
n_col = ncol(juice(sleep_recipe))

rf_model_bas <- rand_forest(
  mtry = sqrt(n_col) %>% floor(), # mtry
  trees = 500,                    # num.trees
  min_n = 1                       # min.node.size 
) %>% 
  set_engine("ranger", num.threads = 4, importance = "permutation") %>% 
  set_mode("classification")

Definir o objeto workflow:

rf_wflow_bas <- workflow() %>% 
  add_recipe(sleep_recipe) %>% 
  add_model(rf_model_bas) 

Ajustar modelo via validação cruzada:

rf_res_bas <- fit_resamples(
  rf_wflow_bas,
  sleep_folds,
  metrics = metric_set(roc_auc, mn_log_loss, pr_auc),
  control = control_resamples(save_pred = TRUE)
)

Finalizar o modelo com o conjunto de parâmetros encontrados no processo de otimização:

# Finalizar workflow com parametros selecionados (default nesse caso)
rf_final_wflow_bas <- 
  finalize_workflow(
    rf_wflow_bas,
    select_best(rf_res_bas, metric = 'mn_log_loss') )

# Realizar ajuste final nos dados de treino
rf_final_fit_bas <- rf_final_wflow_bas %>% last_fit(sleep_split) 

# Coletar previsões nos dados de teste
rf_test_preds_bas <- collect_predictions(rf_final_fit_bas)

Avaliar desempenho do modelo nos dados de teste:

rf_test_preds_bas %>% 
  mutate(mood = factor(mood, levels = c("Ruim", "Bom"), ordered = TRUE)) %>%
  conf_mat_plot()

Este modelo não fez nenhuma previsão de falso positivo! Porém note que o trs_fbeta ficou bastante alto, o que deve ter ocorrido como reflexo do elevado logloss que indicaria que a incerteza que o modelo tem nas previsões esta alta.

Tunning

Definir o modelo que será utilizado:

rf_model_tun <- rand_forest(
  mtry = tune(),
  trees = tune(), 
  min_n = tune()
) %>% 
  set_engine("ranger", num.threads = 4, importance = "permutation") %>% 
  set_mode("classification")
# tree_model %>% translate()

Definir o objeto workflow:

rf_wflow_tun <- workflow() %>% 
  add_recipe(sleep_recipe) %>% 
  add_model(rf_model_tun) 

O grid utilizado tentará valores superiores e inferiores ao número de árvores default do algoritmo e vamos incluir o valor 1 ao min_n pois árvores mais longas neste método podem ser úteis. O mtry será calculado baseado nas informações do dataset de treino.

• trees: [100, 900]
• min_n: [1, 40]
• mtry: [1, 20]

Definir técnica de otimização de hiperparâmetros

rf_grid <-grid_max_entropy(
  trees() %>% range_set(c(100, 900)), # Default Range: [1, 2000]
  min_n() %>% range_set(c(1, 40)),    # Default Range: [2, 40]
  finalize(mtry(), sleep_train),
  size = 30)

Ajustar modelo:

rf_res_tun <- 
  rf_wflow_tun %>% 
  tune_grid(
    resamples = sleep_folds,
    grid = rf_grid,
    metrics = metric_set(roc_auc, mn_log_loss, pr_auc),
    control = control_grid(save_pred = TRUE)
  )

# Salvar cache da otimizacao 
saveRDS(rf_res_tun, "rf_res_tun.rds")

Impacto de cada hiperparâmetro no resultado das métricas cálculadas para cada modelo:

id_best_model <- 
  show_best(rf_res_tun, metric = 'mn_log_loss') %>%
  slice(1) %>% 
  pull(.config)

plot_rf_tun <- 
  rf_res_tun %>% 
  collect_metrics() %>% 
  mutate(best_model = if_else(.config == id_best_model, 
                              "BestModel", "Try")) %>% 
  select(.metric, mean, best_model,
         mtry:min_n) %>%
  pivot_longer(mtry:min_n,
               values_to = "value",
               names_to = "parameter"
  ) %>% 
  mutate(parameter = case_when(
    parameter == "mtry" ~ "Randomly Selected Predictors",
    parameter == "min_n" ~ "Minimal Node Size",
    parameter == "trees" ~ "# Trees"
  )) %>% {
    ggplot(., aes(value, mean, color = best_model)) +
      geom_point(alpha = 0.6, show.legend = FALSE) +
      geom_point(data = subset(., best_model == 'BestModel'), 
                 size = 4, shape = 3)+
      scale_color_manual(values = c("red", "black"))+
      facet_grid(.metric~parameter, scales = "free") +
      labs(x = NULL, y = NULL)
  }
# Codigo para mesmo grafico sem cor para melhor modelo:
# autoplot(rf_res_tun)

plot_rf_tun %>% 
  plotly::ggplotly()%>% 
  plotly::layout(showlegend = FALSE) %>% 
  plotly::config(displayModeBar = F)

Melhores resultados:

show_best(rf_res_tun, metric = 'mn_log_loss') %>% 
  select(-.estimator, -n, -.config)

## # A tibble: 5 x 6
##    mtry trees min_n .metric      mean std_err
##   <int> <int> <int> <chr>       <dbl>   <dbl>
## 1     1   657    37 mn_log_loss 0.284 0.00582
## 2     1   265    32 mn_log_loss 0.284 0.00639
## 3     3   674    21 mn_log_loss 0.296 0.0190 
## 4     4   448    26 mn_log_loss 0.299 0.0188 
## 5     5   822    30 mn_log_loss 0.306 0.0193

Finalizar o modelo com o conjunto de parâmetros encontrados no processo de otimização:

# finalizar workflow definindo modelo final
rf_final_wflow_tun <- 
  finalize_workflow(
    rf_wflow_tun,
    select_best(rf_res_tun, metric = 'mn_log_loss') )

# Realizar ajuste final nos dados de treino
rf_final_fit_tun <- rf_final_wflow_tun %>% last_fit(sleep_split) 

# Coletar previsões nos dados de teste
rf_test_preds_tun <- collect_predictions(rf_final_fit_tun)

Vejamos como ficou foi o ajuste do modelo utilizando a configuração obtida no após o tunning final:

Avaliar desempenho do modelo nos dados de teste:

rf_test_preds_tun %>% 
  mutate(mood = factor(mood, levels = c("Ruim", "Bom"), ordered = TRUE)) %>%
  conf_mat_plot()

Note que apesar do maior número de Verdadeiros Positivos, este modelo apresentou um Falso Positivo. Parece estranho pois é exatamente o que queriamos evitar porém é possível notar que o logloss foi bem inferior e o trs_fbeta está bem mais razoavel agora.

Importancia de cada feature conforme o modelo:

vip::vip(pull_workflow_fit(rf_final_fit_tun$.workflow[[1]]))

Diferente do modelo baseado em 1 unica árvore de decisões, a feature steps não foi tão importante assim. A time_asleep_seconds foi a mais importante mas com a ordem de grandeza muito próxima de time_before_sleep_seconds.

Random Forest é um excelente modelo e poderíamos investir mais tempo tentando otimizando sua performance mas para este post acho que já esta suficiente. Vamos para o próximo modelo! 😍

Default

Os parâmetros default foram definidos baseados na documentação oficial do pacote lightgbm em https://lightgbm.readthedocs.io/en/latest/ e o de/para para definição dos parâmetros na página do (incrível 🤩) pacote treesnip em https://github.com/curso-r/treesnip/blob/master/R/lightgbm.R

lgbm_model_bas <- parsnip::boost_tree(
  mode = "classification",
  trees = 100,       # num_iterations
  learn_rate = 0.1,  # fixo
  min_n = 20,        # min_data_in_leaf
  tree_depth = 6,    # max_depth
  sample_size = 1,   # bagging_fraction
  mtry = 1,          # feature_fraction
  loss_reduction = 0 # min_gain_to_split
) %>%  
  set_engine("lightgbm",
             nthread = 4,
             importance = "permutation") %>% 
  set_mode("classification")

Definir o objeto workflow:

lgbm_wflow_bas <- workflow() %>% 
  add_recipe(sleep_recipe) %>% 
  add_model(lgbm_model_bas) 

Ajustar modelo via validação cruzada:

lgbm_res_bas <- fit_resamples(
  lgbm_wflow_bas,
  sleep_folds,
  metrics = metric_set(roc_auc, mn_log_loss, pr_auc),
  control = control_resamples(save_pred = TRUE)
)
saveRDS(lgbm_res_bas, "lgbm_res_bas.rds")

Finalizar o modelo com o conjunto de parâmetros encontrados no processo de otimização:

# Finalizar workflow com parametros selecionados (default nesse caso)
lgbm_final_wflow_bas <- 
  finalize_workflow(
    lgbm_wflow_bas,
    select_best(lgbm_res_bas, metric = 'mn_log_loss') )

# Realizar ajuste final nos dados de treino
lgbm_final_fit_bas <- lgbm_final_wflow_bas %>% last_fit(sleep_split) 

# Coletar previsões nos dados de teste
lgbm_test_preds_bas <- collect_predictions(lgbm_final_fit_bas)

Avaliar desempenho do modelo nos dados de teste:

lgbm_test_preds_bas %>% 
  mutate(mood = factor(mood, levels = c("Ruim", "Bom"), ordered = TRUE)) %>%
  conf_mat_plot()

Tunning

Para o tunning vamos utilizar uma estratégia um pouco diferente. Vamos fixar o número de árvores trees e a taxa de aprendizado learning_rate pois vamos separar mais uma pequena parte dos dados para usar o recurso early_stopping. Esta opção basicamente “trava” o crescimento da árvore caso o modelo não melhore a performance a partir da n-ésima iteração.

lgbm_model_tun <- parsnip::boost_tree(
  mode = "classification",
  trees = 700,             # autotune com early stopping
  learn_rate = 0.01,       # early stopping
  min_n = tune(),          # min_data_in_leaf
  tree_depth = tune(),     # max_depth
  sample_size = 1,         # bagging_fraction, n funciona com goss
  mtry = tune(),           # feature_fraction
  loss_reduction = tune()  # min_gain_to_split
) %>%  
  set_engine("lightgbm", nthread = 4, 
             # parametros para early stopping
             early_stop = 30,
             validation = .20,
             eval_metric = "mn_log_loss",
             importance = "permutation"
             # feature_fraction = tune("feature_fraction")
  ) %>% 
  set_mode("classification")
# tree_model %>% translate()

Definir o objeto workflow:

lgbm_wflow_tun <- workflow() %>% 
  add_recipe(sleep_recipe) %>% 
  add_model(lgbm_model_tun) 

Definir grid para otimização de hiperparâmetros baseados nas sugestões de github/Laurae2 em uma issue no repositório oficial do modelo

lightgbm_params <- 
  dials::parameters(
    # learn_rate(),           # learning_rate
    # trees()                 # num_iterations
    min_n(),                  # min_data_in_leaf
    tree_depth(c(2, 63)),     # max_depth
    # sample_prop(c(0.4, 1)), # bagging_fraction (vai para sample_size)
    mtry(),                   # feature_fraction
    loss_reduction()          # min_gain_to_split
  ) 

lgbm_grid <- lightgbm_params %>% 
  finalize(sleep_train) %>% 
  grid_max_entropy(size = 30)

Ajustar modelo:

lgbm_res_tun <- 
  lgbm_wflow_tun %>% 
  tune_grid(
    resamples = sleep_folds,
    grid = lgbm_grid,
    metrics = metric_set(roc_auc, mn_log_loss, pr_auc),
    control = control_grid(save_pred = TRUE)
  )

# Salvar cache da otimizacao 
saveRDS(lgbm_res_tun, "lgbm_res_tun.rds")

Impacto de cada hiperparâmetro no resultado das métricas cálculadas para cada modelo:

id_best_model <- 
  show_best(lgbm_res_tun, metric = 'mn_log_loss')[1, ] %>% 
  pull(.config)

plot_lgbm_tun <- 
  lgbm_res_tun %>% 
  collect_metrics() %>% 
  mutate(best_model = if_else(.config == id_best_model, 
                              "BestModel", "Try")) %>% 
  select(.metric, mean, best_model,
         mtry:loss_reduction) %>%
  pivot_longer(mtry:loss_reduction,
               values_to = "value",
               names_to = "parameter"
  ) %>% {
    ggplot(., aes(value, mean, color = best_model)) +
      geom_point(alpha = 0.6, show.legend = FALSE) +
      geom_point(data = subset(., best_model == 'BestModel'), 
                 size = 4, shape = 3)+
      scale_color_manual(values = c("red", "black"))+
      facet_grid(.metric~parameter, scales = "free") +
      labs(x = NULL, y = NULL)
  }

# Codigo para mesmo grafico sem cor para melhor modelo:
# autoplot(lgbm_res_tun)

plot_lgbm_tun %>% 
  plotly::ggplotly()%>% 
  plotly::layout(showlegend = FALSE) %>% 
  plotly::config(displayModeBar = F)

Melhores resultados:

show_best(lgbm_res_tun, metric = 'mn_log_loss') %>% 
  select(-.estimator, -n, -.config)

## # A tibble: 5 x 7
##    mtry min_n tree_depth loss_reduction .metric      mean std_err
##   <int> <int>      <int>          <dbl> <chr>       <dbl>   <dbl>
## 1     2    35         28 0.000000000108 mn_log_loss 0.259 0.00888
## 2     1    16          5 0.00000160     mn_log_loss 0.267 0.0100 
## 3     4    28         31 0.000507       mn_log_loss 0.272 0.0111 
## 4     5    39         62 0.000164       mn_log_loss 0.273 0.00955
## 5     2    14         19 0.0642         mn_log_loss 0.274 0.0138

Finalizar o modelo com o conjunto de parâmetros encontrados no processo de otimização:

# finalizar workflow definindo modelo final
lgbm_final_wflow_tun <- 
  finalize_workflow(
    lgbm_wflow_tun,
    select_best(lgbm_res_tun, metric = 'mn_log_loss') )

# Realizar ajuste final nos dados de treino
lgbm_final_fit_tun <- lgbm_final_wflow_tun %>% last_fit(sleep_split) 

# Coletar previsões nos dados de teste
lgbm_test_preds_tun <- collect_predictions(lgbm_final_fit_tun)

Vejamos como ficou foi o ajuste do modelo utilizando a configuração obtida no após o tunning final:

Avaliar desempenho do modelo nos dados de teste:

lgbm_test_preds_tun %>% 
  mutate(mood = factor(mood, levels = c("Ruim", "Bom"), ordered = TRUE)) %>%
  conf_mat_plot()

Que maravilha! Modelos acertaram mais a classe de interesse do que os anteriores (apesar do default ainda apresentar alta proporção de falsos positivos). Note ainda que o LightGBM após o tunning apresentou as melhores métricas no geral (melhor AUC-PR, menor logloss e um bom equilíbrio no trade-off de Precision x Recall).

Vejamos quais as features mais importantes no ajuste do modelo:

lgbm_imp_tun <- lightgbm::lgb.importance(lgbm_final_fit_tun$.workflow[[1]]$fit$fit$fit, percentage = T)

lgbm_imp_tun%>% 
  mutate(Feature = reorder(Feature, Gain)) %>% 
  ggplot(aes(x = Feature, y = Gain))+
  geom_bar(stat = "identity")+
  labs(y = "Importance", x= "")+
  coord_flip()