2.1 데이터 가져오기

TV 홍카콜라와 유시민의 알릴레오에서 채널 고유값을 가져온다. 이를 데이터프레임으로 만들고 채널고유값을 tuber 팩키지 get_all_channel_video_stats() 함수에 넣어 유튜브 채널 트래픽 데이터를 불러와서 저장시킨다.

library(tuber)
library(tidyverse)

yt_oauth(yt_app_id, yt_app_pw)

hy_channel <- list("TV홍카콜라" = "UCfmicRK2-WdZMVQDrfcitLA",
                   "알릴레오"   = "UCJS9VvReVkplPwCIbxnbsjQ")

# 1. 데이터 가져오기 -----
## 1.1 유튜브 채널 통계 -----
hy_channel_tbl <- tibble(channel = hy_channel %>% unlist, channel_name = names(hy_channel), stat =NA)
 
hy_video_stat_tbl <- map_df(hy_channel_tbl$channel, get_all_channel_video_stats)

hy_channel_stat_tbl <- hy_channel_tbl %>% 
  mutate(stat = map(hy_channel_tbl$channel, get_all_channel_video_stats)) 

hy_channel_stat_tbl %>% write_rds("data/hy_channel_stat_tbl.rds")

2.2 채널 트래픽 비교

TV홍카콜라 첫방송이 “2018-12-18” “이 남자, 돌아온다.”라는 티져를 시작으로 본격적으로 방송이 되어 알릴레오와 최대한 유사한 비교 조건을 만든다. “2019-02-01” 시점기준으로 얼추 유사한 동영상 갯수임을 확인할 수 있다.

library(lubridate)

hy_channel_stat_tbl <- read_rds("data/hy_channel_stat_tbl.rds")

hy_channel_stat_tbl

# A tibble: 2 x 3
  channel                  channel_name stat                  
  <chr>                    <chr>        <list>                
1 UCfmicRK2-WdZMVQDrfcitLA TV홍카콜라   <data.frame [79 x 9]> 
2 UCJS9VvReVkplPwCIbxnbsjQ 알릴레오     <data.frame [274 x 9]>

hy_channel_stat_df <- hy_channel_stat_tbl %>% 
  unnest(stat) %>% 
  mutate_at(vars(contains("Count")), as.integer)

hy_channel_stat_df %>% 
  mutate(date = ymd_hms(publication_date)) %>% 
  filter(date >= ymd("2018-01-19")) %>% 
  group_by(channel_name) %>% 
  summarise(video_count         = n(),
            max_viewCount       = max(viewCount, na.rm = TRUE),
            mean_viewCount      = mean(viewCount, na.rm = TRUE),
            median_viewCount    = median(viewCount, na.rm = TRUE),
            max_likeCount       = max(likeCount, na.rm = TRUE),
            mean_likeCount      = mean(likeCount, na.rm = TRUE),
            median_likeCount    = median(likeCount, na.rm = TRUE),
            max_dislikeCount    = max(dislikeCount, na.rm = TRUE),
            mean_dislikeCount   = mean(dislikeCount, na.rm = TRUE),
            median_dislikeCount = median(dislikeCount, na.rm = TRUE),
            max_commentCount    = max(commentCount, na.rm = TRUE),
            mean_commentCount   = mean(commentCount, na.rm = TRUE),
            median_commentCount = median(commentCount, na.rm = TRUE)) %>% 
  gather(metric, value, -channel_name) %>% 
  spread(channel_name, value) %>% 
  DT::datatable() %>% 
    DT::formatRound(c(2:3), digits = 0)

2.3 조회수 → 좋아요 전환

조회수 대비 좋아요 전환은 “TV홍카콜라”가 “알릴레오”에 비해 더 높은 것으로 나타나지만, 파괴력면에서는 “알릴레오”가 “TV홍카콜라”를 넘어서는 것으로 파악된다.

library(extrafont)
loadfonts()

hy_channel_stat_df %>% 
  ggplot(aes(x=viewCount, y=likeCount, color=channel_name)) +
    geom_point() +
    geom_smooth() +
    scale_x_sqrt(labels = scales::comma) +
    scale_y_sqrt(labels = scales::comma) +
    labs(x="조회수", y="좋아요수", title="조회수와 좋아요수 관계", 
         subtitle="유튜브 TV홍카콜라와 알릴레오 채널", color="유튜브 채널명") +
    theme_minimal(base_family = "NanumGothic") +
    theme(legend.position = "right")

