Prova Aprendizagem da Máquinas

Primeira Questão

Explique com suas palavras o dilema de balanço entre viés e variância.

Resposta :

O viés refere á diferença entre as previsões médias do modelo e os valores reais que estamos tentando prever.

Variância é a sensibilidade do modelo ás variações nos dados de treinamento.

Segunda Questão

Explique resumidamente o que é aprendizagem supervisionada e não-supervisionada. Cite um problema de aprendizagem supervisionada e um outro de aprendizagem não-supervisionada.

Resposta:

Aprendizagem supervisionada usamos o método de classificação, o objetivo é mapear as entradas e as saídas com base nos padrões identificados nos dados de treinamento.

Aprendizagem não-supervisionada usamos o método de classificação, o objetivo é encontrar padrões, estruturas ou relações intrínsecas nos dados sem que haja informações prévias sobre as saídas desejadas.

Terceira Questão

Explique qual o motivo que faz com que o Erro Quadrático Médio-EQM para avaliar o desempenho de um modelo é ruim quando não adotamos nenhuma estratégia de divisão do conjunto de dados em treinamento e teste.

Resposta:

Overfitting (Sobreajuste): Quando um modelo é treinado em todo o conjunto de dados, ele pode aprender detalhes e ruídos específicos dos dados de treinamento que não são generalizáveis para novos dados. Isso pode resultar em um modelo que se ajusta muito bem aos dados de treinamento, mas que performa mal em dados não vistos anteriormente. O EQM pode ser baixo nos dados de treinamento, mas alto nos dados de teste devido ao overfitting.

Avaliação inadequada da generalização: A principal razão para dividir o conjunto de dados em treinamento e teste é avaliar como o modelo generaliza para dados não vistos. Quando não há divisão e o modelo é treinado em todos os dados, não há uma avaliação realista da capacidade do modelo de fazer previsões precisas em novos dados, que é o objetivo final da maioria das aplicações.

load("C:/Users/elton/Downloads/dados_expectativa_renda (3).RData")
library(rsample)
library(dplyr)
library(ggplot2)
library(tidymodels)
library(tibble)
library(purrr)
library(patchwork)
tidymodels::tidymodels_prefer()

Quarta Questão

Considere o conjunto de dados de Expectativa de vida versus PIB per Capita. Considere a função g uma regressão polinomia. Utilizando o erro quadrático médio observado, sem fazer nenhuma estratégia de divisão dos dados, implemente um código em R para checar qual o melhor modelo. p = 1, …, 50

set.seed(2023)
p = 50
dados_exp <- dados_expectativa_renda[,-1]
colnames(dados_exp) <- c("y", "x")

for(i in 1:p){
  if(i > 1){
    temp <- cbind(temp, temp[,2]^i)
    colnames(temp) <- c("y", "x", paste0("x", 2:i))
    fit <- lm(y~. , data = temp)
    eqm[i] <- mean((temp$y - predict(fit, newdata = temp))^2)
    i = i + 1
  }
  else{
    fit <- lm(y~. , data = dados_exp)
    eqm <- mean((dados_exp$y - predict(fit, newdata = dados_exp))^2)
    temp <- dados_exp
  }
}
eqm1 <- data.frame("P" = 1:50, "EQM" = eqm)

g <- ggplot(eqm1, aes(P, EQM)) + 
  geom_line(linetype = 2, size = 0.4) + 
  geom_point(size = 2, aes(colour = -EQM)) +
  scale_fill_brewer(palette = 1) + 
  labs(x = "P", y = "EQM",
       title = "Avaliação do EQM",
       subtitle = "Sem repartir conjunto treino / teste")
g

Quinta Questão

Refaça o exercício anterior do polinômio, utilizando a estratégia de data splitting, em que divide-se o conjunto de dados em treinamento e teste. Utilize o conjunto de teste para calcular a estimativa do risco, usando o EQM

set.seed(2023)
p = 50
dados_exp <- dados_expectativa_renda[,-1]
colnames(dados_exp) <- c("y", "x")
dados_exp <- initial_split(dados_exp, prop = 3/4)
trainer <- training(dados_exp)
tester <- testing(dados_exp)

