Вступление

Данный групповой проект был сделан Власенко Анастасией, Волковой Вероникой, Гончаровой Екатериной, Лактионовым Вадимом, Феофиловым Кириллом - группой №5.

Мы начнем работу с загрузки датасета по фильмам и сокращенный по рейтингам этих фильмов. В первой части мы хотим посмотреть на то, как связаны между собой компании, выпускающие фильмы и жанры фильмов ( = построить две разные сети).

Кластеры, которые содержат похожие фильмы, позволят нам предлагать пользователю то, что ему может понравиться. Предположим, что Пользователю 1 понравился фильм в жанрах Экшен, Драма, Комедия. Мы попробуем предложить ему фильм из того же кластера, куда попал первый фильм с расчётом на то, что он ему тоже понравится.

Разведочный анализ, выбор переменных

Загрузка библиотек и данных

library(tidyverse)
library(readr)
library(tidyr)
library(magrittr)
library(tidytext)
library(recommenderlab)
library(igraph)
library(tnet)
movies <- read_csv("~/shared/minor2_2018/data/movies.csv")
ratings <- read_csv("~/shared/minor2_2018/data/ratings_cut.csv")
source("~/shared/minor2_2018/2-tm-net/extract_json.R")

Первая сеть: по жанрам

meta <- movies %>% 
  dplyr::select(movie_id, genres)
meta_n = extract_json(df = meta, col = "genres")
rownames(meta_n) <- str_c("id", meta_n$movie_id, sep = "_") 
 
meta_n = meta_n %>% 
  select(-movie_id, -genres) %>%   
  as.matrix()

Начнем с построения самого простого графика, который потом преобразуем.

g <- graph_from_incidence_matrix(meta_n)
is.bipartite(g)
## [1] TRUE
pr = bipartite.projection(g)
 
p <- pr[[1]]
 
V(p)$label <- NA
lt = layout.fruchterman.reingold(p)
plot(p, vertex.size = 2, layout = lt)

Первый граф выглядит очень хаотично и практически не читаем, поэтому нам нужно поработать над ним: отфильтруем его, оставим более сильные связи.

movies_id <- rownames(meta_n)

df <- data.frame(movies = str_replace(movies_id, "id_", ""), i = 1:545) 
 
p = projecting_tm(meta_n, method="Newman")
p <- left_join(p, df, by = "i")
 
df <- data.frame(movies_1 = str_replace(movies_id, "id_", ""), j = 1:545)
p <- left_join(p, df, by = "j")
p = dplyr::select(p, i = movies, j = movies_1, w)
p1 = filter(p, w >= 0.04) %>% select(-w) # здесь можно менять w
 
set.seed(483)
net1 <- simplify(graph_from_edgelist(as.matrix(p1), directed = F))
V(net1)$color <- "steel blue"
V(net1)$name
##   [1] "3"    "200"  "311"  "443"  "459"  "535"  "720"  "1114" "1604" "1722"
##  [11] "1726" "1739" "1884" "2317" "2673" "2749" "2782" "2856" "3269" "3497"
##  [21] "3624" "3730" "3760" "4406" "57"   "118"  "199"  "1292" "1432" "1482"
##  [31] "1556" "2217" "2743" "3148" "3153" "4001" "77"   "554"  "1902" "4043"
##  [41] "4148" "166"  "312"  "384"  "832"  "886"  "1599" "1759" "2276" "2360"
##  [51] "2385" "2470" "2697" "3347" "4080" "4247" "4456" "252"  "426"  "473" 
##  [61] "563"  "760"  "1507" "1525" "1776" "1983" "2690" "3107" "3414" "3446"
##  [71] "3938" "4100" "4179" "4418" "362"  "862"  "406"  "1035" "1218" "1408"
##  [81] "2558" "2640" "3309" "3944" "486"  "528"  "851"  "3155" "3205" "3489"
##  [91] "4136" "2182" "2456" "3481" "4141" "551"  "993"  "1184" "1406" "2163"
## [101] "2731" "3138" "3551" "629"  "3496" "3753" "3936" "4384" "2342" "2464"
## [111] "2899" "2944" "4345" "818"  "2875" "819"  "2116" "4374" "1267" "1832"
## [121] "1861" "3434" "3905" "2266" "2395" "3713" "2617" "2734" "3920" "3188"
## [131] "3455" "3610" "3638"
V(net1)$label <- NA
plot(net1, vertex.label.color = "black", vertex.size = 3, layout = layout.fruchterman.reingold(net1))

Это выглядит уже лучше! Данный граф дает нам представление о том, что жанры все же имеют тенденцию формировать между собой кластеры, более того часть из них собирается в тесный “клубок”, не взаимодействующий с другими узлами (отсутствуют брокеры).

membership = membership(fastgreedy.community(net1))