2.4 유튜브 채널별 동영상 상세

조회수 대비 좋아요 전환은 “TV홍카콜라”가 “알릴레오”에 비해 더 높은 것으로 나타나지만, 파괴력면에서는 “알릴레오”가 “TV홍카콜라”를 넘어서는 것으로 파악된다.

hy_channel_stat_df %>% 
  mutate(publication_date = as.Date(publication_date)) %>% 
  mutate(id = paste0("<a href=https://www.youtube.com/watch?v=", id,">", id,"</a>")) %>% 
  arrange(desc(viewCount)) %>% 
  select(-channel, `채널`=channel_name, `동영상`=id, date=publication_date, -favoriteCount, -url) %>% 
  DT::datatable(escape=FALSE, options = list(scrollX=TRUE, autoWidth = TRUE,
                                         columnDefs = list(list(width = '300px', targets = c(3))))) %>% 
  DT::formatCurrency(c("viewCount", "likeCount", "dislikeCount", "commentCount"), currency = "", digits = 0) 

2.5 유튜브 채널 댓글 데이터

tuber 팩키지 get_all_comments() 함수를 사용해서 댓글을 가져온다. 문제는 댓글이 없는 경우 오류가 생기기 때문에 possibly()를 사용해서 오류가 나더라도 후속작업을 진행시킨다.

library(tictoc)

# 1. 함수형 프로그래밍 동영상 댓글 -----
get_all_comments_possibly <- possibly(get_all_comments, otherwise = NULL)

tic()
hy_video_comment_list <- map(hy_video_stat_tbl$id, get_all_comments_possibly)
toc()

# 1641.46 sec elapsed

hy_video_comment_df <- hy_video_stat_tbl %>% 
  mutate(comment = hy_video_comment_list)

hy_video_comment_list %>% 
  write_rds("data/hy_video_comment_list.rds")

2.6 댓글 데이터 자료형

트래픽 데이터프레임과 댓글 데이터프레임을 두 유튜브 채널별로 결합시켜 예측모형 개발에 필요한 데이터구조를 만들어낸다.

hy_video_comment_list <- read_rds("data/hy_video_comment_list.rds")

hy_channel_stat_df <- hy_channel_stat_tbl %>% 
  unnest(stat)

hy_channel_stat_comment_df <- hy_channel_stat_df %>% 
  mutate(comment = hy_video_comment_list)

hy_channel_stat_comment_df %>% 
  select(channel_name, title, viewCount, comment)