eqm2 = data.frame(P = 1:50, y = NA)
for(i in 1:p){
  if(i > 1){
    trainer <- cbind(trainer, trainer[,2]^i)
    colnames(trainer) <- c("y", "x", paste0("x", 2:i))
    fit <- lm(y~., trainer)
    
    ## Avaliando no conjunto de teste
    tester <- cbind(tester, tester[,2]^i)
    colnames(tester) <- c("y", "x", paste0("x", 2:i))
    eqm2[i,2] <- mean((tester[,1] - predict(fit, tester))^2)
  }
  else{
    fit <- lm(y~., trainer)
    eqm2[i,2] <- mean((tester[,1] - predict(fit, tester))^2)
  }
}

colnames(eqm2) <- c("P", "EQM")
g <- ggplot(eqm2, aes(P, EQM)) + 
  geom_line(linetype = 2, size = 0.4) + 
  geom_point(size = 2, aes(colour = -EQM)) +
  labs(x = "P", y = "EQM",
       title = "Avaliação do EQM",
       subtitle = "Repartindo conjunto treino/teste, sem validação cruzada") +
  xlim(c(0,18)) + ylim(c(10,130))

g

Sexta Questão

Ainda considerando o exercício do polinômio, implemente uma estratégia de leave-one-out cross-validation e selecione o melhor modelo minimizando a função de risco.

set.seed(2023)
p = 50
dados_exp <- dados_expectativa_renda[,-1]
colnames(dados_exp) <- c("y", "x")
dados_exp <- initial_split(dados_exp, prop = 3/4)
trainer <- training(dados_exp)
tester <- testing(dados_exp)

leave <- loo_cv(trainer)

results1 <- data.frame(P = NA, EQM = NA)
for(b in 1:dim(leave)[1]){
  eqm <- NULL
  
  for(i in 1:p){
    if(i > 1){
      temp_trainer <- leave$splits[[b]] %>% analysis()
      temp_tester <- leave$splits[[b]] %>% assessment()
      for(j in 2:i){
        temp_trainer <- cbind(temp_trainer, temp_trainer$x^j)
        temp_tester <- cbind(temp_tester, temp_tester$x^j)
        colnames(temp_trainer) <- c("y", "x", paste0("x", 2:j))
        colnames(temp_tester) <- c("y", "x", paste0("x", 2:j))
      }
      
      fit <- lm(y~., temp_trainer)
      eqm[i] <- as.numeric((temp_tester[,1] - predict(fit, temp_tester))^2)
    }
    else{
      temp_trainer <- leave$splits[[b]] %>% analysis()
      temp_tester <- leave$splits[[b]] %>% assessment()
      fit <- lm(y~., temp_trainer)
      eqm[i] <- as.numeric((temp_tester[,1] - predict(fit, newdata = temp_tester))^2)
    }
  }
  
  results1[b,1] <- which(eqm == min(eqm))[1]
  results1[b,2] <- min(eqm) 
}

Resposta:

Polinômio de Grau 7 apresentou o menor EQM, no valor de \(4.5994799^{-6}\).

Sétima Questão

Por fim, considerando o exercício do polinômio, rafaça-o utilizando um procedimento de k-fold cross-validation. Considere k=5. Dica: considere utilizar a biblioteca rsample.

set.seed(2023)
p = 50
k = 5
dados_exp <- dados_expectativa_renda[,-1]
colnames(dados_exp) <- c("y", "x")
dados_exp <- initial_split(dados_exp, prop = 3/4)
trainer <- training(dados_exp)
tester <- testing(dados_exp)

vfold <- vfold_cv(trainer, v = 5)

results2 <- data.frame(P = NA, EQM = NA)
for(b in 1:dim(vfold)[1]){
  eqm <- NULL
  
  for(i in 1:p){
    if(i > 1){
      temp_trainer <- vfold$splits[[b]] %>% analysis()
      temp_tester <- vfold$splits[[b]] %>% assessment()
      for(j in 2:i){
        temp_trainer <- cbind(temp_trainer, temp_trainer$x^j)
        temp_tester <- cbind(temp_tester, temp_tester$x^j)
        colnames(temp_trainer) <- c("y", "x", paste0("x", 2:j))
        colnames(temp_tester) <- c("y", "x", paste0("x", 2:j))
      }
      
      fit <- lm(y~., temp_trainer)
      eqm[i] <- mean((temp_tester[,1] - predict(fit, newdata = temp_tester))^2)
    }
    else{
      temp_trainer <- vfold$splits[[b]] %>% analysis()
      temp_tester <- vfold$splits[[b]] %>% assessment()
      fit <- lm(y~., temp_trainer)
      eqm[i] <- mean((temp_tester[,1] - predict(fit, newdata = temp_tester))^2)
    }
  }
  results2[b,1] <- which(eqm == min(eqm))[1]
  results2[b,2] <- min(eqm) 
}

