透過網路分析Kaggle的電影資料集中演員與導演的關係

library(readr)
library(dplyr)
library(jiebaR)
library(tidyr)
library(tidytext)
library(igraph)
library(topicmodels)
library(stringr)
library(ggplot2)
library(jsonlite)

資料來源：kaggle上的電影資料集
https://www.kaggle.com/tmdb/tmdb-movie-metadata

電影所有演職人員的關係

# 讀入演職人員名單
credits = read_csv("./tmdb_5000_credits.csv")

Parsed with column specification:
cols(
  movie_id = col_double(),
  title = col_character(),
  cast = col_character(),
  crew = col_character()
)

credits

# cast:演員
# crew:工作人員

# 將工作人員的資料從JSON格式中轉成tidy格式，並找出所有導演的名單。
director = credits %>% 
  filter(nchar(crew)>2) %>% 
  mutate(js=lapply(crew,fromJSON)) %>% 
  unnest(js) %>% 
  mutate(dir_name = name) %>% 
  select(movie_id, title, job, dir_name) %>% 
  filter(job == "Director")
director

# 過濾出沒有導演的電影
credits %>% 
  filter(.$movie_id %in% credits$movie_id[!unique(credits$movie_id) %in% unique(director$movie_id)]) %>% 
  select(movie_id, title, crew)

# 總出現的導演人數
length(unique(director$dir_name))

[1] 2577

# 畫圖呈現導演拍過的電影片數
director %>%
  filter(!(is.na(dir_name)| dir_name==""))%>%
  group_by(dir_name) %>% 
  summarise(count=n()) %>% 
  top_n(20) %>% 
  mutate(dir_name = reorder(dir_name, count)) %>% 
  ggplot(aes(dir_name,count,fill=dir_name)) + 
  geom_bar(stat="identity") + 
  theme(legend.position="None") + 
  labs(x="Director",y="Count") +
  coord_flip()

Selecting by count

# 將演員的資料從JSON格式中轉成tidy格式。
actor = credits %>% 
  filter(nchar(cast)>2) %>% 
  mutate(js=lapply(cast,fromJSON)) %>% 
  unnest(js) %>% 
  mutate(cast_name = name) %>% 
  select(movie_id, title, cast_name, order)
actor

# 總出現的演員人數
length(unique(actor$cast_name))

[1] 54201

# 畫圖呈現演員拍過的電影片數
actor %>%
  filter(!(is.na(cast_name)| cast_name==""))%>%
  group_by(cast_name) %>% 
  summarise(count=n()) %>% 
  top_n(20) %>% 
  mutate(cast_name = reorder(cast_name, count)) %>% 
  ggplot(aes(cast_name,count,fill=cast_name)) + 
  geom_bar(stat="identity") + 
  theme(legend.position="None") + 
  labs(x="Actor",y="Count") +
  coord_flip()

Selecting by count

# 總共有參與的人員(導演&演員)
all_credit <- c(director$dir_name, actor$cast_name)
length(unique(all_credit))

[1] 56175

# 整理所有人員
# 如果有執導過，就標註他爲dir
# 如果沒有，則標註他爲act
all_list <- data.frame(name=unique(all_credit)) %>%
              mutate(type=ifelse(name %in% director$dir_name, "dir", "act"))
all_list

# 整理所有導演有執導過的演員
act <- right_join(actor, director) %>% 
  select(movie_id, title, cast_name, dir_name, order)

Joining, by = c("movie_id", "title")

act

# 挑出cast_name(演員名字)、dir_name(導演名字)、movie_id 三個欄位
# 為了減少資料量，過濾掉 order < 3 的資料，order代表在該電影裡角色的重要性，越小代表越重要
link <- act %>% 
  filter(order < 3) %>% 
  select(cast_name, dir_name, movie_id)
link

# 建立網路關係
act_Network <- graph_from_data_frame(d=link, directed=T)
act_Network