m = factor(membership)
sort(m)
##  166  312  384  832  886 1759 2276 2360 2385 2470 2697 3347 4080 4247 2342 
##    1    1    1    1    1    1    1    1    1    1    1    1    1    1    1 
## 2464 2899 2944 4345  406 1035 1218 1408 2558 2640 3309 3944   77  554 1902 
##    1    1    1    1    2    2    2    2    2    2    2    2    3    3    3 
## 4043 4148 1599 4456  252  426  473  563  760 1507 1525 1776 1983 2690 3107 
##    3    3    3    3    3    3    3    3    3    3    3    3    3    3    3 
## 3414 3446 3938 4100 4179 4418  362  862  486  528  851 3155 3205 3489 4136 
##    3    3    3    3    3    3    3    3    3    3    3    3    3    3    3 
##  551  993 1184 1406 2163 2731 3138 3551  629 3496 3753 3936 4384 1267 2266 
##    3    3    3    3    3    3    3    3    3    3    3    3    3    3    3 
## 3188 3455    3  200  311  443  459  535  720 1114 1604 1722 1726 1739 1884 
##    3    3    4    4    4    4    4    4    4    4    4    4    4    4    4 
## 2317 2673 2749 2782 2856 3269 3497 3624 3730 3760 4406   57  118  199 1292 
##    4    4    4    4    4    4    4    4    4    4    4    4    4    4    4 
## 1432 1482 1556 2217 2743 3148 3153 4001 2182 2456 3481 4141 1832 1861 3434 
##    4    4    4    4    4    4    4    4    4    4    4    4    5    5    5 
## 3905 2617 2734 3920  819 2116 4374 2395 3713  818 2875 3610 3638 
##    5    5    5    5    6    6    6    7    7    8    8    9    9 
## Levels: 1 2 3 4 5 6 7 8 9
V(net1)$color = membership
plot(net1, vertex.size = 5,vertex.label.cex = 0.4)

Чтобы можно было говорить о каком-то анализе, раскрасим кластеры в разные цвета и подпишем их.

plot(net1, layout = layout.kamada.kawai(net1), edge.arrow.size = 0, vertex.color 
= membership, vertex.size = 5,vertex.label.cex = 0.4, margin = -0.1, vertex.label = V(net1)$name)

m[m==1]
##  166  312  384  832  886 1759 2276 2360 2385 2470 2697 3347 4080 4247 2342 
##    1    1    1    1    1    1    1    1    1    1    1    1    1    1    1 
## 2464 2899 2944 4345 
##    1    1    1    1 
## Levels: 1 2 3 4 5 6 7 8 9
m[m==2]
##  406 1035 1218 1408 2558 2640 3309 3944 
##    2    2    2    2    2    2    2    2 
## Levels: 1 2 3 4 5 6 7 8 9
m[m==3]
##   77  554 1902 4043 4148 1599 4456  252  426  473  563  760 1507 1525 1776 
##    3    3    3    3    3    3    3    3    3    3    3    3    3    3    3 
## 1983 2690 3107 3414 3446 3938 4100 4179 4418  362  862  486  528  851 3155 
##    3    3    3    3    3    3    3    3    3    3    3    3    3    3    3 
## 3205 3489 4136  551  993 1184 1406 2163 2731 3138 3551  629 3496 3753 3936 
##    3    3    3    3    3    3    3    3    3    3    3    3    3    3    3 
## 4384 1267 2266 3188 3455 
##    3    3    3    3    3 
## Levels: 1 2 3 4 5 6 7 8 9
m[m==4]
##    3  200  311  443  459  535  720 1114 1604 1722 1726 1739 1884 2317 2673 
##    4    4    4    4    4    4    4    4    4    4    4    4    4    4    4 
## 2749 2782 2856 3269 3497 3624 3730 3760 4406   57  118  199 1292 1432 1482 
##    4    4    4    4    4    4    4    4    4    4    4    4    4    4    4 
## 1556 2217 2743 3148 3153 4001 2182 2456 3481 4141 
##    4    4    4    4    4    4    4    4    4    4 
## Levels: 1 2 3 4 5 6 7 8 9
m[m==5]
## 1832 1861 3434 3905 2617 2734 3920 
##    5    5    5    5    5    5    5 
## Levels: 1 2 3 4 5 6 7 8 9
m[m==6]
##  819 2116 4374 
##    6    6    6 
## Levels: 1 2 3 4 5 6 7 8 9
m[m==7]
## 2395 3713 
##    7    7 
## Levels: 1 2 3 4 5 6 7 8 9
m[m==8]
##  818 2875 
##    8    8 
## Levels: 1 2 3 4 5 6 7 8 9
m[m==9]
## 3610 3638 
##    9    9 
## Levels: 1 2 3 4 5 6 7 8 9
a = data.frame(movie_id = V(net1)$name, clust = V(net1)$color)

movies$movie_id = as.factor(movies$movie_id)
movies_name = movies %>% select(movie_id, title)

mov_names = left_join(a, movies_name, by = "movie_id")