# A tibble: 353 x 4
   channel_name title                           viewCount comment          
   <chr>        <chr>                           <chr>     <list>           
 1 TV홍카콜라   [홍준표의 뉴스콕] 너 이름이 뭐니?~ 114999    <data.frame [440~
 2 TV홍카콜라   [홍준표의 뉴스콕] 文정부, 사라지는 일자리~ 178818    <data.frame [1,9~
 3 TV홍카콜라   [홍준표의 뉴스콕] 누가 뭐라 해도 남북경협 박차~ 74626     <data.frame [771~
 4 TV홍카콜라   [홍준표의 뉴스콕] 효자산업 반도체의 고난~ 54249     <data.frame [522~
 5 TV홍카콜라   [홍준표] 홍준표의 재구성 - 남정욱교수~ 17246     <data.frame [292~
 6 TV홍카콜라   [홍준표의 뉴스콕] 목이 메여 불러보는..~ 105534    <data.frame [683~
 7 TV홍카콜라   [홍준표] 당랑의꿈               49529     <data.frame [778~
 8 TV홍카콜라   [TV홍카콜라 LIVE On-Air] 이벤트 라이브 -~ 86880     <data.frame [689~
 9 TV홍카콜라   [홍준표의 뉴스콕] 중국의 우리하늘 우리어장 침범~ 82345     <data.frame [789~
10 TV홍카콜라   [공식예고] 내 나라 살리는 길, 함께 갑시다 - 홍준~ 215559    <data.frame [2,5~
# ... with 343 more rows

3.1 예측모형 데이터

예측모형 구축을 위해 표본 구성을 맞춘다. 즉, 클래스 불균형을 맞추고 시점도 맞추기 위해서 “2018-01-19” 이후로 TV홍카콜라와 알릴레오를 동영상 구성을 맞추고 publication_date에서 날짜 feature만 일부 추출하여 Basetable 모형데이터를 준비시킨다.

hy_rect_basetable <- hy_channel_stat_comment_df %>% 
  mutate(date = ymd_hms(publication_date)) %>% 
  filter(date >= ymd("2018-01-19")) %>% 
  select(channel_name, contains("Count"), date=publication_date) 

hy_rect_basetable <- hy_rect_basetable %>% 
  mutate(y = ifelse(channel_name == "TV홍카콜라", 0L, 1L) %>% factor(., levels=c(0, 1), labels = c("홍카콜라", "알릴레오") )) %>% 
    mutate_at(vars(contains("Count")), as.integer) %>% 
    mutate(date = ymd_hms(date)) %>% 
    mutate(month = month(date) %>% as.factor,
           week = weekdays(date) %>%  as.factor) %>% 
    select(y, contains("Count"), month, week) %>% 
    mutate(month = case_when(month == 1 ~ "1월",
                             month ==12 ~ "12월",
                             TRUE ~ "기타")) %>% 
    mutate(commentCount = ifelse(is.na(commentCount), 0, commentCount))
  
hy_rect_basetable

# A tibble: 165 x 8
   y     viewCount likeCount dislikeCount favoriteCount commentCount month
   <fct>     <int>     <int>        <int>         <int>        <dbl> <chr>
 1 홍카콜라~    114999     10659          392             1          460 12월 
 2 홍카콜라~    178818     23870          528             1         2146 1월  
 3 홍카콜라~     74626     11163          108             1          851 1월  
 4 홍카콜라~     54249      8236           71             1          596 1월  
 5 홍카콜라~     17246      2681           20             1          318 1월  
 6 홍카콜라~    105534     10641          525             1          720 12월 
 7 홍카콜라~     49529      5328           88             1          901 1월  
 8 홍카콜라~     86880      8564          519             1          671 12월 
 9 홍카콜라~     82345     11731          127             1          834 1월  
10 홍카콜라~    215559     13272         2095             1         2896 12월 
# ... with 155 more rows, and 1 more variable: week <fct>

3.2 예측모형 개발 ¹

caret 팩키지를 사용해서 예측모형을 개발하고 성능을 파악한다.

library(caret)

# 2. 예측모형 -----
## 2.1. 훈련/시험 데이터 분할 ------

y_index <- createDataPartition(hy_rect_basetable$y, times =1, p=0.7, list=FALSE)

train_df <- hy_rect_basetable[y_index, ]
test_df  <- hy_rect_basetable[-y_index, ]

## 2.2. 모형 개발/검증 데이터셋 준비 ------

cv_folds <- createMultiFolds(train_df$y, k = 10, times = 3)

cv_cntrl <- trainControl(method = "repeatedcv", number = 10,
                        repeats = 3, index = cv_folds)


## 2.2. 모형 개발/검증 데이터셋 준비 ------

library(doSNOW)
library(tictoc)
# 실행시간
tic()

cl <- makeCluster(4, type = "SOCK")
registerDoSNOW(cl)

hy_rpart <- train(y ~ ., data = train_df, 
                   method = "rpart", 
                   trControl = cv_cntrl, 
                   preProcess = c("nzv", "center", "scale", "spatialSign"),
                   tuneLength = 7)

hy_glm   <- train(y ~ ., data = train_df, 
                   method = "glm",
                   family = "binomial",
                   trControl = cv_cntrl, 
                   preProcess = c("nzv", "center", "scale", "spatialSign"),
                   tuneLength = 7)

hy_rf    <- train(y ~ ., data = train_df, 
                  method = "rf",
                  trControl = cv_cntrl, 
                  preProcess = c("nzv", "center", "scale", "spatialSign"),
                  tuneLength = 7,
                  importance = TRUE)

stopCluster(cl)
toc()

9.12 sec elapsed

# 4. 모형 비교평가-----
model_list <- list(
  rpart = hy_rpart,
  glm   = hy_glm,
  rf    = hy_rf
)

resamps <- resamples(model_list)
summary(resamps)

Call:
summary.resamples(object = resamps)

Models: rpart, glm, rf 
Number of resamples: 30 

Accuracy 
           Min.   1st Qu.    Median      Mean   3rd Qu. Max. NA's
rpart 0.6363636 0.7500000 0.8333333 0.8403263 0.9090909    1    0
glm   0.6666667 0.8333333 0.9166667 0.8807692 0.9807692    1    0
rf    0.7272727 0.8333333 0.9128788 0.8974359 0.9214744    1    0

Kappa 
           Min.   1st Qu.    Median      Mean   3rd Qu. Max. NA's
rpart 0.2413793 0.5000000 0.6666667 0.6806696 0.8196721    1    0
glm   0.3333333 0.6439394 0.8333333 0.7597664 0.9608434    1    0
rf    0.4406780 0.6666667 0.8216008 0.7935792 0.8408635    1    0

dotplot(resamps)

# 5. 모형성능 평가 -----
hy_pred_class <- predict(hy_rf, newdata = test_df)
## 혼동행렬 -----
confusionMatrix(hy_pred_class, test_df$y)

Confusion Matrix and Statistics

          Reference
Prediction 홍카콜라 알릴레오
  홍카콜라       22        2
  알릴레오        1       23
                                         
               Accuracy : 0.9375         
                 95% CI : (0.828, 0.9869)
    No Information Rate : 0.5208         
    P-Value [Acc > NIR] : 3.647e-10      
                                         
                  Kappa : 0.875          
 Mcnemar's Test P-Value : 1              
                                         
            Sensitivity : 0.9565         
            Specificity : 0.9200         
         Pos Pred Value : 0.9167         
         Neg Pred Value : 0.9583         
             Prevalence : 0.4792         
         Detection Rate : 0.4583         
   Detection Prevalence : 0.5000         
      Balanced Accuracy : 0.9383         
                                         
       'Positive' Class : 홍카콜라       
                                         

4.1 댓글 제목

NLP4kec 팩키지를 활용해서 유튜브 제목을 형태소분석하여 이를 tidytext 작업흐름에 맞춰 빈도수 분석을 한다.

# install.packages("C:/Users/chongmu/Downloads/NLP4kec_1.2.0.zip", repos=NULL)
library(NLP4kec)
library(extrafont)
loadfonts()

hy_bow_df <- hy_channel_stat_comment_df %>% 
  select(channel_name, title) %>% 
  mutate(bow = r_parser_r(title, language = "ko", useEn = TRUE))

hy_bow_tidy_df <- hy_bow_df %>% 
  mutate(bow = map(bow, str_split, pattern=" ") ) %>% 
  select(channel_name, title, bow) %>% 
  unnest(bow) %>% 
  unnest(bow)

hy_bow_tidy_df %>% 
  count(channel_name, bow, sort=TRUE) %>% 
  filter(bow != "",
         channel_name == "TV홍카콜라") 

# A tibble: 274 x 3
   channel_name bow        n
   <chr>        <chr>  <int>
 1 TV홍카콜라   홍준표    63
 2 TV홍카콜라   뉴스      53
 3 TV홍카콜라   콕        52
 4 TV홍카콜라   tv        13
 5 TV홍카콜라   대담       9
 6 TV홍카콜라   쇼         9
 7 TV홍카콜라   편         9
 8 TV홍카콜라   live       8
 9 TV홍카콜라   시사       8
10 TV홍카콜라   air        7
# ... with 264 more rows

hy_bow_tidy_df %>% 
  count(channel_name, bow, sort=TRUE) %>% 
  filter(bow != "") %>% 
  group_by(channel_name) %>% 
  top_n(20, wt=n) %>% 
  ungroup() %>% 
  ggplot(aes(x=fct_reorder2(bow, channel_name, -n), y=n, fill=channel_name)) +
    geom_col() +
    coord_flip() +
    facet_wrap(~channel_name, scales = "free") +
    labs(title="TV홍카콜라 vs 알릴레오 고빈도 용어 20선",
         subtitle="유튜브 채널",
         x="", y="") +
    theme_light(base_family="NanumGothic") +
    theme(legend.position = "none") 

5.1 댓글 사용자 예측 BaseTable

댓글 사용자 예측 BaseTable을 댓글로부터 제작한다. 그리고 나서 이를 나이브베이즈 예측모형을 통해 제작한다. “알릴레오” 유튜브 채널에 댓글이 없는 동영상이 많아서 이를 제거한다.

hy_channel_stat_comment_df %>% 
  select(channel_name, comment) %>% 
  mutate(check_type = map_lgl(comment, is.data.frame)) %>% 
  count(check_type, channel_name) %>% 
  mutate(pcnt = n/sum(n))

# A tibble: 3 x 4
  check_type channel_name     n  pcnt
  <lgl>      <chr>        <int> <dbl>
1 FALSE      알릴레오       126 0.357
2 TRUE       TV홍카콜라      79 0.224
3 TRUE       알릴레오       148 0.419

댓글을 뽑아내서 형태소 분석을 한 후에 예측모형에 사용된 basetable을 제작한다.

library(tidytext)
library(NLP4kec)
library(caret)
library(glmnet)

hy_text_basetable <- hy_channel_stat_comment_df %>% 
  select(id, channel_name, comment) %>% 
  mutate(check_type = map_lgl(comment, is.data.frame)) %>% 
  filter(check_type) %>% 
  select(-check_type)

hy_text_basetable_df <- hy_text_basetable %>% 
  unnest(comment) %>% 
  select(id, channel_name, textDisplay) %>% 
  mutate(bow = r_parser_r(textDisplay, language = "ko", useEn = TRUE))

hy_text_basetable_df %>% write_rds("data/hy_text_basetable_df.rds")

glmnet 팩키지 cv.glmnet() 함수를 사용해서 유튜브 채널에 붙는 댓글을 넣으면 채널을 예측하는 댓글 예측모형을 제작할 수 있다.

library(doSNOW)

hy_text_basetable <- hy_channel_stat_comment_df %>% 
  select(id, channel_name, comment) %>% 
  mutate(check_type = map_lgl(comment, is.data.frame)) %>% 
  filter(check_type) %>% 
  select(-check_type)

## NLP4kec --> 형태소 분석

hy_basetable_df  <- read_rds("data/hy_text_basetable_df.rds")

hy_basetable_bow_df <- hy_basetable_df %>% 
  select(id, bow) %>% 
  mutate(bow = map(bow, str_split, pattern=" ") ) %>% 
  unnest(bow) %>% 
  unnest(bow) 

hy_basetable_sparse <- hy_basetable_bow_df %>% 
  # filter(str_detect(bow, "[가-흫].+"), str_length(bow) > 1) %>%
  count(id, bow, sort = TRUE) %>% 
  cast_sparse(id, bow, n)

cl <- makeCluster(8, type = "SOCK")
registerDoSNOW(cl)

glmnet_mod <- cv.glmnet(hy_basetable_sparse, as.factor(hy_text_basetable$channel_name), 
                        family = "binomial", 
                        alpha=0, nfolds=5, parallel=TRUE, intercept=TRUE,
                        type.measure="class")

stopCluster(cl)

## 혼동행렬 -----
hy_predict <- predict(glmnet_mod, newx = hy_basetable_sparse, s = "lambda.min",type = "class")
confusionMatrix(as.factor(hy_predict), as.factor(hy_text_basetable$channel_name))

Confusion Matrix and Statistics

            Reference
Prediction   TV홍카콜라 알릴레오
  TV홍카콜라         79        0
  알릴레오            0      148
                                     
               Accuracy : 1          
                 95% CI : (0.9839, 1)
    No Information Rate : 0.652      
    P-Value [Acc > NIR] : < 2.2e-16  
                                     
                  Kappa : 1          
 Mcnemar's Test P-Value : NA         
                                     
            Sensitivity : 1.000      
            Specificity : 1.000      
         Pos Pred Value : 1.000      
         Neg Pred Value : 1.000      
             Prevalence : 0.348      
         Detection Rate : 0.348      
   Detection Prevalence : 0.348      
      Balanced Accuracy : 1.000      
                                     
       'Positive' Class : TV홍카콜라