IGRAPH edb71b1 DN-- 7842 15089 -- 
+ attr: name (v/c), movie_id (e/n)
+ edges from edb71b1 (vertex names):
 [1] Sam Worthington  ->James Cameron     Zoe Saldana      ->James Cameron     Sigourney Weaver ->James Cameron    
 [4] Johnny Depp      ->Gore Verbinski    Orlando Bloom    ->Gore Verbinski    Keira Knightley  ->Gore Verbinski   
 [7] Daniel Craig     ->Sam Mendes        Christoph Waltz  ->Sam Mendes        Léa Seydoux      ->Sam Mendes       
[10] Christian Bale   ->Christopher Nolan Michael Caine    ->Christopher Nolan Gary Oldman      ->Christopher Nolan
[13] Taylor Kitsch    ->Andrew Stanton    Lynn Collins     ->Andrew Stanton    Samantha Morton  ->Andrew Stanton   
[16] Tobey Maguire    ->Sam Raimi         Kirsten Dunst    ->Sam Raimi         James Franco     ->Sam Raimi        
[19] Zachary Levi     ->Byron Howard      Mandy Moore      ->Byron Howard      Donna Murphy     ->Byron Howard     
[22] Zachary Levi     ->Nathan Greno      Mandy Moore      ->Nathan Greno      Donna Murphy     ->Nathan Greno     
+ ... omitted several edges

# 畫出網路圖
plot(act_Network)

看不出什麼東西。

# 將點的大小和線的粗細調小，並不顯示所有人員的名字。
plot(act_Network, vertex.size=2, edge.arrow.size=.2, vertex.label=NA)

可以發現比較有趣的一點：發現有不少部電影的導演是自導自演。

電影分類

根據前面的網路圖可以發現資料量太大，4800部電影、54201位演員、2577位導演，很難從圖中找出關係，
因此我們從kaggle電影資料集的另一部份：每部電影的相關資料(包括電影預算、類型、票房、片長等)， 以其中的每部電影的類型來進行分類(動作、科幻、冒險等)，藉此以不同的電影類型來進行網路圖的繪製。

# 讀入資料集
movies = read_csv("tmdb_5000_movies.csv")

Parsed with column specification:
cols(
  .default = col_character(),
  budget = col_double(),
  id = col_double(),
  popularity = col_double(),
  release_date = col_date(format = ""),
  revenue = col_double(),
  runtime = col_double(),
  vote_average = col_double(),
  vote_count = col_double()
)
See spec(...) for full column specifications.

movies

# 將所屬類型的資料從JSON格式中轉成tidy格式。
# 製作電影利潤變數
m_genres <- movies %>% 
  filter(nchar(genres)>2) %>% 
  mutate(js=lapply(genres,fromJSON)) %>% 
  unnest(js) %>% 
  mutate(movie_id = id, genre = name, ROI=(revenue-budget)/budget) %>% 
  select(movie_id, title, genre,ROI)
m_genres

revenue_data<-movies %>%
  filter(budget >= 1000000 & revenue >= 1000000) %>%
  mutate(ROI = (revenue - budget)/budget)
#預算
revenue_data %>%
  select(title, budget) %>%
  arrange(desc(budget)) %>%
  head(15)%>%
  ggplot(., aes(x = reorder(title, -desc(budget)), y = budget/1000000)) +
  geom_bar(stat = "identity")+ 
  ggtitle("電影預算")+
  xlab("")+
  ylab("預算金額 (百萬)") + 
  theme(text = element_text(family = "Heiti TC Light")) +
  coord_flip()

#收入
revenue_data %>%
  select(title, revenue) %>%
  arrange(desc(revenue)) %>%
  head(15)%>%
  ggplot(., aes(x = (reorder(title, -desc(revenue))), y = revenue/1000000)) +
  geom_bar( stat = "identity")+ 
  theme(axis.text.x=element_text(hjust=1))+
  ggtitle("Movie Revenues")+
  xlab("")+
  ylab("Revenue (in Millions)") + 
  coord_flip() 

## 投資報酬率
revenue_data %>%
  select(title, budget, revenue, ROI) %>%
  arrange(desc(ROI)) %>%
  head(15)%>%
  ggplot(., aes(x = reorder(title, -desc(ROI)), y = ROI)) +
  geom_bar( stat = "identity")+ 
  theme(axis.text.x=element_text(hjust=1))+
  ggtitle("Movie ROI")+
  xlab("")+
  ylab("ROI") + 
  coord_flip()

