1 Objetivo e Prelúdio

Nesse exercício, nós vamos investigar o poder do algoritmo K-nn para detecção de câncer, usando dados abertos sobre características dos tumores e comparando entre diferentes tamanhos de vizinhança dos grupos, \(K_i\), para fazer a melhor predição de diagnóstico, se é Maligno ou Benigno.

setwd("/home/heitor/Área de Trabalho/R Projects/Análise Macro/Lab 5")
library(tidyverse)
library(plotly)
library(knitr)
library(kableExtra)
library(class)
library(gmodels)

2 Os Dados

Importei os dados, chamando-o de dt. Retirei a variável id. Transformei nossa variável alvo em fator. Por fim, listei e sumarizei as variáveis.

dt <- read_csv("wisc_bc_data.csv") %>% as_tibble()
dt$id <- NULL
dt$diagnosis <- factor(dt$diagnosis,
                       levels = c('B', 'M'),
                       labels = c('Benigno', 'Maligno'))
glimpse(dt)
## Rows: 569
## Columns: 31
## $ diagnosis         <fct> Benigno, Benigno, Benigno, Benigno, Benigno, Benigno…
## $ radius_mean       <dbl> 12.32, 10.60, 11.04, 11.28, 15.19, 11.57, 11.51, 13.…
## $ texture_mean      <dbl> 12.39, 18.95, 16.83, 13.39, 13.21, 19.04, 23.93, 23.…
## $ perimeter_mean    <dbl> 78.85, 69.28, 70.92, 73.00, 97.65, 74.20, 74.52, 91.…
## $ area_mean         <dbl> 464.1, 346.4, 373.2, 384.8, 711.8, 409.7, 403.5, 597…
## $ smoothness_mean   <dbl> 0.10280, 0.09688, 0.10770, 0.11640, 0.07963, 0.08546…
## $ compactness_mean  <dbl> 0.06981, 0.11470, 0.07804, 0.11360, 0.06934, 0.07722…
## $ concavity_mean    <dbl> 0.039870, 0.063870, 0.030460, 0.046350, 0.033930, 0.…
## $ points_mean       <dbl> 0.037000, 0.026420, 0.024800, 0.047960, 0.026570, 0.…
## $ symmetry_mean     <dbl> 0.1959, 0.1922, 0.1714, 0.1771, 0.1721, 0.2031, 0.13…
## $ dimension_mean    <dbl> 0.05955, 0.06491, 0.06340, 0.06072, 0.05544, 0.06267…
## $ radius_se         <dbl> 0.2360, 0.4505, 0.1967, 0.3384, 0.1783, 0.2864, 0.23…
## $ texture_se        <dbl> 0.6656, 1.1970, 1.3870, 1.3430, 0.4125, 1.4400, 2.90…
## $ perimeter_se      <dbl> 1.670, 3.430, 1.342, 1.851, 1.338, 2.206, 1.936, 3.9…
## $ area_se           <dbl> 17.43, 27.10, 13.54, 26.33, 17.72, 20.30, 16.97, 52.…
## $ smoothness_se     <dbl> 0.008045, 0.007470, 0.005158, 0.011270, 0.005012, 0.…
## $ compactness_se    <dbl> 0.011800, 0.035810, 0.009355, 0.034980, 0.014850, 0.…
## $ concavity_se      <dbl> 0.016830, 0.033540, 0.010560, 0.021870, 0.015510, 0.…
## $ points_se         <dbl> 0.012410, 0.013650, 0.007483, 0.019650, 0.009155, 0.…
## $ symmetry_se       <dbl> 0.01924, 0.03504, 0.01718, 0.01580, 0.01647, 0.01868…
## $ dimension_se      <dbl> 0.002248, 0.003318, 0.002198, 0.003442, 0.001767, 0.…
## $ radius_worst      <dbl> 13.50, 11.88, 12.41, 11.92, 16.20, 13.07, 12.48, 19.…
## $ texture_worst     <dbl> 15.64, 22.94, 26.44, 15.77, 15.73, 26.98, 37.16, 41.…
## $ perimeter_worst   <dbl> 86.97, 78.28, 79.93, 76.53, 104.50, 86.43, 82.28, 12…
## $ area_worst        <dbl> 549.1, 424.8, 471.4, 434.0, 819.1, 520.5, 474.2, 115…
## $ smoothness_worst  <dbl> 0.1385, 0.1213, 0.1369, 0.1367, 0.1126, 0.1249, 0.12…
## $ compactness_worst <dbl> 0.12660, 0.25150, 0.14820, 0.18220, 0.17370, 0.19370…
## $ concavity_worst   <dbl> 0.124200, 0.191600, 0.106700, 0.086690, 0.136200, 0.…
## $ points_worst      <dbl> 0.09391, 0.07926, 0.07431, 0.08611, 0.08178, 0.06664…
## $ symmetry_worst    <dbl> 0.2827, 0.2940, 0.2998, 0.2102, 0.2487, 0.3035, 0.21…
## $ dimension_worst   <dbl> 0.06771, 0.07587, 0.07881, 0.06784, 0.06766, 0.08284…

