O mês que a Terra parou, coronavírus e Psicologia Complexa.

#?daisy()
#artigo base para criar cluster com variáveis quali e quanti - Gower, J. C. (1971) A general coefficient of similarity and some of its properties, Biometrics 27, 857–874.

rm(list=ls(all=TRUE))

dados_orig<- read_excel("dados.xlsx", col_types = c("text", 
    "text", "text", "text", "text", "text", 
    "text", "text", "text", "text", "text", 
    "text", "text", "text", "text","text", "numeric", 
    "text", "text", "text", "text", "numeric", 
    "text", "text", "text", "text", "text", 
    "text", "text", "text"))

dados_orig$q1 <-factor(dados_orig$q1, levels = c("1","2","3","4","5","6","7"), labels = c("1","2","3","4","5","6","7"))
dados_orig$q2 <-factor(dados_orig$q2, levels = c("1","2","3","4","5","6","7"), labels = c("1","2","3","4","5","6","7"))
dados_orig$q3 <-factor(dados_orig$q3, levels = c("1","2","3","4","5","6","7"), labels = c("1","2","3","4","5","6","7"))
dados_orig$q4 <-factor(dados_orig$q4, levels = c("1","2","3","4","5","6","7"), labels = c("1","2","3","4","5","6","7"))
dados_orig$q5 <-factor(dados_orig$q5, levels = c("1","2","3","4","5","6","7"), labels = c("1","2","3","4","5","6","7"))
dados_orig$q6 <-factor(dados_orig$q6, levels = c("1","2","3","4","5","6","7"), labels = c("1","2","3","4","5","6","7"))
dados_orig$q7 <-factor(dados_orig$q7, levels = c("1","2","3","4","5","6","7"), labels = c("1","2","3","4","5","6","7"))
dados_orig$q8 <-factor(dados_orig$q8, levels = c("1","2","3","4","5","6","7"), labels = c("1","2","3","4","5","6","7"))
dados_orig$q9 <-factor(dados_orig$q9, levels = c("1","2","3","4","5","6","7"), labels = c("1","2","3","4","5","6","7"))
dados_orig$q10 <-factor(dados_orig$q10, levels = c("1","2","3","4","5","6","7"), labels = c("1","2","3","4","5","6","7"))
dados_orig$q11 <-factor(dados_orig$q11, levels = c("1","2","3","4","5","6","7"), labels = c("1","2","3","4","5","6","7"))
dados_orig$q12 <-factor(dados_orig$q12, levels = c("1","2","3","4","5","6","7"), labels = c("1","2","3","4","5","6","7"))
#dados_orig$sexo <-factor(dados_orig$sexo, levels = c("Masculino","Feminino"), labels = c("1","2"))
dados_orig <-remove_missing(dados_orig[,c(1:30)])
#dados_orig$estado
dados = dados_orig[,c(1:12)]
rownames(dados) <- dados_orig$regiao_orig
#rownames(dados)

Descrição simples

#glimpse(dados)
# Summary 
#stats4::summary(dados)
#for (i in 1:12) {
#plot(dados_orig[,i], main=colnames(dados_orig)[i],
#ylab = "Frequência", col="steelblue", las = 2)
#}

likert_q1 <- likert(as.data.frame(dados), nlevels = 7)
likert.bar.plot(likert_q1,plot.percents=F,legend = "Legenda", low.color = "red", text.size=4) + ggtitle("") + labs( x = "Questões", y = "Porcentagem") + theme_minimal() + theme(legend.position = "bottom")

kable(summary(likert_q1)[,1:6],digits =2, row.names = F,longtable = TRUE, align=c('c', 'c','c','c','c', 'c', 'c'), booktabs = T, format.args = list(decimal.mark = ","))

Item	low	neutral	high	mean	sd
q4	0,86	0,29	98,86	6,67	0,71
q7	3,86	0,86	95,28	6,35	1,12
q11	5,72	3,00	91,27	6,13	1,31
q1	8,15	1,86	89,99	5,89	1,34
q9	7,01	8,15	84,84	5,67	1,28
q10	18,31	6,15	75,54	5,28	1,69
q8	17,31	8,87	73,82	4,99	1,61
q6	24,61	1,72	73,68	5,08	1,94
q2	26,75	2,00	71,24	5,17	2,18
q5	51,22	1,43	47,35	3,86	2,12
q12	44,35	22,75	32,90	3,59	2,04
q3	94,13	1,14	4,72	1,51	1,12

Método

1. Cálculo da distância de Gower. Artigo base para criar cluster com variáveis quali e quanti - Gower, J. C. (1971) A general coefficient of similarity and some of its properties, Biometrics 27, 857–874.

2. Escolha do algoritmo para formar os cluters. Foi empregado o algoritmo não hierárquico partitioning around medoids (PAM).  

3. Selecionar o número de clusters. Usaremos a largura da silhueta, uma métrica de validação interna que é uma medida agregada de como a observação é semelhante ao seu próprio cluster em comparação com o cluster vizinho mais próximo.

Cálculo das distâncias