投資報酬率高的電影年代都比較久遠

## 透過時間計算電影發布的個數
library(lubridate)
revenue_data %>%
 filter(year(release_date) > 1990) %>%  
 group_by(year = year(release_date), month = month(release_date)) %>%
 summarise(count = n())%>% 
 ggplot(aes(year, as.factor(month)))+
 geom_tile(aes(fill=count),colour="white")+
 scale_fill_gradient(low="light blue",high = "dark blue") +
 xlab("電影發布年份")+
 ylab("電影發布月份")+
 ggtitle("Heat Map") +
  theme(text = element_text(family = "Heiti TC Light"))

從1990-2010電影上映的數量逐年增加，尤其以九月份上映的電影數量偏多

# 將資料合併到剛剛的導演和演員名單
act_genre <- right_join(act, m_genres)

Joining, by = c("movie_id", "title")

act_genre

# 資料集中所有的分類
unique(act_genre$genre)

 [1] "Action"          "Adventure"       "Fantasy"         "Science Fiction" "Crime"           "Drama"          
 [7] "Thriller"        "Animation"       "Family"          "Western"         "Comedy"          "Romance"        
[13] "Horror"          "Mystery"         "History"         "War"             "Music"           "Documentary"    
[19] "Foreign"         "TV Movie"       

# 這裡為了降低資料量，做了兩個限制：
# 1.order < 3，order 越小表示在劇中越重要，亦即主演。
# 2.genre == "Action"，找出為動作片的電影。
link_g_action <- act_genre %>% 
  filter(order < 3) %>% 
  filter(genre == "Action") %>% 
  select(cast_name, dir_name, movie_id, genre, ROI)
link_g_action

# 建立網路關係
g_action_Network <- graph_from_data_frame(d=link_g_action, directed=T)
g_action_Network

IGRAPH 24b7d70 DN-- 2489 3626 -- 
+ attr: name (v/c), movie_id (e/n), genre (e/c), ROI (e/n)
+ edges from 24b7d70 (vertex names):
 [1] Sam Worthington  ->James Cameron     Zoe Saldana      ->James Cameron     Sigourney Weaver ->James Cameron    
 [4] Johnny Depp      ->Gore Verbinski    Orlando Bloom    ->Gore Verbinski    Keira Knightley  ->Gore Verbinski   
 [7] Daniel Craig     ->Sam Mendes        Christoph Waltz  ->Sam Mendes        Léa Seydoux      ->Sam Mendes       
[10] Christian Bale   ->Christopher Nolan Michael Caine    ->Christopher Nolan Gary Oldman      ->Christopher Nolan
[13] Taylor Kitsch    ->Andrew Stanton    Lynn Collins     ->Andrew Stanton    Samantha Morton  ->Andrew Stanton   
[16] Tobey Maguire    ->Sam Raimi         Kirsten Dunst    ->Sam Raimi         James Franco     ->Sam Raimi        
[19] Robert Downey Jr.->Joss Whedon       Chris Hemsworth  ->Joss Whedon       Mark Ruffalo     ->Joss Whedon      
[22] Ben Affleck      ->Zack Snyder       Henry Cavill     ->Zack Snyder       Gal Gadot        ->Zack Snyder      
+ ... omitted several edges

# 畫出網路圖
plot(g_action_Network)

還是看不出什麼。

# 將點的大小和線的粗細調小，並不顯示所有人員的名字。
# 如果合作的電影有賺錢標記綠色，沒賺錢標記紅色
# E(g_action_Network)$color <- ifelse(E(g_action_Network)$ROI>mean(E(g_action_Network)$ROI) , "lightgreen", "palevioletred")
plot(g_action_Network, vertex.size=2, edge.arrow.size=.2 , vertex.label.cex=0.8, vertex.label= NA)

可以看出明顯比未做限制的結果稀疏許多，不過還是看不出什麼。

