범주형 데이터에 대한 계층적 군집분석접근

데이터 미리보기

6개의 변수를 만들고, 부상자 및 사망자수에 따른 fatal_level을 적용할 예정입니다.

library(knitr)

## Warning: package 'knitr' was built under R version 3.5.3

library(kableExtra)

## Warning: package 'kableExtra' was built under R version 3.5.3

carAccident %>% 
  head() %>%
  kable() %>% 
  kable_styling(bootstrap_options = "striped", full_width = F)

fatal_level & carAccidentType 변수 추가하기

carAccident <- carAccident %>% 
  mutate(
    fatal_level = case_when(
      injured == 0 & dead == 0 ~ "상해없음", 
      injured <= 2 & dead == 0 ~ "경상해", 
      injured > 2  & dead == 0 ~ "중상해", 
      dead > 0 ~ "치명적상해"
    )
  ) %>% 
  mutate_if(is.character, as.factor)

carAccident$carAccidentType <- sample(c("car_car", "car_human", "car_only"), 
                              size = 567, 
                              replace = TRUE, 
                              prob = c(0.5, 0.3, 0.2)) %>% factor()

carAccident %>% 
  head() %>%
  kable() %>% 
  kable_styling(bootstrap_options = "striped", full_width = F)

• 위 데이터 전체 관측치는 567개이며, 변수의 개수는 9개입니다. 각각의 데이터에 대한 성격은 아래에서 확인하시기를 바랍니다.

glimpse(carAccident)

## Observations: 567
## Variables: 9
## $ ids             <fct> 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14,...
## $ weeks           <ord> 수요일, 목요일, 수요일, 수요일, 수요일, 수요일, 월요일, 수요일, 화요일, 월...
## $ city            <fct> 경기, 대전, 경기, 서울, 부산, 강원, 대전, 강원, 부산, 대전, 강원, 강원...
## $ dpart           <fct> 경영, 영업, 영업, 서비스, 경영, 경영, 개발, 경영, 분석, 영업, 경영, 디...
## $ carType         <fct> 승용차, 승용차, 승용차, 승용차, 오토바이, 승용차, 트럭, 경차, 오토바이, 오...
## $ injured         <dbl> 0, 0, 4, 1, 4, 0, 0, 3, 3, 3, 4, 1, 3, 4, 1, 3...
## $ dead            <dbl> 1, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 3, 0, 0, 0...
## $ fatal_level     <fct> 치명적상해, 치명적상해, 중상해, 경상해, 중상해, 상해없음, 치명적상해, 중상해,...
## $ carAccidentType <fct> car_only, car_human, car_car, car_human, car_h...

실무에서는 최초 데이터는 매우 지저분하게 되어 있을 가능성이 큽니다. 바로 모델링을 진행하기에 앞서서, 데이터 전처리 및 고객사에 맞는 데이터 필터링이 매우 중요합니다. 제 경우에는 전체 2만개의 데이터 중, 실제로 고객사가 필요한 데이터는 600개가 되지 않았습니다. 나머지 데이터는 사실상 큰 의미부여를 하기 힘든 데이터였던 것으로 기억합니다. 이러한 부분은 보통 고객사의 요구 수준에 맞추어 진행하게 됩니다.

Aggolomerative Hierachical Clustering 알고리즘

# 여기에서는 일반적으로 사용되는 Complete Linkages 활용합니다. 
agg_clust_c <- hclust(gower_distance, method = "complete")
plot(agg_clust_c, main = "Agglomerative, complete linkages")

Divisive Hierachical Clustering 알고리즘

divisive_clust <- diana(as.matrix(gower_distance), 
                  diss = TRUE, keep.diss = TRUE)
plot(divisive_clust, main = "Divisive")

Visualisation

sil_width <- c(NA)
for(i in 2:8) {
  pam_fit <- pam(gower_distance, diss = TRUE, k = i)
  sil_width[i] <- pam_fit$silinfo$avg.width
}

plot(1:8, sil_width,
     xlab = "Number of clusters",
     ylab = "Silhouette Width")
lines(1:8, sil_width)

Summary

k <- 2
pam_fit <- pam(gower_distance, diss = TRUE, k)
pam_results <- carAccident %>%
  mutate(cluster = pam_fit$clustering) %>%
  group_by(cluster) %>%
  do(the_summary = summary(.))

pam_results$the_summary

## [[1]]
##       ids         weeks      city       dpart        carType   
##  1      :  1   월요일:55   강원:38   개발  :18   경차    : 47  
##  2      :  1   화요일:41   경기:57   경영  :57   승용차  :119  
##  4      :  1   수요일:65   대전:12   기획  :37   오토바이: 14  
##  5      :  1   목요일:17   부산:24   디자인:24   트럭    : 24  
##  6      :  1   금요일:26   서울:73   분석  : 9                 
##  7      :  1                         서비스:32                 
##  (Other):198                         영업  :27                 
##     injured           dead            fatal_level   carAccidentType
##  Min.   :0.000   Min.   :0.0000   경상해    : 26   car_car  : 46   
##  1st Qu.:1.000   1st Qu.:0.0000   상해없음  : 27   car_human:111   
##  Median :2.000   Median :1.0000   중상해    : 28   car_only : 47   
##  Mean   :2.181   Mean   :0.9167   치명적상해:123                   
##  3rd Qu.:4.000   3rd Qu.:1.0000                                    
##  Max.   :9.000   Max.   :3.0000                                    
##                                                                    
##     cluster 
##  Min.   :1  
##  1st Qu.:1  
##  Median :1  
##  Mean   :1  
##  3rd Qu.:1  
##  Max.   :1  
##             
## 
## [[2]]
##       ids         weeks       city        dpart         carType   
##  3      :  1   월요일:108   강원:141   개발  : 28   경차    :183  
##  8      :  1   화요일: 69   경기: 81   경영  : 49   승용차  :108  
##  9      :  1   수요일:105   대전: 35   기획  : 59   오토바이: 41  
##  10     :  1   목요일: 34   부산: 47   디자인: 32   트럭    : 31  
##  11     :  1   금요일: 47   서울: 59   분석  : 19                 
##  12     :  1                           서비스: 63                 
##  (Other):357                           영업  :113                 
##     injured           dead            fatal_level   carAccidentType
##  Min.   : 0.00   Min.   :0.0000   경상해    : 47   car_car  :224   
##  1st Qu.: 1.00   1st Qu.:0.0000   상해없음  : 61   car_human: 61   
##  Median : 3.00   Median :0.0000   중상해    :218   car_only : 78   
##  Mean   : 2.78   Mean   :0.1405   치명적상해: 37                   
##  3rd Qu.: 4.00   3rd Qu.:0.0000                                    
##  Max.   :10.00   Max.   :3.0000                                    
##                                                                    
##     cluster 
##  Min.   :2  
##  1st Qu.:2  
##  Median :2  
##  Mean   :2  
##  3rd Qu.:2  
##  Max.   :2  
## 

library(Rtsne)

## Warning: package 'Rtsne' was built under R version 3.5.3

tsne_obj <- Rtsne(gower_distance, is_distance = TRUE)
tsne_data <- tsne_obj$Y %>%
  data.frame() %>%
  setNames(c("X", "Y")) %>%
  mutate(cluster = factor(pam_fit$clustering))
ggplot(aes(x = X, y = Y), data = tsne_data) +
  geom_point(aes(color = cluster))

(계속 진행중)