# Escolha a métrica
gower_dist <- daisy(dados, metric = "gower")

#gower_dist <- dist(dados, method = "minkowski",p=1)

#gower
# Check attributes to ensure the correct methods are being used
# (I = interval',' N = nominal)
#gower_dist
summary(gower_dist)

243951 dissimilarities, summarized :
   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
 0.0000  0.5833  0.6667  0.6823  0.8333  1.0000 
Metric :  mixed ;  Types = N, N, N, N, N, N, N, N, N, N, N, N 
Number of objects : 699

head(gower_dist)

[1] 0.5833333 0.7500000 0.7500000 0.8333333 0.9166667 0.9166667

Verificar a mais similar e mais dissimilar

gower_mat <- as.matrix(gower_dist)
# Output most similar pair
dados[
  which(gower_mat == min(gower_mat[gower_mat != min(gower_mat)]),
        arr.ind = TRUE)[1, ], ]

dados[
  which(gower_mat == max(gower_mat[gower_mat != max(gower_mat)]),
        arr.ind = TRUE)[1, ], ]

Algoritmo não hierárquico PAM

Cálculo da silhueta - “Plot sihouette width (higher is better)”

# Calculate silhouette width for many k using PAM
#gower_dist - matriz com as distâncias
sil_width <- c(NA)
for(i in 2:5){
  pam_fit <- pam(gower_dist,
                 diss = TRUE,
                 k = i)
  sil_width[i] <- pam_fit$silinfo$avg.width
}
# Plot sihouette width (higher is better)
#plot(1:5, sil_width,
#     xlab = "Number of clusters",
#     ylab = "Silhouette Width")
#lines(1:5, sil_width)

# Outra função
# para o PAM
fviz_nbclust(gower_mat,pam,method = "silhouette") + theme_classic()

# para k-means
#fviz_nbclust(gower_mat,kmeans,method = "wss") + theme_classic()

Gráfico custer plot e medoids

k=2

pam_fit <- pam(gower_dist, diss = TRUE, k)
#pam_fit$clustering
#as.matrix(dados[pam_fit$medoids, ])
#print(pam_fit)
medoids=pam_fit$medoids

dados_orig %>% filter(regiao_orig==c(medoids))

grp = pam_fit$clustering
#  como fazer com as dist?  só lançar data como matriz de distâncias

fviz_cluster(list(data = gower_dist, cluster = grp),
#palette = c("orange", "green","red","brown", "blue"),
ellipse.type = "euclid", # Concentration ellipse
repel = TRUE, # Avoid label overplotting (slow)
show.clust.cent = T, ggtheme = theme_minimal()
)

Descrição dos grupos pelo algoritmo PAM

pam_results <- dados %>%
  dplyr::mutate(cluster = pam_fit$clustering) %>%
  group_by(cluster) %>%
  do(the_summary = summary(.))

pam_results$the_summary

[[1]]
 q1      q2      q3      q4      q5      q6      q7      q8      q9      q10     q11     q12    
 1: 13   1: 48   1:452   1:  3   1:126   1: 33   1: 10   1: 39   1:  9   1: 13   1: 13   1:164  
 2:  5   2: 16   2: 15   2:  2   2: 80   2: 19   2:  3   2: 21   2:  7   2: 37   2: 10   2: 73  
 3: 16   3: 25   3: 18   3:  1   3: 84   3: 38   3:  5   3: 30   3: 12   3: 21   3:  5   3: 33  
 4: 10   4:  6   4:  4   4:  2   4:  6   4:  4   4:  2   4: 46   4: 32   4: 24   4: 13   4:103  
 5: 68   5: 44   5:  8   5:  8   5: 92   5: 99   5: 27   5:128   5: 62   5: 81   5: 36   5: 48  
 6:138   6: 72   6:  2   6: 29   6: 31   6:115   6: 72   6:166   6:212   6:152   6:108   6: 30  
 7:254   7:293   7:  5   7:459   7: 85   7:196   7:385   7: 74   7:170   7:176   7:319   7: 53  
    cluster 
 Min.   :1  
 1st Qu.:1  
 Median :1  
 Mean   :1  
 3rd Qu.:1  
 Max.   :1  
            

[[2]]
 q1      q2     q3     q4      q5     q6     q7      q8     q9     q10    q11     q12   
 1:  2   1:36   1:62   1:  0   1: 3   1:25   1:  1   1: 2   1: 2   1: 3   1:  1   1: 6  
 2:  4   2:35   2:92   2:  0   2:31   2:32   2:  2   2:18   2: 7   2:31   2:  7   2:20  
 3: 17   3:27   3:19   3:  0   3:34   3:25   3:  6   3:11   3:12   3:23   3:  4   3:14  
 4:  3   4: 8   4: 4   4:  0   4: 4   4: 8   4:  4   4:16   4:25   4:19   4:  8   4:56  
 5: 44   5:24   5:10   5: 16   5:48   5:40   5: 33   5:54   5:48   5:38   5: 24   5:31  
 6:105   6:61   6: 6   6:114   6:53   6:61   6:109   6:85   6:96   6:73   6:110   6:45  
 7: 20   7: 4   7: 2   7: 65   7:22   7: 4   7: 40   7: 9   7: 5   7: 8   7: 41   7:23  
    cluster 
 Min.   :2  
 1st Qu.:2  
 Median :2  
 Mean   :2  
 3rd Qu.:2  
 Max.   :2  
            