出演次數

因為資料量還是太大，這裡我們選擇以出演次數為限制，找出多產的演員與導演之間的關係。

# 找出出演次數大於10的演員
most_cast <- link_g_action %>% 
  distinct(movie_id, cast_name, .keep_all = T) %>% #排除一個電影可能會有兩個directors
  count(cast_name, sort = TRUE) %>% 
  filter(n >= 10)
most_cast

# 找出執導次數大於5的導演
most_dir <- link_g_action %>% 
  distinct(movie_id, dir_name, .keep_all = T) %>% 
  count(dir_name, sort = TRUE) %>% 
  filter(n >= 5)
most_dir

# 找出「出演次數大於10的演員」且「執導次數大於5的導演」的組合
lim_link_g_action <- link_g_action %>% 
  filter(.$cast_name %in% most_cast$cast_name & .$dir_name %in% most_dir$dir_name)
lim_link_g_action

# 篩選出上一步驟中有出現的組合
filtered_name <- all_list %>%
          filter(name %in% lim_link_g_action$cast_name | name %in% lim_link_g_action$dir_name) %>%
          arrange(desc(type))
filtered_name

# 建立網路關係
lim_g_action_Network <- graph_from_data_frame(d=lim_link_g_action, v=filtered_name, directed=T)
lim_g_action_Network

IGRAPH 864ccd1 DN-B 54 114 -- 
+ attr: name (v/c), type (v/c), movie_id (e/n), genre (e/c), ROI (e/n)
+ edges from 864ccd1 (vertex names):
 [1] Will Smith      ->Barry Sonnenfeld Tommy Lee Jones ->Barry Sonnenfeld Mark Wahlberg   ->Michael Bay     
 [4] Harrison Ford   ->Steven Spielberg Jackie Chan     ->Brett Ratner     Will Smith      ->Barry Sonnenfeld
 [7] Jet Li          ->Rob Cohen        Will Smith      ->David Ayer       Vin Diesel      ->Rob Cohen       
[10] Will Smith      ->Peter Berg       Pierce Brosnan  ->Lee Tamahori     Bruce Willis    ->Michael Bay     
[13] Tommy Lee Jones ->Barry Sonnenfeld Will Smith      ->Barry Sonnenfeld Mel Gibson      ->Richard Donner  
[16] Will Smith      ->Michael Bay      Angelina Jolie  ->Phillip Noyce    Liam Neeson     ->Louis Leterrier 
[19] Antonio Banderas->John McTiernan   Tom Cruise      ->John Woo         Tommy Lee Jones ->Paul Greengrass 
[22] Nicolas Cage    ->John Woo         Mel Gibson      ->Roland Emmerich  Tom Cruise      ->Steven Spielberg
+ ... omitted several edges

# 繪圖
set.seed(12345)
plot(lim_g_action_Network, vertex.size=2, edge.arrow.size=.2, vertex.label.cex=0.8)

還是稍微有點太多，改成只標示較有關聯的點(>=5)。

# 將有執導過人的點改為金色
# 單純是演員的點改為天藍色
# 合作較賺錢邊際設為綠色(ROI>全部平均)
# 較沒賺錢標記紅色(ROI<=全部平均)
# 顯示有超過5個關聯的點
set.seed(12345)
labels <- degree(lim_g_action_Network)
V(lim_g_action_Network)$label <- names(labels)
E(lim_g_action_Network)$color <- ifelse(E(lim_g_action_Network)$ROI>mean(E(lim_g_action_Network)$ROI) , "lightgreen", "palevioletred")
V(lim_g_action_Network)$color <- ifelse(V(lim_g_action_Network)$type == "dir", "gold", "lightblue")
plot(lim_g_action_Network, vertex.size=5, edge.arrow.size=.2 , vertex.label.cex=0.8, 
     vertex.label=ifelse(degree(lim_g_action_Network) >= 5, V(lim_g_action_Network)$label, NA))

透過這張圖我們可以看出，在動作片的這個範疇下，演員經常跟哪些導演合作拍戲，以及導演跟演員合作的電影的投資報酬率高低。