Resposta :

Polinômio de Grau 10 apresentou o menor EQM, no valor de 19.8729033 para o método k-fold, k=5.

Oitava Questão

Utilizando os dados de vinho vermelho, faça uma pequena análise exploratória dos dados. No link do Kaggle você consegue uma explicação sobre o que significa cada uma das variáveis.

library(dplyr)
wine<-read.csv("C:/Users/elton/Desktop/winequality-red.csv")
wine<- wine%>%rename(c(acidez_fixa=fixed.acidity,acidez_volatil=volatile.acidity,acido_citrico=citric.acid,açucar_residual=residual.sugar,cloretos=chlorides,dioxido_enxofre_livre=free.sulfur.dioxide,dioxido_enxofre_total=total.sulfur.dioxide,densidade=density,sulfatos=sulphates,alcool=alcohol,qualidade=quality))
skimr::skim(wine)

── Data Summary ────────────────────────
                           Values
Name                       wine  
Number of rows             1599  
Number of columns          12    
_______________________          
Column type frequency:           
  numeric                  12    
________________________         
Group variables            None  

Nona Questão

obtenha o melhor modelo de regressão linear para modelar a qualidade do vinho, considerando: Método dos Mínimos Quadrados, Regressão Ridge, Regressão Lasso, Elastic Net. Selecione o melhor modelo para cada uma das classes e contrua uma tabela com o risco estimado. Ao fim construir quatro gráficos mostrando cada um dos ajustes.

library(rsample)
library(tidymodels)
library(workflows)
library(dplyr)
library(ggplot2)
library(tune)
library(tibble)
library(purrr)
library(patchwork)
library(glmnet)      
wine<-read.csv("C:/Users/elton/Desktop/winequality-red.csv")
colnames(wine) <- c(paste0("x", 1:11), "y")
wine <- initial_split(wine, prop = 3/4)

trainer <- training(wine)
tester <- testing(wine)

#Setting Engine
(modelo_mmo <- 
  linear_reg(penalty = 0, mixture = 0) %>% 
  set_mode("regression") %>% 
  set_engine("glmnet"))

Linear Regression Model Specification (regression)

Main Arguments:
  penalty = 0
  mixture = 0

Computational engine: glmnet 

(modelo_ridge <- 
  linear_reg(penalty = tune::tune(), mixture = 0) %>% 
  set_mode("regression") %>% 
  set_engine("glmnet"))

Linear Regression Model Specification (regression)

Main Arguments:
  penalty = tune::tune()
  mixture = 0

Computational engine: glmnet 

(modelo_lasso <- 
  parsnip::linear_reg(penalty = tune::tune(), mixture = 1) %>% 
  set_mode("regression") %>% 
  parsnip::set_engine("glmnet"))

Linear Regression Model Specification (regression)

Main Arguments:
  penalty = tune::tune()
  mixture = 1

Computational engine: glmnet 

(modelo_elastic <- 
  parsnip::linear_reg(penalty = tune::tune(), mixture = tune::tune()) %>% 
  set_mode("regression") %>% 
  parsnip::set_engine("glmnet"))

Linear Regression Model Specification (regression)

Main Arguments:
  penalty = tune::tune()
  mixture = tune::tune()

Computational engine: glmnet 

#workflow
(all_wf <- 
  workflow_set(
    preproc = list(y ~ . ),
    models = list(mmo = modelo_mmo, ridge = modelo_ridge, lasso = modelo_lasso, elastic = modelo_elastic), 
    cross = TRUE
  ))

#cross-validation
set.seed(2023)
(cv <-vfold_cv(trainer, v = 5L))

#  5-fold cross-validation 

#metrics
(metrica <- yardstick::metric_set(rmse))

#tunning
tunagem <- 
  all_wf %>%  
  workflow_map(
    seed = 2023, 
    verbose = TRUE,
    resamples = cv,
    grid = 50,
    metrics = metrica
  )
  