assortativity(net1, V(net1), directed = T)
## [1] 0.8381166
a_5 = mov_names %>% filter(clust == 5) #это просто, чтобы посмотреть, названия фильмов к какому кластеру принадлежат
a_9 = mov_names%>% filter(clust==9)

У нас получилось 9 кластеров, которые объединяют фильмы по жанрам. По большей части фильмы связаны одинаковым набором жанров, причем связь очень сильная. Например, в 9 кластере находятся 2 фильма, у которых абсолютно одинаковый набор жанров, ничем не отличающийся. Могут добавляться еще жанры, но бОльшая часть будет одинаковой. Также, рассчитав ассортативность, выяснили, что, действительно, узлы предпочитают формировать связь с похожими узлами, т.к. показатель ассортативности близок к единице (0.8381166).

Вторая сеть: по производителям

movies = movies %>% select(movie_id, production_companies)

companies = extract_json2(df = movies, col = "production_companies")
companies = spread(companies, key = production_companies_sep, value = production_companies_v)

rownames(companies) = companies$movie_id
rownames(companies) = str_c("id", companies$movie_id, sep = "_")

companies[is.na(companies)] = 0 
companies = companies %>% select(-movie_id, -production_companies) %>% as.matrix()

Построим изначальную сеть, опираясь на которую, будем делать дальнейший анализ.

net <- graph_from_incidence_matrix(companies)
 
is.bipartite(net)
## [1] TRUE
pr = bipartite.projection(net) 
 
p <- pr[[1]]
p
## IGRAPH 88449f4 UNW- 522 5533 -- 
## + attr: name (v/c), weight (e/n)
## + edges from 88449f4 (vertex names):
##  [1] id_24--id_175  id_24--id_2668 id_30--id_148  id_30--id_187 
##  [5] id_30--id_313  id_30--id_445  id_30--id_658  id_30--id_708 
##  [9] id_30--id_720  id_30--id_859  id_30--id_963  id_30--id_1035
## [13] id_30--id_1102 id_30--id_1151 id_30--id_1202 id_30--id_1270
## [17] id_30--id_1332 id_30--id_1693 id_30--id_1709 id_30--id_1862
## [21] id_30--id_1922 id_30--id_1963 id_30--id_1971 id_30--id_2200
## [25] id_30--id_2306 id_30--id_2457 id_30--id_2495 id_30--id_2617
## [29] id_30--id_2897 id_30--id_3546 id_30--id_3610 id_30--id_3624
## + ... omitted several edges
V(p)$label <- NA
lt = layout.fruchterman.reingold(p)

membership = membership(fastgreedy.community(p))
plot(p,
     vertex.size = degree(p)*0.15,
     vertex.label.cex = degree(p)/10,
     layout = lt*0.8,
     edge.arrow.size=.4)

Как можно заметить, сеть слишком плотная, и для того, чтобы более осознанно выделить кластеры, взвесим проекцию обычной проекции(подход Ньюмана, т.е взвесим силу связи между фильмами на популярность кинокомпании). После взвешивания удалим слабые связи. Это позволить просмотреть структуру сети более четко.

movies_id <- rownames(companies)
 
df <- data.frame(movies = str_replace(movies_id, "id_", ""), i = 1:522)
 
p = projecting_tm(companies, method="Newman")
p <- left_join(p, df, by = "i")
 
df <- data.frame(movies_1 = str_replace(movies_id, "id_", ""), j = 1:522)
p <- left_join(p, df, by = "j")
p = dplyr::select(p, i = movies, j = movies_1, w)
ggplot(p) + 
  geom_histogram(aes(x=w), fill = "pink") +
  geom_vline(aes(xintercept=mean(w)), color="blue", linetype="dashed", size=1) +
  xlab("Newman's coefficient")

Мы можем попробовать удалить все связи, у которых сила чуть ниже или выше среднего(подбором, 0,13 - наиболее оптимальное)

p1 = filter(p, w >= 0.13) %>% 
  select(-w) # здесь можно менять w

set.seed(123) 
 