dados_orig <- dados_orig %>% mutate(grupo = pam_fit$clustering ) 

Quantidade em cada grupo por região

kableExtra::kable(table(dados_orig$regiao, dados_orig$grupo))%>% kable_styling()

	1	2
CENTRO-OESTE	16	6
Não nasci no Brasil, porém morei grande parte da minha vida no Sudeste	0	1
NE	95	34
NORTE	12	2
SUDESTE	358	138
SUL	23	14

NA

Resultados por Estado

rownames(dados) <- dados_orig$estado_trab
## Descrição dos grupos pelo algoritmo PAM
pam_results <- dados %>%
  dplyr::mutate(cluster = pam_fit$clustering) %>%
  group_by(cluster) %>%
  do(the_summary = summary(.))

pam_results$the_summary

[[1]]
 q1      q2      q3      q4      q5      q6      q7      q8      q9      q10     q11     q12    
 1: 13   1: 48   1:452   1:  3   1:126   1: 33   1: 10   1: 39   1:  9   1: 13   1: 13   1:164  
 2:  5   2: 16   2: 15   2:  2   2: 80   2: 19   2:  3   2: 21   2:  7   2: 37   2: 10   2: 73  
 3: 16   3: 25   3: 18   3:  1   3: 84   3: 38   3:  5   3: 30   3: 12   3: 21   3:  5   3: 33  
 4: 10   4:  6   4:  4   4:  2   4:  6   4:  4   4:  2   4: 46   4: 32   4: 24   4: 13   4:103  
 5: 68   5: 44   5:  8   5:  8   5: 92   5: 99   5: 27   5:128   5: 62   5: 81   5: 36   5: 48  
 6:138   6: 72   6:  2   6: 29   6: 31   6:115   6: 72   6:166   6:212   6:152   6:108   6: 30  
 7:254   7:293   7:  5   7:459   7: 85   7:196   7:385   7: 74   7:170   7:176   7:319   7: 53  
    cluster 
 Min.   :1  
 1st Qu.:1  
 Median :1  
 Mean   :1  
 3rd Qu.:1  
 Max.   :1  
            

[[2]]
 q1      q2     q3     q4      q5     q6     q7      q8     q9     q10    q11     q12   
 1:  2   1:36   1:62   1:  0   1: 3   1:25   1:  1   1: 2   1: 2   1: 3   1:  1   1: 6  
 2:  4   2:35   2:92   2:  0   2:31   2:32   2:  2   2:18   2: 7   2:31   2:  7   2:20  
 3: 17   3:27   3:19   3:  0   3:34   3:25   3:  6   3:11   3:12   3:23   3:  4   3:14  
 4:  3   4: 8   4: 4   4:  0   4: 4   4: 8   4:  4   4:16   4:25   4:19   4:  8   4:56  
 5: 44   5:24   5:10   5: 16   5:48   5:40   5: 33   5:54   5:48   5:38   5: 24   5:31  
 6:105   6:61   6: 6   6:114   6:53   6:61   6:109   6:85   6:96   6:73   6:110   6:45  
 7: 20   7: 4   7: 2   7: 65   7:22   7: 4   7: 40   7: 9   7: 5   7: 8   7: 41   7:23  
    cluster 
 Min.   :2  
 1st Qu.:2  
 Median :2  
 Mean   :2  
 3rd Qu.:2  
 Max.   :2  
            

dados_orig <- dados_orig %>% mutate(grupo = pam_fit$clustering ) 
tab <- table(dados_orig$estado, dados_orig$grupo)
kableExtra::kable(tab) %>% kable_styling()

	1	2
Alagoas	2	0
Amapá	1	0
Amazonas	6	2
Aposentado	2	0
Bahia	55	12
Ceará	2	1
Desempregada	1	0
Distrito Federal	4	5
Espírito Santo	6	2
Goiás	3	1
Maranhão	5	1
Mato Grosso	1	2
Mato Grosso do Sul	2	0
Minas Gerais	14	10
Não Trabalho	14	7
Pará	3	2
Paraná	7	2
Pernambuco	2	1
Piauí	0	1
Rio de Janeiro	277	109
Rio Grande do Norte	2	0
Rio Grande do Sul	8	3
Rondônia	1	0
Roraima	3	0
Santa Catarina	4	1
São Paulo	65	25
Sergipe	1	6
Tocantins	13	2

#Gráfico de Colunas ou barras verticais por sexo
grafico_coluna=ggplot(dados_orig,aes(grupo,fill=estado)) + 
               geom_bar() +
               ggtitle("")+
               xlab("Grupos") +
               ylab("Freq.") 
             
ggplotly(grafico_coluna)

NA
NA