library(rsample)
library(purrr)
library(dplyr)
library(workflowsets)

modelos_rank <- tunagem %>% rank_results()

melhor_mmo <- 
  tunagem %>% 
  extract_workflow_set_result("formula_mmo") %>% 
  select_best("rmse")

melhor_ridge <- 
  tunagem %>% 
  extract_workflow_set_result("formula_ridge") %>% 
  select_best("rmse")

melhor_lasso <- 
  tunagem %>% 
  extract_workflow_set_result("formula_lasso") %>% 
  select_best("rmse")

melhor_elastic <- 
  tunagem %>% 
  extract_workflow_set_result("formula_elastic") %>% 
  select_best("rmse")

finalizando_mmo <- 
  tunagem %>% 
  extract_workflow("formula_mmo") %>% 
  finalize_workflow(melhor_mmo) %>% 
  last_fit(split = wine)

finalizando_ridge <- 
  tunagem %>% 
  extract_workflow("formula_ridge") %>% 
  finalize_workflow(melhor_ridge) %>% 
  last_fit(split = wine)

finalizando_lasso <- 
  tunagem %>% 
  extract_workflow("formula_lasso") %>% 
  finalize_workflow(melhor_lasso) %>% 
  last_fit(split = wine)

finalizando_elastic <- 
  tunagem %>% 
  extract_workflow("formula_elastic") %>% 
  finalize_workflow(melhor_elastic) %>% 
  last_fit(split = wine)

knitr::kable(data.frame(row.names = c("MMO", "Ridge", "Lasso", "Elastic"), 
                        "RMSE" = as.numeric(c((finalizando_mmo  %>%  collect_metrics())[1,3],
                                              (finalizando_ridge %>% collect_metrics())[1,3],
                                              (finalizando_lasso %>% collect_metrics())[1,3],
                                              (finalizando_elastic %>% collect_metrics())[1,3])))
             
             
)

	RMSE
MMO	0.6456993
Ridge	0.6456993
Lasso	0.6465983
Elastic	0.6455892

data_temp <- data.frame(ychapeu_mmo = (finalizando_mmo %>% collect_predictions())[2],
                        ychapeu_ridge = (finalizando_ridge %>% collect_predictions())[2],
                        ychapeu_lasso = (finalizando_lasso %>% collect_predictions())[2],
                        ychapeu_elastic = (finalizando_elastic %>% collect_predictions())[2],
                        y = (finalizando_elastic %>% collect_predictions())[4]
)

colnames(data_temp) <- c("ychapeu_mmo", "ychapeu_ridge", "ychapeu_lasso", "ychapeu_elastic", "y")
data_temp <- as_tibble(data_temp)


graph <- ggplot(data_temp, aes(x = ychapeu_mmo, y = y)) +
  geom_point() + geom_line(aes(y = ychapeu_mmo), colour = "red", size = 1) +
  labs(title = "Reta ajustada", subtitle = "y_ajustado vs y_real do modelo MMO")

graph

wine <- read.csv("winequality-red.csv")

colnames(wine) <- c(paste0("x", 1:11), "y")
#Data split
wine <- initial_split(wine, prop = 3/4)

trainer <- training(wine)
tester <- testing(wine)

features <- trainer[,-12] %>% as.matrix()
ytrainer <- trainer[,12] %>% as.matrix()
testfeatures <- tester[,-12] %>% as.matrix()
ytest <- tester[,12] %>% as.matrix()

#MMO

fit <- glmnet(x = features, y = ytrainer, alpha = 0, lambda = 0)
preditos <- predict(fit, newx = testfeatures)
eqm_mmo <- mean((preditos - ytest)^2)


#Ridge
cvridge <- cv.glmnet(x = features, y = ytrainer, alpha = 0, nfolds = 5)
fit2 <- glmnet(x = features, y = ytrainer, alpha = 0)
preditos_ridge <- predict(fit2, s = cvridge$lambda.1se, newx = testfeatures)
eqm_ridge <- mean((preditos_ridge - ytest)^2)

#Lasso
cvlasso <- cv.glmnet(x = features, y = ytrainer, alpha = 1, nfolds = 5)
fit3 <- glmnet(x = features, y = ytrainer, alpha = 1)
preditos_lasso <- predict(fit3, s = cvlasso$lambda.1se, newx = testfeatures)
eqm_lass <- mean((preditos_lasso - ytest)^2)