net1 <- simplify(graph_from_edgelist(as.matrix(p1), directed=F))
V(net1)$color <- "steel blue"
V(net1)$label <- NA
V(net1)$name
##   [1] "24"   "175"  "2668" "77"   "4043" "78"   "1525" "118"  "390"  "548" 
##  [11] "638"  "1406" "1943" "4064" "4214" "143"  "2000" "2178" "3730" "148" 
##  [21] "313"  "2200" "2388" "2866" "166"  "3434" "167"  "3256" "181"  "1384"
##  [31] "187"  "3463" "216"  "3350" "4001" "256"  "1294" "1861" "2558" "2743"
##  [41] "3496" "3758" "4201" "295"  "658"  "3309" "297"  "378"  "299"  "1305"
##  [51] "3155" "4432" "4472" "329"  "331"  "788"  "330"  "3920" "334"  "528" 
##  [61] "2574" "3860" "4141" "4306" "348"  "1655" "353"  "564"  "1220" "1267"
##  [71] "1387" "1585" "2612" "2641" "3505" "357"  "571"  "1180" "2423" "3321"
##  [81] "3938" "4269" "4356" "362"  "851"  "1518" "4127" "367"  "4109" "384" 
##  [91] "808"  "832"  "1073" "2755" "3151" "424"  "1432" "2217" "3355" "4247"
## [101] "459"  "3466" "3905" "473"  "3446" "482"  "748"  "3255" "3713" "3944"
## [111] "486"  "3197" "516"  "2673" "517"  "2078" "535"  "1893" "2021" "2095"
## [121] "3174" "1332" "3295" "3546" "3610" "3715" "551"  "833"  "2366" "2528"
## [131] "3497" "3557" "558"  "1709" "2103" "570"  "3333" "621"  "1905" "3651"
## [141] "629"  "1646" "3090" "4248" "4271" "4392" "631"  "3943" "645"  "1470"
## [151] "652"  "3198" "4488" "659"  "1138" "686"  "705"  "908"  "2009" "3634"
## [161] "3898" "720"  "4345" "829"  "3866" "903"  "1615" "1682" "1955" "2177"
## [171] "4080" "1035" "1693" "1070" "4339" "1074" "1102" "1151" "1270" "1862"
## [181] "2495" "2617" "1105" "2862" "3085" "3756" "1145" "2800" "4282" "1148"
## [191] "3684" "3481" "4354" "1234" "1329" "3626" "1292" "4331" "1307" "1482"
## [201] "1983" "2136" "3579" "3917" "2992" "3825" "1528" "3782" "1561" "1571"
## [211] "1665" "1839" "1850" "1865" "1704" "2456" "3864" "1744" "1843" "1759"
## [221] "3347" "1770" "4227" "3188" "1962" "1939" "3624" "3205" "3948" "3385"
## [231] "2112" "2376" "2122" "2152" "2782" "2524" "3489" "3824" "2186" "3638"
## [241] "2192" "3936" "4113" "4374" "2348" "2875" "2372" "2499" "2391" "2705"
## [251] "2690" "3107" "3414" "4100" "2731" "3787" "3780" "2777" "2874" "3161"
## [261] "3077" "4384" "3084" "4149" "3138" "4429" "3225" "4402" "3326" "4056"
## [271] "3611" "3714" "4171" "4260" "4341" "4418" "4456"
plot(net1, vertex.label.color = "black", vertex.size = 3, layout = layout.kamada.kawai(net1))

Структура просматривается гораздо лучше. Осталось выделить кластеры.

membership1 = membership(cluster_edge_betweenness(net1))
 
plot(net1, layout = layout.kamada.kawai(net1), edge.arrow.size = 0, vertex.color = membership1, vertex.size = 5,vertex.label.cex = 0.4)

Следующий шаг - выяснить, какой кластер к чему относится.