Fiz uma nova base de dados escalonando positivamente as variáveis numéricas em relação à maior diferença entre elas. Para isso, apliquei a função scale1 em cada coluna numérica, criando a nova base, dt1.

scale1    <- function(x){ return( (x-min(x)) / (max(x)-min(x)) ) }
dt1       <- as.data.frame(lapply(dt[2:31],scale1)) %>% as_tibble()
dt1$diagn <- dt$diagnosis

3 Divisão de Amostras

Escolhi, com aleatoriedade fixa em \(666\) (para fins de replicação), uma amostra de treino de 80%, sobre o qual o modelo será feito. Portanto, o teste será feito na amostra restante, 20%.

set.seed(666)
train <- dt1 %>% sample_frac(.,0.8)
sid   <- as.numeric(rownames(train))
test  <- dt1[-sid,]
remove(sid)

4 Modelo e Comparações entre K’s

Rodarei um primeiro modelo seguindo a regra de bolso: \[k = \sqrt(numero \ \ de \ \ observacoes \ \ do \ \ treino ) = \sqrt(455) \approx 21\]
As amostras de Treino e Teste devem conter apenas variáveis numéricas, por isso, especifiquei que treino e teste devem ser realizados da coluna 1 até a 30, e.g., tain[1:30]. Em cl = é que colocarmos a variável-fator, que queremos prever.

4.1 Primeiro Modelo

knn0 <- knn(train = train[1:30],
            test  = test[1:30],
            cl    = train$diagn,
            k     = 21)

Para fins de comparação, criei um novo banco de dados chamado rslt0; comparei em t0 a acurácia do \(k(21)-nn\) e salvei três resultados interessantes: a acurácia global (Acc0), o falso benigno (F_Ben0) e o falso maligno (F_Mal0):

rslt0  <- data.frame(Original  = c(test$diagn),
                       Predito = c(knn0))
t0     <- table(rslt0$Original, rslt0$Predito)
Acc0   <- sum(diag(t0))/sum(t0)
F_Ben0 <- sum(t0[2,1])/sum(t0[,1])
F_Mal0 <- sum(t0[1,2])/sum(t0[,2])
t0 %>% kable(booktabs = TRUE,
             escape   = FALSE,
             digits   = 4,
             caption  = 'Resultado das predições do primeiro modelo') %>%
  kable_styling(latex_options = c("striped", "hold_position"),
                position      = "center",
                full_width    = F,
                bootstrap_options = c("striped", "hover", "condensed", "responsive")) %>%
  column_spec(1, bold = T) %>%
  row_spec(0,    bold = T)
Resultado das predições do primeiro modelo
Benigno Maligno
Benigno 70 0
Maligno 4 40 
CrossTable(x = test$diagn, 
           y = knn0, 
           prop.chisq = F)
## 
##  
##    Cell Contents
## |-------------------------|
## |                       N |
## |           N / Row Total |
## |           N / Col Total |
## |         N / Table Total |
## |-------------------------|
## 
##  
## Total Observations in Table:  114 
## 
##  
##              | knn0 
##   test$diagn |   Benigno |   Maligno | Row Total | 
## -------------|-----------|-----------|-----------|
##      Benigno |        70 |         0 |        70 | 
##              |     1.000 |     0.000 |     0.614 | 
##              |     0.946 |     0.000 |           | 
##              |     0.614 |     0.000 |           | 
## -------------|-----------|-----------|-----------|
##      Maligno |         4 |        40 |        44 | 
##              |     0.091 |     0.909 |     0.386 | 
##              |     0.054 |     1.000 |           | 
##              |     0.035 |     0.351 |           | 
## -------------|-----------|-----------|-----------|
## Column Total |        74 |        40 |       114 | 
##              |     0.649 |     0.351 |           | 
## -------------|-----------|-----------|-----------|
## 
##

Salvarei esse resultado e os demais que se seguirão em Resultados como se segue:

Resultados <- data.frame( K             = 21,
                          Acurácia      = Acc0,
                          Falso_Benigno = F_Ben0,
                          Falso_Maligno = F_Mal0)

4.2 Comparando os Demais K

Farei um loop de 1 a 30 onde cada índice será o número de vizinhos, \(k=(1:30)\). Em cada \(i\), o loop fará um modelo k-nn; salvará temporariamente os diagnósticos preditos vis-a-vis os diagnósticos originais em rslt; calcularei e salvarei temporariamente os três resultados que quero; farei uma nova linha com os três resultados e a adicionarei em Resultados:

Ki <- 1:30

for (i in Ki) {
  modelo_KNN <- knn(train = train[1:30],
                     test = test[1:30],
                       cl = train$diagn,
                        k = i)
  
  rslt  <- data.frame(Original = c(test$diagn),
                      Predito = c(modelo_KNN))
  
  tab   <- table(rslt$Original, rslt$Predito)
  
  Acc   <- sum(diag(tab))/sum(tab)
  F_Ben <- sum(tab[2,1])/sum(tab[,1])
  F_Mal <- sum(tab[1,2])/sum(tab[,2])
  
  nova_linha <- data.frame(i, Acc, F_Ben, F_Mal)
  names(nova_linha) <- c('K', 'Acurácia', 'Falso_Benigno', 'Falso_Maligno')
  
  Resultados <- rbind(Resultados, nova_linha)
}

Visualizando os Resultados:

Resultados %>% 
  kable(#format   = "latex",
         booktabs = TRUE,
         escape   = FALSE,
         digits   = 4,
         caption  = 'Taxa de Acurácia e Falso Resultado Por K Vizinhos Próximos') %>% 
  kable_styling(latex_options = c("striped", "hold_position"),
                position      = "center",
                full_width    = F,
                bootstrap_options = c("striped", "hover", "condensed", "responsive")) %>%
  column_spec(1, bold = T) %>%
  row_spec(0,    bold = T) %>% 
  footnote( general           = "Elaboração Própria.",
            general_title     = "Fonte:",
            footnote_as_chunk = T,
            title_format      = c("italic"))
Taxa de Acurácia e Falso Resultado Por K Vizinhos Próximos
K Acurácia Falso_Benigno Falso_Maligno
21 0.9649 0.0541 0.0000
1 1.0000 0.0000 0.0000
2 0.9737 0.0282 0.0233
3 0.9737 0.0282 0.0233
4 0.9737 0.0282 0.0233
5 0.9737 0.0282 0.0233
6 0.9737 0.0282 0.0233
7 0.9737 0.0282 0.0233
8 0.9825 0.0278 0.0000
9 0.9825 0.0278 0.0000
10 0.9825 0.0278 0.0000
11 0.9737 0.0411 0.0000
12 0.9737 0.0411 0.0000
13 0.9649 0.0541 0.0000
14 0.9737 0.0411 0.0000
15 0.9825 0.0278 0.0000
16 0.9737 0.0411 0.0000
17 0.9737 0.0411 0.0000
18 0.9825 0.0278 0.0000
19 0.9737 0.0411 0.0000
20 0.9561 0.0667 0.0000
21 0.9649 0.0541 0.0000
22 0.9737 0.0411 0.0000
23 0.9649 0.0541 0.0000
24 0.9649 0.0541 0.0000
25 0.9649 0.0541 0.0000
26 0.9649 0.0541 0.0000
27 0.9649 0.0541 0.0000
28 0.9649 0.0541 0.0000
29 0.9649 0.0541 0.0000
30 0.9649 0.0541 0.0000
Fonte: Elaboração Própria. 
gg1 <- Resultados %>% slice(-1) %>% 
  ggplot(aes(x=K, y=Falso_Benigno)) +
  geom_line(size = .8, color='violet')
ggplotly(gg1)
gg2 <- Resultados %>%
  slice(-1) %>% # retira a primeira linha, do modelo knn0
  mutate(desv_m = Acurácia - mean(Acurácia)) %>% 
  ggplot(aes(x=K, y=desv_m)) +
  geom_col(width=.5, color='turquoise1') 
ggplotly(gg2)

Por fim, escolheremos os modelos com melhor acurácia:

Resultados %>% slice_max(Resultados$Acurácia) %>% 
  kable(#format   = "latex",
         booktabs = TRUE,
         escape   = FALSE,
         digits   = 4,
         caption  = 'Taxa(s) Máxima(s) de Acurácia Por K Vizinhos Próximos') %>% 
  kable_styling(latex_options = c("striped", "hold_position"),
                position      = "center",
                full_width    = F,
                bootstrap_options = c("striped", "hover", "condensed", "responsive")) %>%
  column_spec(1, bold = T) %>%
  row_spec(0,    bold = T) %>% 
  footnote( general           = "Elaboração Própria.",
            general_title     = "Fonte:",
            footnote_as_chunk = T,
            title_format      = c("italic"))
Taxa(s) Máxima(s) de Acurácia Por K Vizinhos Próximos
K Acurácia Falso_Benigno Falso_Maligno
1 1 0 0
Fonte: Elaboração Própria.