#Elastic-net
#Precisamos estipular o melhor alpha através de uma validaçao cruzada.
#Utilizando 5-folds.
eqm_elastic <- NULL
alpha_values <- seq(0.01, 0.999, length.out = 500)
for(a in alpha_values){
  cvelastic <- cv.glmnet(x = features, y = ytrainer, alpha = a, nfolds = 5)
  tempfit <- glmnet(x = features, y = ytrainer, alpha = a)
  preditos_elastic <- predict(tempfit, s = cvelastic$lambda.1se, newx = testfeatures)
  eqm_elastic <- c(eqm_elastic, 
                   mean((preditos_elastic - ytest)^2)) 
}
min(eqm_elastic)

[1] 0.4219499

alpha_values[which(eqm_elastic == min(eqm_elastic))]

[1] 0.9633246

knitr::kable(data.frame(row.names = c("MMO", "Ridge", "Lasso", "Elastic"),
                        "EQM" = c(eqm_mmo, eqm_ridge, eqm_lass, min(eqm_elastic)),
                        "RMSE" = sqrt(c(eqm_mmo, eqm_ridge, eqm_lass, min(eqm_elastic)))
                        )
)

	EQM	RMSE
MMO	0.4166706	0.6455003
Ridge	0.4395210	0.6629638
Lasso	0.4278124	0.6540737
Elastic	0.4219499	0.6495767

Decima Questão

Considere agora o conjunto de dados de despesas médicas. Refaça o mesmo exercício dos dados de vinho vermelho, em que aqui, o objetivo é prever a variável charges. Perceba que algumas variáveis são qualitativas, e portanto, você deverá transformá-las em dummy. Indique os melhores cenários dos quatro modelos e informe qual modelo você utilizaria. Explique! Dica: usando a função step_dummy() da biblioteca recipes, você poderá facilmente transformar variáveis qualitativas em numéricas.

library(dplyr)
library(tidymodels)
insurance <- read.csv("C:/Users/elton/Desktop/insurance.csv")
df <- recipe(charges ~., data = insurance) %>% 
  step_dummy(all_nominal(), -all_outcomes()) %>% 
  prep() %>% juice() 

knitr::kable(df %>% head(10), format = "html")

age	bmi	children	charges	sex_male	smoker_yes	region_northwest	region_southeast	region_southwest
19	27.900	0	16884.924	0	1	0	0	1
18	33.770	1	1725.552	1	0	0	1	0
28	33.000	3	4449.462	1	0	0	1	0
33	22.705	0	21984.471	1	0	1	0	0
32	28.880	0	3866.855	1	0	1	0	0
31	25.740	0	3756.622	0	0	0	1	0
46	33.440	1	8240.590	0	0	0	1	0
37	27.740	3	7281.506	0	0	1	0	0
37	29.830	2	6406.411	1	0	0	0	0
60	25.840	0	28923.137	0	0	1	0	0

df <- initial_split(df, prop = 3/4)

trainer <- training(df)
tester <- testing(df)

#Setting Engine
modelo_mmo <- 
  linear_reg(penalty = 0, mixture = 0) %>% 
  set_mode("regression") %>% 
  set_engine("glmnet")

modelo_ridge <- 
  linear_reg(penalty = tune::tune(), mixture = 0) %>% 
  set_mode("regression") %>% 
  set_engine("glmnet")

modelo_lasso <- 
  parsnip::linear_reg(penalty = tune::tune(), mixture = 1) %>% 
  set_mode("regression") %>% 
  parsnip::set_engine("glmnet")

modelo_elastic <- 
  parsnip::linear_reg(penalty = tune::tune(), mixture = tune::tune()) %>% 
  set_mode("regression") %>% 
  parsnip::set_engine("glmnet")


#workflow
all_wf <- 
  workflow_set(
    preproc = list(charges ~ . ),
    models = list(mmo = modelo_mmo, ridge = modelo_ridge, lasso = modelo_lasso, elastic = modelo_elastic), 
    cross = TRUE
  )

#cross-validation
set.seed(2023)
cv <- rsample::vfold_cv(trainer, v = 5L)