n = factor(membership1)
sort(n)
##   24  175 2668   77 4043  181 1384  570 3333  652 3198 4488 1105 2862 2992 
##    1    1    1    2    2    2    2    2    2    2    2    2    2    2    2 
## 3205 3948 2777 4384 3084 4149 3611   78 1525  118  390  548  638 1406 1943 
##    2    2    2    2    2    2    2    3    3    4    4    4    4    4    4 
## 4064 4214  330 3920  143 2000 2178 3730  167 3256 4201  299 1305 3155 4432 
##    4    4    4    4    5    5    5    5    5    5    5    5    5    5    5 
## 4472  424 1432 2217 3355 4247  459 3466 3905 1770 4227 1939 3624 2122 2524 
##    5    5    5    5    5    5    5    5    5    5    5    5    5    5    5 
## 3489 3824  148  313 2200 2388 2866  357  571 1180 2423 3321 3938 4356  535 
##    5    5    6    6    6    6    6    6    6    6    6    6    6    6    6 
## 1893 2021 2095 3174 2499  166 3434  187 3463  216 3350 4001  256 1294 1861 
##    6    6    6    6    6    7    7    8    8    9    9    9   10   10   10 
## 2558 2743 3758  353  564 1220 1267 1387 1585 2612 2641 3505 4269  486 3197 
##   10   10   10   10   10   10   10   10   10   10   10   10   10   10   10 
## 1332 3295 3546 3610 3715  631 3943  686 1102 1151 1270 1862 2495 2617 3481 
##   10   10   10   10   10   10   10   10   10   10   10   10   10   10   10 
## 4354 1561 1571 1704 2456 3780 3496  334  528 2574 3860 4141 4306  551  833 
##   10   10   10   10   10   10   11   11   11   11   11   11   11   11   11 
## 2366 2528 3497 3557 2372  295  658 3309  517 2078 1665 1839 1850 1865 3188 
##   11   11   11   11   11   12   12   12   12   12   12   12   12   12   12 
##  297  378  329  331  788  348 1655  362  851 1518 4127  367 4109  482  748 
##   13   13   14   14   14   15   15   16   16   16   16   17   17   17   17 
## 3255 3713 3944  384  808  832 1073 2755 3151  659 1138 3085 3756 1962  473 
##   17   17   17   18   18   18   18   18   18   18   18   18   18   18   19 
## 3446  516 2673  558 1709 2103  645 1470 3864 3385  621 1905 3651  629 1646 
##   19   20   20   21   21   21   21   21   21   21   22   22   22   23   23 
## 3090 4248 4271 4392 1074  705  908 2009 3634 3898 1145 2800 4282  720 4345 
##   23   23   23   23   23   24   24   24   24   24   24   24   24   25   25 
## 1292 4331  829 3866  903 1615 1682 1955 2177 4080 1035 1693 1070 4339 1148 
##   25   25   26   26   27   27   27   27   27   27   28   28   29   29   30 
## 3684 1234 1329 3626 1307 1482 1983 2136 3579 3917 3825 2348 2875 2391 2705 
##   30   31   31   31   32   32   32   32   32   32   32   32   32   32   32 
## 3077 1528 3782 1744 1843 1759 3347 2112 2376 2152 2782 2186 3638 2192 3936 
##   32   33   33   34   34   35   35   36   36   37   37   38   38   39   39 
## 4113 4374 2690 3107 3414 4100 2731 3787 3714 2874 3161 3138 4429 3225 4402 
##   39   39   40   40   40   40   41   41   41   42   42   43   43   44   44 
## 3326 4056 4171 4260 4341 4418 4456 
##   45   45   45   46   46   47   47 
## 47 Levels: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 ... 47
V(net1)$color = membership1
n[n==1]
##   24  175 2668 
##    1    1    1 
## 47 Levels: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 ... 47
n[n==2]
##   77 4043  181 1384  570 3333  652 3198 4488 1105 2862 2992 3205 3948 2777 
##    2    2    2    2    2    2    2    2    2    2    2    2    2    2    2 
## 4384 3084 4149 3611 
##    2    2    2    2 
## 47 Levels: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 ... 47
n[n==3]
##   78 1525 
##    3    3 
## 47 Levels: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 ... 47
n[n==4]
##  118  390  548  638 1406 1943 4064 4214  330 3920 
##    4    4    4    4    4    4    4    4    4    4 
## 47 Levels: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 ... 47
n[n==5]
##  143 2000 2178 3730  167 3256 4201  299 1305 3155 4432 4472  424 1432 2217 
##    5    5    5    5    5    5    5    5    5    5    5    5    5    5    5 
## 3355 4247  459 3466 3905 1770 4227 1939 3624 2122 2524 3489 3824 
##    5    5    5    5    5    5    5    5    5    5    5    5    5 
## 47 Levels: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 ... 47
n[n==6]
##  148  313 2200 2388 2866  357  571 1180 2423 3321 3938 4356  535 1893 2021 
##    6    6    6    6    6    6    6    6    6    6    6    6    6    6    6 
## 2095 3174 2499 
##    6    6    6 
## 47 Levels: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 ... 47
n[n==7]
##  166 3434 
##    7    7 
## 47 Levels: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 ... 47
n[n==8]
##  187 3463 
##    8    8 
## 47 Levels: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 ... 47
n[n==9]
##  216 3350 4001 
##    9    9    9 
## 47 Levels: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 ... 47
n[n==10]
##  256 1294 1861 2558 2743 3758  353  564 1220 1267 1387 1585 2612 2641 3505 
##   10   10   10   10   10   10   10   10   10   10   10   10   10   10   10 
## 4269  486 3197 1332 3295 3546 3610 3715  631 3943  686 1102 1151 1270 1862 
##   10   10   10   10   10   10   10   10   10   10   10   10   10   10   10 
## 2495 2617 3481 4354 1561 1571 1704 2456 3780 
##   10   10   10   10   10   10   10   10   10 
## 47 Levels: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 ... 47
n[n==11]
## 3496  334  528 2574 3860 4141 4306  551  833 2366 2528 3497 3557 2372 
##   11   11   11   11   11   11   11   11   11   11   11   11   11   11 
## 47 Levels: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 ... 47
n[n==12]
##  295  658 3309  517 2078 1665 1839 1850 1865 3188 
##   12   12   12   12   12   12   12   12   12   12 
## 47 Levels: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 ... 47
n[n==13]
## 297 378 
##  13  13 
## 47 Levels: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 ... 47
a = data.frame(movie_id = V(net1)$name, clust = V(net1)$color)

movies$movie_id = as.numeric(movies$movie_id)
a$movie_id = as.numeric(a$movie_id)

movies <- read_csv("~/shared/minor2_2018/data/movies.csv")

movies_name = movies %>% select(movie_id, title)

mov_names = left_join(a, movies_name, by = "movie_id")

Код ниже нужен лишь для того, чтобы можно было просматривать названия фильмов и их количество в зависимости от кластера