#metrics
metrica <- yardstick::metric_set(rmse)

#tunning
tunagem <- 
  all_wf %>%  
  workflow_map(
    seed = 2023, 
    verbose = TRUE,
    resamples = cv,
    grid = 50,
    metrics = metrica
  )

library(rsample)
library(dplyr)
library(ggplot2)
library(tidymodels)
library(tibble)
library(purrr)
library(patchwork)
library(workflowsets)
library(tune)
library(workflows)
tidymodels::tidymodels_prefer()
modelos_rank <- tunagem %>% rank_results()

melhor_mmo <- 
  tunagem %>% 
  extract_workflow_set_result("formula_mmo") %>% 
  select_best("rmse")

melhor_ridge <- 
  tunagem %>% 
  extract_workflow_set_result("formula_ridge") %>% 
  select_best("rmse")

melhor_lasso <- 
  tunagem %>% 
  extract_workflow_set_result("formula_lasso") %>% 
  select_best("rmse")

melhor_elastic <- 
  tunagem %>% 
  extract_workflow_set_result("formula_elastic") %>% 
  select_best("rmse")

finalizando_mmo <- 
  tunagem %>% 
  extract_workflow("formula_mmo") %>% 
  finalize_workflow(melhor_mmo) %>% 
  last_fit(split = df)

finalizando_ridge <- 
  tunagem %>% 
  extract_workflow("formula_ridge") %>% 
  finalize_workflow(melhor_ridge) %>% 
  last_fit(split = df)

finalizando_lasso <- 
  tunagem %>% 
  extract_workflow("formula_lasso") %>% 
  finalize_workflow(melhor_lasso) %>% 
  last_fit(split = df)

finalizando_elastic <- 
  tunagem %>% 
  extract_workflow("formula_elastic") %>% 
  finalize_workflow(melhor_elastic) %>% 
  last_fit(split = df)


knitr::kable(data.frame(row.names = c("MMO", "Ridge", "Lasso", "Elastic"), 
                        "RMSE" = as.numeric(c((finalizando_mmo  %>%  collect_metrics())[1,3],
                                              (finalizando_ridge %>% collect_metrics())[1,3],
                                              (finalizando_lasso %>% collect_metrics())[1,3],
                                              (finalizando_elastic %>% collect_metrics())[1,3])))
)

	RMSE
MMO	6032.497
Ridge	6032.497
Lasso	6046.101
Elastic	6046.310

data_temp <- data.frame(ychapeu_mmo = (finalizando_mmo %>% collect_predictions())[2],
                        ychapeu_ridge = (finalizando_ridge %>% collect_predictions())[2],
                        ychapeu_lasso = (finalizando_lasso %>% collect_predictions())[2],
                        ychapeu_elastic = (finalizando_elastic %>% collect_predictions())[2],
                        y = (finalizando_elastic %>% collect_predictions())[4]
)

colnames(data_temp) <- c("ychapeu_mmo", "ychapeu_ridge", "ychapeu_lasso", "ychapeu_elastic", "y")
data_temp <- as_tibble(data_temp)


g1 <- ggplot(data_temp, aes(x = ychapeu_mmo, y = y)) +
  geom_point() + geom_line(aes(y = ychapeu_mmo), colour = "#191970", size = 1) +
  labs(title = "Modelo MMO", subtitle = "y_ajustado vs y_real")

g2 <- ggplot(data_temp, aes(x = ychapeu_ridge, y = y)) +
  geom_point() + geom_line(aes(y = ychapeu_ridge), colour = "#4169E1", size = 1) +
  labs(title = "Modelo ridge", subtitle = "y_ajustado vs y_real")

g3 <- ggplot(data_temp, aes(x = ychapeu_lasso, y = y)) +
  geom_point() + geom_line(aes(y = ychapeu_lasso), colour = "orange", size = 1) +
  labs(title = "Modelo lasso", subtitle = "y_ajustado vs y_real")

g4 <- ggplot(data_temp, aes(x = ychapeu_elastic, y = y)) +
  geom_point() + geom_line(aes(y = ychapeu_elastic), colour = "red", size = 1) +
  labs(title = "Modelo elastic", subtitle = "y_ajustado vs y_real")


(g1 + g2) / (g3 + g4)

Resposta :

Escolheria o modelo de regressão MMO ou Modelo Ridge.