a_6 = mov_names %>% 
  filter(clust == 6)

Например, в 6 кластере, несмотря на то, что фильмы были выпущены сразу несколькими компаниями, их объединяет Univeral Pictures.

Рассчитаем ассортативность, т.е. того, насколько узлы склонны иметь связи с узлами, обладающими сходными свойствами.

assortativity(net1, V(net1), directed = T)
## [1] 0.7394885

Ответ: почти 0,74. Значение близко к единице. Таким образом, узлы предпочитают формировать связь с похожими узлами.

Итак, мы получили сеть, в которой четко прослеживаются кластеры фильмов, похожих по кинокомпаниям, это значит, что данная сеть позволит нам в дальнейшем рекомендовать тому или иному пользователю фильмы из одного кластера.

Дополнительные данные

Мы нашли два датасета на сайте Kaggle, из одного (tmdb_5000_credits) было бы интересно взять информацию об актерах фильмов, из второго (IMDB_2280_Most_Voted_Movies) - можно будет посмотреть отдельный рейтинг (IMDB Rating), режиссеров и просто добавить больше фильмов для расширенных возможностей.

movies <- read_csv("~/shared/minor2_2018/data/movies.csv")
ratings <- read_csv("~/shared/minor2_2018/data/ratings.csv")

actors = read.csv("/students/avvlasenko_1/tmdb_5000_credits.csv")
actors2 = read.csv("/students/avvlasenko_1/IMDB_2280_Most_Voted_Movies.csv")

movies_act = extract_json2(df = actors, col = "cast")
mov = movies %>% 
full_join(x = movies, y = movies_act, by = "title")

mov1 = mov %>% 
  full_join(x = mov, y = actors2, by = "title")

mov2 = mov1 %>% 
  select (title, popularity, cast_sep, rating, director, revenue)

Посмотрим, какие актеры наиболее часто встречаются в фильмах. Далее же сможем проанализировать рейтинг фильмов, в которых играли актеры из топ-10 по количеству исполненных ролей.

mov3 = mov1 %>% 
  group_by(cast_sep) %>% 
  summarise(count = n()) %>% 
  arrange(desc(count)) %>% 
  top_n(10, count)

mov2 = na.omit (mov2)
mov3 = na.omit (mov3)
head(mov3, 10)
## # A tibble: 9 x 2
##   cast_sep          count
##   <fct>             <int>
## 1 Samuel L. Jackson    68
## 2 Robert De Niro       57
## 3 Bruce Willis         51
## 4 Matt Damon           48
## 5 Morgan Freeman       46
## 6 Steve Buscemi        43
## 7 Johnny Depp          42
## 8 Liam Neeson          41
## 9 Owen Wilson          40
top = mov2 %>% 
  dplyr::filter(cast_sep == "Samuel L. Jackson"| cast_sep == "Robert De Niro" | cast_sep =="Bruce Willis" | cast_sep =="Matt Damon" | cast_sep =="Morgan Freeman" | cast_sep =="Steve Buscemi" | cast_sep =="Liam Neeson" | cast_sep =="Johnny Depp" | cast_sep =="Owen Wilson" | cast_sep =="John Goodman" | cast_sep =="Nicolas Cage" | cast_sep =="Alec Baldwin")

top$revenue = top$revenue/1000000
top = top %>% 
  group_by(cast_sep) %>% 
  summarize(mean = mean(revenue))

top = transform(top, cast_sep = reorder(cast_sep, mean))
ggplot(top) + 
  geom_histogram(data = top, aes(x = cast_sep, y = mean), stat = "identity", col = "violet", fill = "violet", alpha = 0.6) +
theme(axis.text.x = element_text(angle = 90)) +
ggtitle("Зависимость дохода фильмов от участия актера") +
xlab("Имя актера") +
ylab("Среднее ревеню фильма с участием\n актера, в миллионах")

Как видно здесь, часть актеров “собирает” фильмам большие кассы - нам нужно будет обратить внимание на таких, поскольку они скорее всего будут очень часто встречаться. В дальнейшем было бы здорово использовать предпочтения в актерах пользователя, поскольку это делает рекомендации более точными.

stra <- movies %>% 
  dplyr::select(movie_id, production_countries)
stra_n = extract_json2(df = stra, col = "production_countries")
stra_n %>% group_by(production_countries_sep) %>% count() 
## # A tibble: 28 x 2
## # Groups:   production_countries_sep [28]
##    production_countries_sep     n
##    <fct>                    <int>
##  1 United States of America   482
##  2 Sweden                       3
##  3 Germany                     31
##  4 Italy                        9
##  5 Spain                        7
##  6 Japan                       12
##  7 United Kingdom              76
##  8 India                        2
##  9 Argentina                    2
## 10 Netherlands                  4
## # … with 18 more rows
actors2 = actors2 %>%
select(rating, director) %>%
group_by(director) %>%
mutate(ntimes = length(director)) %>%
filter(director != "", ntimes > 10) 

ggplot(actors2) +
geom_boxplot(aes(x = director, y = rating)) +
theme(axis.text.x = element_text(angle = 69))

Рекомендательная система коллаборативной фильтрации

На первых шагах нам не требуются дополнительные данные, поскольку мы строим рекомендательную систему на основе оценок(коллаборативная фильтрация) по готовому датасету ratings_cut.

Подготовка данных

ratings_1 = select(ratings, customer_id, movie_id, rating)
sp_ratings = spread(ratings_1, key = movie_id, value = rating)
rownames(sp_ratings) = sp_ratings$customer_id
sp_ratings = select(sp_ratings, -customer_id)
sp_ratings = as.matrix(sp_ratings)
sp_ratings = as(sp_ratings, "realRatingMatrix")
sp_ratings = sp_ratings[rowCounts(sp_ratings) > 5, colCounts(sp_ratings) > 10]

set.seed(321)
test_ratings = sample(1:nrow(sp_ratings), size = nrow(sp_ratings)*0.1)
ratings_train = sp_ratings[-test_ratings, ]
ratings_test = sp_ratings[test_ratings, ]

Оценка UBCF и IBCF

Для того, чтобы определить, использовать метод IBCF или UBCF посмотрим на соответствующие оценки моделей

razbivka = evaluationScheme(data = sp_ratings, method = "split", train = 0.9, given = 8, goodRating = 4)
recc_model = Recommender(data = getData(razbivka, "train"), method = "IBCF")
recc_predict = predict(object = recc_model, newdata = getData(razbivka, "known"), n = 5, type = "ratings")
eval_accuracy = calcPredictionAccuracy(x = recc_predict, data = getData(razbivka, "unknown"), byUser = F)
eval_accuracy %>% knitr::kable(caption = "оценки для IBCF")
оценки для IBCF
x
RMSE 1.497788
MSE 2.243369
MAE 1.095225

И для UBCF

recc_model = Recommender(data = getData(razbivka, "train"), method = "UBCF")
recc_predict = predict(object = recc_model, newdata = getData(razbivka, "known"), n = 5, type = "ratings")
eval_accuracy = calcPredictionAccuracy(x = recc_predict, data = getData(razbivka, "unknown"), byUser = F)
eval_accuracy %>% knitr::kable(caption = "оценки для UBCF")
оценки для UBCF
x
RMSE 1.0265914
MSE 1.0538898
MAE 0.8089049

Оценки отклонений и ошибок в модели UBCF меньше, значит используем её.

Используем метод UBCF

recc_model = Recommender(data = ratings_train, method = "UBCF", parameter = list(k = 30))
## Available parameter (with default values):
## method    =  cosine
## nn    =  25
## sample    =  FALSE
## normalize     =  center
## verbose   =  FALSE
recc_predict = predict(object = recc_model, newdata = ratings_test, n = 5)

Теперь мы можем рекоммендовать фильмы для любого пользователя, поставившего оценки и спрогнозировать будущие оценки фильмам

recc_films = function(user_id){ 
  recc_user = recc_predict@items[[user_id]]
  movies_user = recc_predict@itemLabels[recc_user]
  a = ratings$title[match(movies_user, ratings$movie_id)]
  recc_predict@ratings[[user_id]]
  a
}
recc_ratings = function(user_id){recc_predict@ratings[[user_id]]}

Проверка

Проверим для пользователя с id 2554698

as.data.frame(recc_films("2554698")) %>% 
  knitr::kable(caption = "Рекомендованные фильмы")
Рекомендованные фильмы
recc_films(“2554698”) 
as.data.frame(recc_ratings("2554698")) %>% 
  knitr::kable(caption = "Предсказанные рейтинги")

Table: Предсказанные рейтинги

|| || || ||

Эти таблицы содержат в себе рекомендации конкретному пользователю с предсказывемой оценкой(насколько пользователю понравится фильм, на сколько он его оценит) - в дальнейшем мы планируем сделать рекомендации более точными, чтобы устранить случаи, когда пользователь остается недоволен фильмом.

Холодный старт

Content-based рекомендательная система

Подготовка данных

movies <- read_csv("~/shared/minor2_2018/data/movies.csv")
ratings <- read_csv("~/shared/minor2_2018/data/ratings_cut.csv")
## Warning: Missing column names filled in: 'X1' [1]
IMDB_2280_Most_Voted_Movies <- read_csv("/students/avvlasenko_1/IMDB_2280_Most_Voted_Movies.csv")
imdb = IMDB_2280_Most_Voted_Movies %>% 
  select(title, director, actors, rating)

b = left_join(movies, imdb)
b$movie_id[3] = 9856
b$movie_id[23] = 9863
b$movie_id[27]=9462
b$movie_id[32]=7861
b$movie_id[43] =4529
b$movie_id[189]=5896
b$movie_id[223]=5212

2) Матрица схожести(по жанрам, директорам, пользовательскому рейтингу, длительности фильма)

kino = b %>% 
  select(title, movie_id, genres, director, rating, runtime)
kino = mutate(kino, e = 1)
kino = extract_json(df = kino, col = "genres")
kino = spread(kino, key = director, value = e, fill = 0)
kino = kino %>% 
  select(-genres, -title)
rownames(kino) = kino$movie_id
kino = kino %>% 
  select(-movie_id)
mod = lsa::cosine(t(as.matrix(kino)))
diag(mod) = 0

Функция + проверка

getFilms = function(userId){
  client = ratings %>% 
    filter(customer_id == userId & rating == 5)
  
  if (length(client)==0) {
    recommend = "Гарри Поттер"} else {
    mostSimilar = head(sort(mod[,as.character(client$movie_id)], decreasing = T), n = 3)
    a = which(mod[,as.character(client$movie_id)] %in% mostSimilar, arr.ind = TRUE)
    rows = a %% dim(mod)[1]
    result = rownames(mod)[rows]
    recommend = filter(movies,movie_id %in% result) %>% dplyr::select(title)
  }
  
  recommend
}
knitr::kable(getFilms(111343))
title
Network
Midnight Cowboy
A Streetcar Named Desire 
knitr::kable(getFilms(2533015))
title
Chocolat
Sideways
Four Weddings and a Funeral 
id = c(100, 100, 100, 100, 100, 100, 100, 100, 100, 100) 
movie_id = c(621, 252, 558, 3107, 1332, 3938, 3466, 607, 554, 550) 
movie_title = c("Armageddon", "Stuart Little 2", "Fantastic Four", "Mulan", "Sherlock Holmes", "Shrek 2", "Spy Kids", "Speed", "Solaris", "First Knight") 
rating = c(5, 4, 2, 5, 5, 5, 2, 2, 3, 4) 

kirill = data.frame(customer_id = id, movie_id = movie_id, rating = rating, movie_title = movie_title) 
ratings = full_join(ratings, kirill) 
knitr::kable(getFilms(100))
title
Robin Hood
Bad Boys II
Planet of the Apes

Чтобы проверить точность модели, мы предложили людям оценить 10 фильмов по шкале от 0 до 5, а затем вбили их в базу данных. Результаты оценки первого пользователя таковы: Armageddon - 5 Stuart Little 2 - 4 Fantastic Four - 2 Mulan - 5 Sherlock Holmes - 5 Shrek 2 - 5 Spy Kids - 2 Speed - 2 Solaris - 3 First Knight - 4 По предварительной оценке, можно заметить, что пользователь любит приключенческий жанр, фантастику и экшн, посмотрим, что получится. Наша система выдала 3 фильма (Bad Boys II, Planet of the Apes, Sphere), которые, действительно, оказались похожими друг на друга. Они совмещают в себе те жанры, что любит наш пользователь. Кроме того, если посмотреть на хронометраж фильмов, можно увидеть, что все они идут 2+ часа. Из этого всего можно сделать вывод о том, что пользователю, вероятнее всего, понравятся фильмы, рекомендованные нашей системой.

id = c(101, 101, 101, 101, 101, 101, 101, 101, 101, 101) 
movie_id = c(3124, 1270, 1180, 2782, 1332, 3938, 1615, 1073, 554, 313) 
movie_title = c("Titanic", "The Great Gatsby", "A beautiful Mind", "Braveheart", "Sherlock Holmes", "Shrek 2", "The American President", "Coach Carter", "Solaris", "Pay It Forward") 
rating = c(5, 3, 5,2, 5, 5, 3, 5, 2, 5) 

katya = data.frame(customer_id = id, movie_id = movie_id, rating = rating, movie_title = movie_title) 
ratings = full_join(ratings, katya)
knitr::kable(getFilms(101))
title
The Hurricane
The Master
The Passion of the Christ

Второй пользователь дал оценку следующим фильмам: Titanic - 5 The Great Gatsby - 3 A beautiful Mind - 5 Braveheart - 2 Sherlock Holmes - 5 Shrek 2 - 5 The American President -3 Coach Carter - 5 Solaris - 2 Pay It Forward -5 Большинство из них - фильмы достаточно серьезные: драмы, детективы. Что же выдала нам наша рекомендательная система? The Hurricane, The Master, The Passion of the Christ. В результате видим, что, опять же, полученные фильмы похожи друг на друга. Почитав к ним описание, видим, что они все относятся к жанру драма. Некоторые из них описывают автобиографические события.

Холодный старт 2.0

Какие сочетания слов (биграммы) чаще всего встречаются в фильмах, которые окупили затраты на своё производство в прокате?

Частота встречаемости биграмм в бюджетно успешных фильмах
Сочетание слов Частота встречаемости
year old 5
christmas eve 4
los angeles 4
new york 3
north pole 3
peter pan 3
woman named 3
adams family’s 2
american woman 2
buddy cops 2

That is it, folks.