Analiza sieci społecznościowych - projekt zaliczeniowy

Opis danych:

Zbiór danych został utworzony w celu zestawienia wszystkich produkcji (filmy lub seriale i programy) dostępnych w serwisie Netflix i przeanalizowania danych w celu znalezienia interesujących faktów. Dane zostały pozyskane w lipcu 2022 r. i obejmują produkcje dostępne w Stanach Zjednoczonych.

Do przeprowadzenia analizy dysponować będziemy dwoma plikami: credits oraz titles.

Pierwszy z nich (credits) zawiera informacje dotyczące obsady danej produkcji. Można znaleźć tam informacje dotyczące aktorów i reżyserów ponad 77 tysięcy rekordów.

Drugi plik (titles) z kolei skupia się na samych produkcjach i zawiera ponad 5 tysięcy unikatowych tytułów na Netflixie.

Dla lepszego zrozumienia naszych danych, poniżej możemy znaleźć dwie tabele, w których znajduje się opis poszczególnych zmiennych.

Titles:

Zmienna	Opis
id	id danego tytułu na JustWatch*
title	tytuł produkcji
show_type	typ (film lub serial/program)
description	opis danej produkcji (fabuły)
release_year	data wydania
age_certification	grupa wiekowa odbiorców
runtime	czas trwania
genres	lista gatunków
production_countries	lista krajów produkujących dany tytuł
seasons	liczba sezonów
imdb_id	id na stronie IMDB
imdb_score	ocena produkcji na IMDB**
imdb_votes	liczba oddanych głósów na IMDB
tmdb_popularity	popularność na TMDB***
tmdb_score	ocena produkcji na TMDB

*JustWatch - wyszukiwarka seriali/filmów/programów. Umożliwia także użytkownikom śledzenie ich ulubionych programów i filmów oraz śledzić kiedy dany tytuł będzie dostępny w jednej z dostępnych usług.

**IMDB - jest jednym z najpopularniejszych i najbardziej wiarygodnych źródeł treści filmowych, telewizyjnych i gwiazd, zaprojektowanym, aby pomóc fanom odkrywać świat filmów i programów oraz decydować, co obejrzeć na podstawie rekomendacji. Posiada bazę danych, która zawiera miliony filmów, programów telewizyjnych i rozrywkowych oraz członków obsady i ekipy filmowej.

***TMDB - to stworzona przez społeczność baza danych filmów, seriali i programów telewizyjnych. Każdy fragment danych został dodany przez użytkowników i przetworzony przez TMDB. Zawiera dane dotyczące różnych tytułów, segreguje je na te bardziej i mniej popularne, ale również zawiera opinie i rankingi użytkowników.

Credits:

Zmienna	Opis
person_ID	id aktora/reżysera na JustWatch
id	id danego tytułu na JustWatch
name	imię i nazwisko aktora/reżysera
character_name	nazwa postaci granej w danej produkcji
role	pełniona funkcja (aktor lub reżyser)

Problem badawczy:

Przewidywanie, czy dana produkcja zdobędzie dużą popularność lub tego jaka będzie możliwa obsada nadchodzących filmów/serialów, jest dość rozpowszechnione wśród fanów i miłośników kina. Istnieje kilka powodów, dlaczego ludzie to robią.

Reżyserowie często mają swoich ulubionych aktorów, z którymi regularnie współpracują. Na przykład, Martin Scorsese często współpracuje z Leonardo DiCaprio, a Quentin Tarantino z Samuelem L. Jacksonem. Znając styl, wcześniejsze współprace reżysera i to, czy jego dzieła odniosły sukces, fani mogą próbować przewidzieć, jakie są szanse, że dany film/serial zdobędzie duża popularność i uznanie.

Na forach internetowych, w mediach społecznościowych i na stronach, fani często dyskutują i spekulują na temat potencjalnej obsady nadchodzących filmów i tego czy produkcja osiągnie sukces. Te spekulacje mogą być oparte na różnych czynnikach, takich jak plotki, wcześniejsze współprace i analizy stylu reżysera.

Przewidywanie popularności produkcji w świecie kina to część szerszej fascynacji kinematografią, która pozwala fanom angażować się w proces twórczy i wyrażać swoje oczekiwania oraz nadzieje dotyczące nadchodzących produkcji.

Cel projektu:

W związku z powyższym rozpoznaniem tematu i problematyki badania, poniżej przedstawione zostały cele projektu:

Projekt badań - będzie wykonany na zasadzie metody “Wyznaczenie granic sieci” - wyodrębnienie grupy obiektów, które będą poddane analizie. Po ustaleniu granic wykonuje się badanie wszystkich podmiotów znajdujących się w obrębie tej granicy.

Cel - opis:

Przedstawienie/zbadanie struktury, różnic i podobieństw sieci aktorów i reżyserów (w celu zweryfikowania podstawowych informacji dotyczących kształtu i specyfikacji grafów – dla dobrych i złych produkcji - zgodnie z poniższymi wytycznymi.

Uwaga 1: Właściwa analiza sieci społecznościowej powinna odbyć się w podziale na produkcje filmowe i seriale/programy, ze względu na różnice w świecie kinematografii dla tych dwóch kategorii. W niniejszym projekcie interesować będzie nas struktura sieci dla seriali/programów. Badanie będzie można w przyszłości wykonać również dla filmów.

Uwaga 2: Aby zagłębić się bardziej szczegółowo w powyższy temat, oprócz dzielenia sieci pod względem rodzaju produkcji, zastosujemy również podział pod względem oceny/popularności produkcji. Dzięki takiemu podejściu, będziemy mogli w większym stopniu szczegółowości przyjrzeć się strukturze między aktorami a reżyserami dla konkretnego obszaru (serial), wraz z rozróżnieniem charakterystyki sieci dla “dobrej” produkcji i “gorszej”. Dodatkowo będziemy starali skupić się na tych jednostkach (węzłach w grafie), które charakteryzują się konkretnymi parametrami (bliskość / stopień etc.), aby analizować tylko najbardziej istotnych “aktorów” w sieci.

W związku z powyższym, naszym celem będzie zobrazować struktury sieci aktorów i reżyserów dla poniższych kategorii:

struktura sieci aktor-reżyser dla:

serialów
mające dobre ratingi
odpowiednio duża próba (liczba) głosów, która złożyła się na rating
dodatkowa eliminacja jednostek w grafie na podstawie jednego z parametrów

struktura sieci aktor-reżyser dla:

serialów
mające złe ratingi
odpowiednio duża próba (liczba) głosów, która złożyła się na rating
dodatkowa eliminacja jednostek w grafie na podstawie jednego z parametrów

Uwaga 3: W ramach analizy struktury aktorów i reżyserów w produkcjach serialowych, które odniosły sukces oraz tych, które nie zdobyły uznania, wprowadzony został dodatkowy filtr oparty na odpowiedniej liczbie głosów oddanych na dany serial. Ten filtr służy jako zabezpieczenie, zapewniające, że do analizy będą brane pod uwagę jedynie te seriale, które wykazują się większą wiarygodnością w kontekście uzyskanej oceny. Nie możemy bowiem zakładać, że serial jest dobry lub zły na podstawie pojedynczej oceny na stronie. Wiarygodność ocen wzrasta wraz z liczbą głosów, co pozwala na bardziej rzetelną i obiektywną analizę jakości seriali.

Uwaga 4: Przy wyborze próby do analizy, dodatkowo zawęzimy nasze jednostki do tych, które charakteryzują się konkretnym parametrem, takim jak np. bliskość. Skupienie się na najbardziej istotnych jednostkach – aktorach i reżyserach – tworzących sieć pozwoli na bardziej precyzyjną analizę struktury sieci społecznościowej. Ponadto, ograniczenie liczby wierzchołków w grafie umożliwi lepsze zwizualizowanie sieci, ponieważ zbyt wiele wierzchołków sprawia, że wykres staje się nieczytelny, co utrudnia łatwą interpretację wyników. Dzięki temu podejściu będziemy mogli skupić się na kluczowych elementach sieci, co poprawi jakość i przejrzystość naszej analizy.

Przygotowanie danych:

Biblioteki:

library(readr)
library(dplyr)

## Warning: pakiet 'dplyr' został zbudowany w wersji R 4.3.2

## 
## Dołączanie pakietu: 'dplyr'

## Następujące obiekty zostały zakryte z 'package:stats':
## 
##     filter, lag

## Następujące obiekty zostały zakryte z 'package:base':
## 
##     intersect, setdiff, setequal, union

library(VIM)

## Ładowanie wymaganego pakietu: colorspace

## Ładowanie wymaganego pakietu: grid

## VIM is ready to use.

## Suggestions and bug-reports can be submitted at: https://github.com/statistikat/VIM/issues

## 
## Dołączanie pakietu: 'VIM'

## Następujący obiekt został zakryty z 'package:datasets':
## 
##     sleep

library(ggplot2)

## Warning: pakiet 'ggplot2' został zbudowany w wersji R 4.3.3

library(igraph)

## Warning: pakiet 'igraph' został zbudowany w wersji R 4.3.3

## 
## Dołączanie pakietu: 'igraph'

## Następujące obiekty zostały zakryte z 'package:dplyr':
## 
##     as_data_frame, groups, union

## Następujące obiekty zostały zakryte z 'package:stats':
## 
##     decompose, spectrum

## Następujący obiekt został zakryty z 'package:base':
## 
##     union

library(tidyverse)

## Warning: pakiet 'lubridate' został zbudowany w wersji R 4.3.2

## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ forcats   1.0.0     ✔ stringr   1.5.0
## ✔ lubridate 1.9.3     ✔ tibble    3.2.1
## ✔ purrr     1.0.1     ✔ tidyr     1.3.0

## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ lubridate::%--%()       masks igraph::%--%()
## ✖ tibble::as_data_frame() masks igraph::as_data_frame(), dplyr::as_data_frame()
## ✖ purrr::compose()        masks igraph::compose()
## ✖ tidyr::crossing()       masks igraph::crossing()
## ✖ dplyr::filter()         masks stats::filter()
## ✖ dplyr::lag()            masks stats::lag()
## ✖ purrr::simplify()       masks igraph::simplify()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors

library(RColorBrewer)
library(ggraph)

## Warning: pakiet 'ggraph' został zbudowany w wersji R 4.3.3

library(tidygraph)

## Warning: pakiet 'tidygraph' został zbudowany w wersji R 4.3.3

## 
## Dołączanie pakietu: 'tidygraph'
## 
## Następujący obiekt został zakryty z 'package:igraph':
## 
##     groups
## 
## Następujący obiekt został zakryty z 'package:stats':
## 
##     filter

Wgranie danych:

credits <- read_csv("C:/Users/Michal/Desktop/OSTATNI SEMESTR/ASS/credits.csv")

## Rows: 77801 Columns: 5
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (4): id, name, character, role
## dbl (1): person_id
## 
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.

titles <- read_csv("C:/Users/Michal/Desktop/OSTATNI SEMESTR/ASS/titles.csv")

## Rows: 5850 Columns: 15
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (8): id, title, type, description, age_certification, genres, production...
## dbl (7): release_year, runtime, seasons, imdb_score, imdb_votes, tmdb_popula...
## 
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.

Weryfikacja i przygotowanie typu zmiennych:

class(credits)

## [1] "spec_tbl_df" "tbl_df"      "tbl"         "data.frame"

class(titles)

## [1] "spec_tbl_df" "tbl_df"      "tbl"         "data.frame"

Możemy zauważyć, że nasze zbiory danych są obiektami data frame, co pozwoli nam na łatwe odwołanie się do poszczególnych elementów zbiorów oraz obróbkę danych.

Kolejnym krokiem będzie sprawdzenie typu naszych danych:

Nazwy_kolumn_credits <- colnames(credits)
Nazwy_kolumn_titles <- colnames(titles)

typy_zmiennych_credits <- sapply(credits, class)
typy_zmiennych_titles<- sapply(titles, class)

for (i in Nazwy_kolumn_credits) {
  cat("Typ zmiennej '", i, "': ", typy_zmiennych_credits[i], "\n", sep = "")
}

## Typ zmiennej 'person_id': numeric
## Typ zmiennej 'id': character
## Typ zmiennej 'name': character
## Typ zmiennej 'character': character
## Typ zmiennej 'role': character

for (i in Nazwy_kolumn_titles) {
  cat("Typ zmiennej '", i, "': ", typy_zmiennych_titles[i], "\n", sep = "")
}

## Typ zmiennej 'id': character
## Typ zmiennej 'title': character
## Typ zmiennej 'type': character
## Typ zmiennej 'description': character
## Typ zmiennej 'release_year': numeric
## Typ zmiennej 'age_certification': character
## Typ zmiennej 'runtime': numeric
## Typ zmiennej 'genres': character
## Typ zmiennej 'production_countries': character
## Typ zmiennej 'seasons': numeric
## Typ zmiennej 'imdb_id': character
## Typ zmiennej 'imdb_score': numeric
## Typ zmiennej 'imdb_votes': numeric
## Typ zmiennej 'tmdb_popularity': numeric
## Typ zmiennej 'tmdb_score': numeric

Jak widzimy w naszym zbiorze danych występują 2 różne typy zmiennych: numeric (zmienna numeryczna to liczba rzeczywista) oraz character (ciąg znaków tekstowych).

W kolejnym kroku możemy przyjrzeć się podsumowaniu “summary” naszych danych, pamiętając, że więcej informacji zdobędziemy dla danych numerycznych - dlatego też przyjrzymy się głównie nim.

Wstępna analiza danych:

Zbiór danych - titles

Dla zmiennej type możemy sprawdzić, czy liczba występowania w naszym zbiorze danych typu ‘MOVIE’ i ‘SHOW’ jest podobna czy jednak, któraś kategoria przeważa nad drugą.

table(titles$type)

## 
## MOVIE  SHOW 
##  3744  2106

Sprawdźmy jak prezentują się te wartości w kontekście struktury zbioru danych.

M <- table(titles$type, exclude = "SHOW") / nrow(titles) * 100
S <- table(titles$type, exclude = "MOVIE") / nrow(titles) * 100
M

## 
## MOVIE 
##    64

## 
## SHOW 
##   36

Możemy zauważyć, że w naszym zbiorze przeważają filmy.

Struktura_type <- c(M, S)

pie_colors <- c("#FF9999", "#66B2FF")
par(bg = "#F5F5F5")

result <- pie(Struktura_type,
              main = "Struktura typów produkcji",
              labels = c("Movies", "Shows"),
              col = pie_colors,
              border = "white",
              clockwise = TRUE,
              init.angle = 90,
              cex.main = 1.5,
              cex.lab = 1.2
)

legend("topright", c("Movies (64%)", "Shows (36%)"), 
       cex = 1.2, fill = pie_colors, bty = "n")

print(result)

## NULL

W naszym zbiorze jest 64% filmów oraz 34% seriali/programów.

Przyjrzyjmy się teraz zmiennej release_year, która przedstawia datę produkcji.

summary(titles$release_year)

##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##    1945    2016    2018    2016    2020    2022

Możemy zauważyć, że najstarsza produkcja w naszym zbiorze danych powstała w 1945 roku, z kolei najnowsza jest z 2022 roku. Warto zwrócić również uwagę, że wiekszość naszych tytułów powstała w okresie pomiędzy 2016 rokiem, a 2020 rokiem.

year<-table(titles$release_year)
year

## 
## 1945 1954 1956 1958 1959 1960 1961 1963 1966 1967 1969 1971 1972 1973 1974 1975 
##    1    2    1    1    1    1    1    1    1    2    2    1    3    1    1    2 
## 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 
##    3    1    1    5    3    3    6    4    6    1    4    6    7   12    7   13 
## 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 
##    3   14   16   10    7   16   22   13   11   20   22   31   38   32   45   48 
## 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 
##   63   59   66   86  107  135  153  223  362  563  773  836  814  787  371

Najwięcej tytułów powstało w roku 2019, natomiast do roku 2000 widać stosunkowo małą liczbę produkcji, a przyrost możemy zauważyć dopiero po roku 2010. Warto również zauważyć spadek po roku 2019 (prawdopodobnie jest to spowodowane pandemią COVID-19).

W celu lepszego zwizualizowania powyższych wniosków, podzielimy nasze dane na przedziały:

year_cut <- cut(titles$release_year, 
                breaks = c(-Inf, 2010, 2016, 2019, Inf),
                labels = c('<=2010','2010-2016', '2016-2019', '>2019'),
                include.lowest = TRUE)
table(year_cut)

## year_cut
##    <=2010 2010-2016 2016-2019     >2019 
##       640      1066      2172      1972

year_table <- table(year_cut)

year_cut <- cut(titles$release_year, 
                breaks = c(-Inf, 2010, 2016, 2019, Inf),
                labels = c('<=2010','2010-2016', '2016-2019', '>2019'),
                include.lowest = TRUE)

year_cut <- factor(year_cut, levels = c('<=2010','2010-2016', '2016-2019', '>2019'))

year_data <- data.frame(year_cut)

wykres_year <- ggplot(data = year_data, aes(x = year_cut)) +
  geom_bar(fill = "lightblue", color = "black") +
  labs(x = "Okres", y = "Liczebność", title = "Wykres liczebności produkcji powstałych \n w poszczególnych okresach") +
  theme_minimal() +
  theme(
    plot.title = element_text(color = "black", size = 16, face = "bold", hjust = 0.5),
    axis.text = element_text(color = "black", size = 12, face = "bold"), 
    axis.title = element_text(color = "black", size = 14, face = "bold"), 
    panel.background = element_rect(fill = "#EBEBEB"),
    plot.background = element_rect(fill = "gray")
  )

print(wykres_year)

Powyższy wykres, na którym przedstawione zostały liczebności produkcji w poszczególnych latach potwierdza wcześniejsze uwagi.

Aby zobaczyć jak liczebność wyprodukowanych produkcji zminiałą się na przestrzeni czasu, przedstawmy odpowiedni wykres:

titles_summary <- titles %>%
  group_by(type, release_year) %>%
  summarise(count = n()) %>%
  ungroup()

## `summarise()` has grouped output by 'type'. You can override using the
## `.groups` argument.

colors <- c("MOVIE" = "slategrey", "SHOW" = "plum4")

p <- ggplot(titles_summary, aes(x = release_year, y = count, fill = type, color = type)) +
  geom_area(alpha = 0.9, position = 'identity') +
  geom_line() +
  scale_fill_manual(values = colors) +
  scale_color_manual(values = colors) +
  theme_minimal() +
  theme(
    panel.grid = element_blank(),
    axis.line.x = element_line(color = "black", size = 1.3),
    axis.ticks = element_blank(),
    axis.text.y = element_text(hjust = 1),
    axis.text.x = element_text(hjust = 0.5),
    plot.title = element_text(size = 15, face = "bold", family = "serif"),
    plot.subtitle = element_text(size = 12, family = "serif"),
    legend.position = "none"
  ) +
  labs(
    title = "Liczebność produkcji z podziałem na warianty na przestrzeni czasu") +
  annotate("text", x = 2010, y = max(titles_summary$count), label = "MOVIE", color = "slategrey", size = 5, fontface = "bold", family = "serif") +
  annotate("text", x = 2011, y = max(titles_summary$count), label = "|", color = "black", size = 5, fontface = "bold", family = "serif") +
  annotate("text", x = 2012, y = max(titles_summary$count), label = "SHOW", color = "plum4", size = 5, fontface = "bold", family = "serif") +
  scale_x_continuous(breaks = seq(2008, 2020, 1), limits = c(2008, 2020))

## Warning: The `size` argument of `element_line()` is deprecated as of ggplot2 3.4.0.
## ℹ Please use the `linewidth` argument instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.

print(p)

## Warning: Removed 78 rows containing non-finite outside the scale range
## (`stat_align()`).

## Warning: Removed 78 rows containing missing values or values outside the scale range
## (`geom_line()`).

Gwałtowny skok produkcji od ok. 2016 roku, może być spowodowany znacznym rozszerzeniem działalności Netflixa na skalę globalną. Natomiast, porównując rok 2019 do 2020 widać pewien spadek, najprawdopodobniej przez wstrzymanie wielu produkcji z powodu pandemii.

Zmienna age_certification przedatawia specjalne oznaczenia kategorii wiekowych, dla których dopuszczalne jest obejrzenie poszczególnej produkcji.

Spójrzmy na poniższą tabelę, aby rozeznać się jakie kategorie wsytępują w naszym zbiorze danych oraz jaka jest ich liczebność.

wiek <- table(titles$age_certification)

wiek_wykres <- data.frame(
  rating = names(wiek),
  count = as.numeric(wiek)
)
wiek_wykres

##    rating count
## 1       G   124
## 2   NC-17    16
## 3      PG   233
## 4   PG-13   451
## 5       R   556
## 6   TV-14   474
## 7    TV-G    79
## 8   TV-MA   883
## 9   TV-PG   188
## 10   TV-Y   107
## 11  TV-Y7   120

Spójrzmy na wykres przedstawiający liczebność serialów w poszczególnych kategoriach wiekowych.

shows <- titles[titles$type == "SHOW", ]

shows_certification <- shows %>%
  count(age_certification, name = "total_shows")

ggplot(shows_certification, aes(x = age_certification, y = total_shows, fill = age_certification)) +
  geom_bar(stat = "identity", color = "black") +  
  geom_text(aes(label = total_shows), vjust = -0.5, color = "black") +  
  labs(title = "Seriale wg kategorii wiekowych", x = "Kategoria wiekowa", y = "Liczebność") +
  scale_fill_brewer(palette = "Set3") +  
  theme_minimal(base_size = 15) +
  theme(plot.title = element_text(hjust = 0.5),
        axis.text.x = element_text(angle = 45, hjust = 1),  
        axis.text = element_text(color = "black"),  
        axis.line = element_line(color = "black"), 
        panel.background = element_rect(fill = "#EBEBEB"),
        plot.background = element_rect(fill = "#F5F5F5"),
        legend.position = "none") +
  coord_cartesian(ylim = c(0, max(shows_certification$total_shows) * 1.2)) +  
  scale_x_discrete(limits = unique(shows_certification$age_certification))

Spójrzmy, co oznaczają poszczególne kategorie wiekowe:

Dla dzieci:

TV-Y - Dzieci (Wszystkie)
TV-Y7 - Dzieci (Powyżej 7 roku życia)
TV-PG - Dzieci (Nadzór rodzicielski zalecany)

Dla nastolatków:

TV-14 - Nastolatkowie (Powyżej 14 roku życia)

Dla dorosłych:

TV-MA - dorośli (Wszyscy)

Inne:

TV-G - Ogólne

Podsumowując - sumarycznie rzecz ujmując serialów dla dzieci jest najmniej (nie biorąc pod uwagi kategorii ogólnej). Najwięcej produkcji natomiast, znajduje się w wariancie dla osób dorosłych.

Porównajmy teraz powyższy wykres z analogiczną grafiką natomiast dla produkcji filmowych.

movies <- titles[titles$type == "MOVIE", ]

movies_certification <- movies %>%
  count(age_certification, name = "total_movies")

ggplot(movies_certification, aes(x = age_certification, y = total_movies, fill = age_certification)) +
  geom_bar(stat = "identity", color = "black") +  
  geom_text(aes(label = total_movies), vjust = -0.5, color = "black") +  
  labs(title = "Filmy wg kategorii wiekowych", x = "Kategoria wiekowa", y = "Liczebność") +
  scale_fill_brewer(palette = "Set3") +  
  theme_minimal(base_size = 15) +
  theme(plot.title = element_text(hjust = 0.5),
        axis.text.x = element_text(angle = 45, hjust = 1),  
        axis.text = element_text(color = "black"),  
        axis.line = element_line(color = "black"),
        panel.background = element_rect(fill = "#EBEBEB"),
        plot.background = element_rect(fill = "#F5F5F5"),
        legend.position = "none") +  
  coord_cartesian(ylim = c(0, max(movies_certification$total_movies) * 1.2)) +  
  scale_x_discrete(limits = unique(movies_certification$age_certification))

Można zauważyć, że kategorie wiekowe dla seriali są inne, niż dla filmów. Warto również zwrócić uwagę na znacznie większą liczbę braków danych w przypadku filmów.

Wyjaśnienie oznaczeń kategorii:

Dla dzieci:

PG - Dla większości dzieci, ale niektóre treści mogą wymagać nadzoru rodziców.

Dla nastolatków:

PG-13 - Dla nastolatków, z zaleceniem nadzoru rodziców dla dzieci poniżej 13 roku życia.

Dla dorosłych:

NC-17 - Tylko dla dorosłych, nikt poniżej 17 roku życia nie jest dopuszczony

Inne:

G - Dla wszystkich grup wiekowych.
R - Ograniczone do widzów powyżej 17 roku życia, chyba że towarzyszy im dorosły.

Zmienna runtime oznacza długość danej produkcji w minutach.

summary(titles$runtime)

##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##    0.00   44.00   83.00   76.89  104.00  240.00

Warto zwrócić uwagę, że minimalna wartość, która występuje w zbiorze to 0 minut. Należy zatem mieć to na uwadzę i przyjrzeć w późniejszym etapie projektu, czy przypadkiem nie mamy do czynienia z pewnym brakiem danym lub ewentualną pomyłką/błędem w zbiorze danych.

Zobaczmy ile jest takich produkcji i jakie są ich tytuły:

titles0 <- titles$title[titles$runtime == 0]

length(titles0)

## [1] 14

(length(titles0)*100)/length(titles$runtime)

## [1] 0.2393162

titles0

##  [1] "Pecados capitales"                   "Pink Zone"                          
##  [3] "La Niña"                             "Sons of the Caliphate"              
##  [5] "Borges"                              "Emily's Wonder Lab"                 
##  [7] "Nailed It! Germany"                  "นางสาวก้นครัว"                        
##  [9] "Bullsh*t the Game Show"              "Back to 15"                         
## [11] "Storybots Laugh Learn Sing"          "Vendetta: Truth, Lies and The Mafia"
## [13] "Pedal to Metal"                      "Word Party Presents: Math!"

Takich tytułów jest zaledwie 14 w naszym zbiorze, który liczy w sumie 5850 rekordów, a więc jest to bardzo mały procent naszych danych (tylko 0,24% całego zbioru).

Możemy więc zastanowić się nad ewentualnym usunięciem tych tytułów w kolejnej części projektu.

Spójrzmy jak przedstawiają się nasze obserwacje na wykresie punktowym pod względem wartości długości produkcji.

par(bg = "#F5F5F5")
plot(titles$runtime,
     lty = 2,
     lwd = 1,
     main = "Długość produkcji dla poszczególnych obserwacji",
     col.main = "Black",
     xlab = "Obserwacja",
     ylab = "Długość (min)",
     col = "darkblue")

Można zauważyć wyraźne zagęszczenie punktów danych w okolicy wartości 100 i 30, co może wskazywać na większą liczbę rekordów charakteryzującą się długością produkcji w okolicach tych wartości.

Spójrzmy jak wygląda wykres pudełkowy (ramka-wąsy) dla tej zmiennej.

par(bg = "#F5F5F5")
boxplot(x = titles$runtime, boxwex = 0.5, col = c("lightblue"),
        main = "Box Plot - Długość produkcji",
        ylab = "Długość produkcji (min)",
        ylim = c(0, 250))

Na pierwszy rzut oka, można zauważyć, że występują jednostki nietypowe w górnej części wykresu. Prawdopodobnie są to dłuższe produkcje filmowe, natomiast taka długość filmu jest jak najbardziej do przyjęcia.

Z ciekawości spójrzmy jak wygląda wykres kwantylowy, który służy do sprawdzenia dopasowania teoretycznego rozkładu (normalnego) do zaobserwowanych danych. Typ wykresu kwantyl-kwantyl to jeden z najczęściej wykorzystywanych wykresów do graficznego testowania normalności rozkładu.

par(bg = "#F5F5F5")
q <- qqnorm(titles$runtime, main = "Normal Q-Q Plot - Długość produkcji",
       pch = 1,
       lwd = 1,
       col = "darkcyan",
       frame = FALSE,
       xlab = "Theoretical Quantiles", ylab = "Sample Quantiles - Długość produkcji",
       plot.it = TRUE, datax = FALSE)

q + scale_color_manual(values=c("red"))

## NULL

qqline(titles$runtime, datax = FALSE, distribution = qnorm,
       probs = c(0.25, 0.75), qtype = 7, col = "red", lwd = 2)

Po powyższym wykresie możemy wywnioskować, że że w badanym zbiorze występuje stosunkowo dużo jednostek skupionych w mniejszych wartościach - zauważyć można niedopasowanie do czerwonej linii.

Gdyby punkty danych znajdowały się idealnie na pokazanej linii, oznaczałoby to, że rozkład zmiennej jest dobrze dopasowany do rozkładu teoretycznego - normalnego.

W celu weryfikacji tych obserwacji spójrzmy jak przedstawia się histogram zmiennej runtime.

wykres <- ggplot(titles, aes(x = runtime, fill = type)) + geom_histogram(binwidth = 15) + xlab(label = "Długość produkcji") + ylab(label = "Liczebność") + ggtitle("Histogram liczebności pod \n względem długości i typu produkcji") +
theme(plot.title = element_text(color="black", size=14, face="bold.italic",    hjust = 0.5),
    axis.title.x = element_text(color="black", size=14, face="bold"),
    axis.title.y = element_text(color="black", size=14, face="bold"),
    axis.line = element_line(colour = "black", size = 1, linetype = "solid"),
    axis.text.x = element_text(face = "bold.italic", color="black", size=11),
    axis.text.y = element_text(face = "bold.italic", color="black", size=11),
    plot.background = element_rect(fill = "gray"))

wykres + scale_fill_manual(values = c("pink", "lightblue")) + theme(panel.background = element_rect(fill = "#EBEBEB"))

Powyższy wykres potwierdza nasze przypuszczenia. Można zasugerować, że powyższy histogram ma formę bimodalna - występują dwa główne skupiska jednostek (w okolicach wartości 30 i 100). Jest to również dobrze pokazane na wcześniej pokazanym wykresie punktowym.

Dodatkowo widać wyraźną różnice w długości dla typu produkcji - niższe wartości dla serialów i krótszych programów (kolor niebieski), natomiast większe wartości dla filmów (kolor różowy).

Kolejna zmienna seasons przedstawia liczbę sezonów w naszych produkcjach.

summary(titles$seasons)

##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max.    NA's 
##   1.000   1.000   1.000   2.163   2.000  42.000    3744

nrow(titles[is.na(titles$seasons) & titles$type != "MOVIE", ])

## [1] 0

W podsumowaniu możemy, zauważyć dużą liczbę warości NA, jednak wszystkie te wartości przypisane są do filmów, które nie posiadają sezonów, co wskazuje na to, że z logicznego punktu widzenia jest to dla nich poprawna wartość.

Jeżeli chodzi zaś o seriale - możemy zauważyć, że liczba sezonów jest w przedziale od 1 do 42, a średnia ilość sezonów w serialach jest równa 2.

table(titles$seasons)

## 
##    1    2    3    4    5    6    7    8    9   10   11   12   13   14   15   16 
## 1221  389  187  120   79   36   18   11    9    6    8    4    2    1    3    1 
##   19   20   21   24   25   29   32   37   39   42 
##    1    1    1    2    1    1    1    1    1    1

Przykładowo zweryfikujmy tytuły, które mają więcej niż 10 sezonów.

na.omit(titles[titles$seasons > 10, "title"])

## # A tibble: 30 × 1
##    title           
##    <chr>           
##  1 Thomas & Friends
##  2 Wheel of Fortune
##  3 Fireman Sam     
##  4 Survivor        
##  5 Pokémon         
##  6 One Piece       
##  7 The Challenge   
##  8 Power Rangers   
##  9 All That        
## 10 Barney & Friends
## # ℹ 20 more rows

Wszystkie wartości wydają się być poprawne po zweryfikowaniu ich w odpowiednich źródłach.

Większość seriali ma jednak 1 sezon i jest ich aż 1221.

Zmienna imdb_score odzwierciedla oceny, które osiągneły dane produkcje od publiczności/użytkowników portalu IMDB.

summary(titles$imdb_score)

##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max.    NA's 
##   1.500   5.800   6.600   6.511   7.300   9.600     482

Produkcje zostały ocenione na platformie indb. Produkcje w naszym zbiorze danych uzyskały oceny od 1,5 (minimalna uzyskana wartość) do 9,6 (maksymalna uzyskana wartość).

Część z produkcji prawdopodobnie nie została oceniona i mają one wartość NA.

Dla lepszej wizualizacji wyników, dokonany został podział wyników na kategorie:

score_cut <- cut(titles$imdb_score, 
                breaks = c(-Inf, 2, 3, 4, 5, 6, 7, 8, 9, Inf),
                labels = c('<=2','2-3', '3-4','4-5','5-6','6-7','7-8','8-9', '>9'),
                include.lowest = TRUE)

score_cut[is.na(score_cut)] <- "NA"

## Warning in `[<-.factor`(`*tmp*`, is.na(score_cut), value = "NA"): niepoprawny
## poziom czynnika, wygenerowano wartość NA

score_cut <- factor(score_cut, levels = c('<=2','2-3', '3-4','4-5','5-6','6-7','7-8','8-9', '>9'))

score_data <- data.frame(score_cut)

wykres_score <- ggplot(data = score_data, aes(x = score_cut, fill = score_cut)) +
  geom_bar(color = "black") +  
  geom_text(aes(label = after_stat(count)), stat = "count", vjust = -0.5, color = "black") +  
  labs(x = "Ocena", y = "Liczebność", title = "Wykres liczebności produkcji \n w poszczególnych kategoriach ocen IMBD") +
  scale_fill_brewer(palette = "Set3") +
  scale_x_discrete(drop = FALSE) +  
  scale_y_continuous(expand = expansion(mult = c(0.09, 0.09))) +  
  theme_minimal() +  
  theme(
    plot.title = element_text(color = "black", size = 16, face = "bold", hjust = 0.5), 
    axis.text = element_text(color = "black", size = 12, face = "bold"),  
    axis.title = element_text(color = "black", size = 14, face = "bold"), 
    panel.background = element_rect(fill = "#EBEBEB"),  
    plot.background = element_rect(fill = "#F5F5F5")  
  )

print(wykres_score)

Możemy zauważyć, że najwięcej produkcji ma ocenę w przedziale od 6 do 7, z kolei najmniej jest produkcji które mają ocenę poniżej bądź równą 2.

Tak jak zauważyliśmy wcześniej część produkcji nie zostala prawdopodobnie oceniona (482 - NA).

Możemy jeszcze zobaczyć, które produkcje mają najniższe i najwyższe oceny.

Najniżej oceniane:

na.omit(titles[titles$imdb_score <=2, "title"])

## # A tibble: 8 × 1
##   title                            
##   <chr>                            
## 1 FRED 3: Camp Fred                
## 2 Himmatwala                       
## 3 Kyaa Kool Hain Hum 3             
## 4 Aerials                          
## 5 Hajwala: The Missing Engine      
## 6 Me Against You: Mr. S's Vendetta 
## 7 Thomas & Friends: All Engines Go!
## 8 He's Expecting

Najwyżej oceniane:

na.omit(titles[titles$imdb_score >9, "title"])

## # A tibble: 11 × 1
##    title                            
##    <chr>                            
##  1 Breaking Bad                     
##  2 Avatar: The Last Airbender       
##  3 Khawatir                         
##  4 Chhota Bheem & Krishna vs Zimbara
##  5 Reply 1988                       
##  6 My Mister                        
##  7 #ABtalks                         
##  8 The Last Dance                   
##  9 Our Planet                       
## 10 Kota Factory                     
## 11 Major

Kolejna zmienna imdb_votes jest w pewien sposób połączona z poprzednią, ponieważ mówi nam ile osób oceniło konkretną produkcję.

Jest to również istotna informacja w przypadku weryfikacji oceny produkcji. Należy mieć na uwadzę jak duża próba przyczyniła się na ostateczny wynik (czy była to jedna zła ocena, która negatywnie wpłyneła na ranking, czy więcej osób podzieliło takie zdanie).

summary(titles$imdb_votes)

##      Min.   1st Qu.    Median      Mean   3rd Qu.      Max.      NA's 
##       5.0     516.8    2233.5   23439.4    9494.0 2294231.0       498

Możemy sprawdzić jaka produkcja, została najczęściej i najrzadziej oceniana przez użytkowników.

max(titles$imdb_votes, na.rm = TRUE)

## [1] 2294231

min(titles$imdb_votes, na.rm = TRUE)

## [1] 5

Największą liczba uzyskanych ocen to 2294231, natomiast najmniejsza liczba uzyskanych ocen to 5.

Sprawdźmy zatem, jakie są to tytuły (może być tak, że jest kilka produkcji z najmniejszą/największą liczbą ocen).

na.omit(titles[titles$imdb_votes == '2294231', "title"])

## # A tibble: 1 × 1
##   title    
##   <chr>    
## 1 Inception

na.omit(titles[titles$imdb_votes == '5', "title"])

## # A tibble: 6 × 1
##   title                      
##   <chr>                      
## 1 The Birth Reborn 2         
## 2 Sitara                     
## 3 Dear Affy                  
## 4 JAPAN SINKS: People of Hope
## 5 The Mystic River           
## 6 Let's Eat

Najwięcej osób więc oceniło produkcje “Inception”, a najmniej “The Birth Reborn 2”, “Sitara”, “Dear Affy”, “JAPAN SINKS: People of Hope”, “The Mystic River” oraz “Let’s Eat”.

Możemy dodatkowo sprawdzić, ile głosów otrzymały produkcje, które są najlepiej i najgorzej oceniane w naszym zbiorze danych.

Najgorzej oceniane:

subset(titles,title == 'FRED 3: Camp Fred')$imdb_votes

## [1] 2654

subset(titles,title == 'Himmatwala')$imdb_votes

## [1] 8648

subset(titles,title == 'Kyaa Kool Hain Hum 3')$imdb_votes

## [1] 4356

subset(titles,title == 'Aerials')$imdb_votes

## [1] 388

subset(titles,title == "Hajwala: The Missing Engine")$imdb_votes

## [1] 255

subset(titles,title == "Me Against You: Mr. S's Vendetta")$imdb_votes

## [1] 370

subset(titles,title == "Thomas & Friends: All Engines Go!")$imdb_votes

## [1] 555

subset(titles,title == "He's Expecting")$imdb_votes

## [1] 3019

Wnioski: Niskie oceny nie są spowodowane małą liczbą ocen (małą próbą). Stosunkowo dużo osób nisko oceniło konkretne produkcje. Sprawdźmy więc jak wygląda to dla produkcji najwyżej ocenianych.

Najlepiej oceniane:

subset(titles, title == "Breaking Bad")$imdb_votes

## [1] 1775990

subset(titles, title == "Avatar: The Last Airbender")$imdb_votes

## [1] 303666

subset(titles, title == "Khawatir")$imdb_votes

## [1] 3115

subset(titles, title == "Chhota Bheem & Krishna vs Zimbara")$imdb_votes

## [1] 16

subset(titles, title == "Reply 1988")$imdb_votes

## [1] 6718

subset(titles, title == "My Mister")$imdb_votes

## [1] 6043

subset(titles, title == "#ABtalks")$imdb_votes

## [1] 7

subset(titles, title == "The Last Dance")$imdb_votes

## [1] 115915

subset(titles, title == "Our Planet")$imdb_votes

## [1] 42259

subset(titles, title == "Kota Factory")$imdb_votes

## [1] 69316

subset(titles, title == "Major")$imdb_votes

## [1] 7576

Wnioski: Możemy zauważyć, że większość produkcji ma stosunkowo dużo ocen. Tylko dwie z nich mają ich bardzo mało: “Chhota Bheem & Krishna vs Zimbara” oraz “#ABtalks”. Właśnie dla nich wysokie oceny mogą być spowodowane preferencjami, konkretnych jednostek, które wzieły udział w ocenieniu tych produkcji.

Zmienna tmdb_popularity mówi nam o popularności na platformie TMDB.

summary(titles$tmdb_popularity)

##      Min.   1st Qu.    Median      Mean   3rd Qu.      Max.      NA's 
##    0.0094    2.7285    6.8210   22.6379   16.5900 2274.0440        91

Uwaga: Popularność na stronie TMBD jest mierzona specjalnym wewnętrznym algorytmem, który bierze po uwagę inne zmienne takie jak liczba ocen, liczba odsłon, liczba zaznaczeń produkcji jako ulubionej / do obejrzenia, przyrot oglądalności na przestrzeni czasu etc. Ponieważ nie mamy dostępu do oficjalnych informacji na temat tego algorytmu, skupimy się na bezpośrednim wykorzystaniu tej zmiennej bez wglądu w jej specyfikę.

Sprawdżmy, jaka produkcja jest najbardziej i najmniej popularna. Możemy zweryfikować to z podziałem na filmy oraz seriale/produkcje.

Film najbardziej popularny:

movies <- subset(titles, type == "MOVIE")
max_popularity_index <- which.max(movies$tmdb_popularity)
movies[max_popularity_index, "title"]

## # A tibble: 1 × 1
##   title      
##   <chr>      
## 1 Incantation

Film najmniej popularny:

min_popularity_index <- which.min(movies$tmdb_popularity)
movies[min_popularity_index, "title"]

## # A tibble: 1 × 1
##   title                              
##   <chr>                              
## 1 100 Things to Do Before High School

Serial/program najbardziej popularny:

show <- subset(titles, type == "SHOW")
max_popularity_index <- which.max(show$tmdb_popularity)
show[max_popularity_index, "title"]

## # A tibble: 1 × 1
##   title          
##   <chr>          
## 1 Stranger Things

Serial/program najmniej popularny:

min_popularity_index <- which.min(show$tmdb_popularity)
show[min_popularity_index, "title"]

## # A tibble: 1 × 1
##   title                              
##   <chr>                              
## 1 Five Came Back: The Reference Films

Dodatkowo spójrzmy na wykresy poniżej:

par(bg = "#F5F5F5")
plot(titles$tmdb_popularity,
     lty = 2,
     lwd = 1,
     main = "Wskaźnik popularności TMDB dla poszczególnych obserwacji",
     col.main = "Black",
     xlab = "Obserwacja",
     ylab = "Wskaźnik popularności TMDB",
     col = "darkblue")

par(bg = "#F5F5F5")
q <- qqnorm(titles$tmdb_popularity, main = "Normal Q-Q Plot - titles$tmdb_popularity",
       pch = 1,
       lwd = 1,
       col = "darkcyan",
       frame = FALSE,
       xlab = "Theoretical Quantiles", ylab = "Sample Quantiles - titles$tmdb_popularity",
       plot.it = TRUE, datax = FALSE)

q + scale_color_manual(values=c("red"))

## NULL

qqline(titles$runtime, datax = FALSE, distribution = qnorm,
       probs = c(0.25, 0.75), qtype = 7, col = "red", lwd = 2)

Po powyższych wykresach możemy stwierdzić, że rozkład badanej zmiennej charakteryzuje się znacznie “dłuższym prawym ogonem”, co oznacza, że występują jednostki osiągające stosunkowo wyższe wartości od pozostałych.

Inaczej mówiąc występuje bardzo dużo jednostek wyróżniających się nietypowo wysoką wartościa popularności. Niestety ze względu na brak wiedzy o sposobie przygotowania tej miary, możemy tylko dewagować, które czynniki wpłyneły na tak wysoką lub niską wartość dla poszczególnych tytułów.

summary(titles$tmdb_popularity)

##      Min.   1st Qu.    Median      Mean   3rd Qu.      Max.      NA's 
##    0.0094    2.7285    6.8210   22.6379   16.5900 2274.0440        91

Patrząc na powyższe podstawowe statystyki, można stwierdzić, że znaczna większość jednostek ze zbioru danych przyjmuje wartości stosunkowo małe (w okolicach od 3 do 16). Jednostki nietypowe znacznie wpływają na średnią, co również widać w powyższej tabeli - jest znacznie wyższa niż mediana.

Ostatnia zmienna w zbiorze titles to tmdb_score, która mówi nam o ocenie na platformie TMDB (jest to analogiczna zmienna do imdb_score).

summary(titles$tmdb_score)

##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max.    NA's 
##   0.500   6.100   6.900   6.829   7.537  10.000     311

Produkcje z naszego zbioru danych zostały ocenione na platformie TMBD i zakres ocen tych konkretnych produkcji mieści się w zakresie od 0,5 do 10. Część z produkcji prawdopodobnie nie zostały ocenione i mają wartość NA (311).

Dla lepszej wizualizacji wyników, dokonany został podział ocen na kategorie:

score_cut <- cut(titles$tmdb_score, 
                breaks = c(-Inf, 1, 2, 3, 4, 5, 6, 7, 8, 9, Inf),
                labels = c('<=1','1-2','2-3', '3-4','4-5','5-6','6-7','7-8','8-9', '>9'),
                include.lowest = TRUE)

score_cut[is.na(score_cut)] <- "NA"

## Warning in `[<-.factor`(`*tmp*`, is.na(score_cut), value = "NA"): niepoprawny
## poziom czynnika, wygenerowano wartość NA

score_cut <- factor(score_cut, levels = c('<=1','1-2','2-3', '3-4','4-5','5-6','6-7','7-8','8-9', '>9'))

score_data <- data.frame(score_cut)

wykres_score <- ggplot(data = score_data, aes(x = score_cut, fill = score_cut)) +
  geom_bar(color = "black") +  
  geom_text(aes(label = after_stat(count)), stat = "count", vjust = -0.5, color = "black") +  
  labs(x = "Ocena", y = "Liczebność", title = "Wykres liczebności produkcji \n w poszczególnych kategoriach ocen TMBD") +
  scale_fill_brewer(palette = "Set3") +
  scale_x_discrete(drop = FALSE) +  
  scale_y_continuous(expand = expansion(mult = c(0.09, 0.09))) +  
  theme_minimal() +  
  theme(
    plot.title = element_text(color = "black", size = 16, face = "bold", hjust = 0.5), 
    axis.text = element_text(color = "black", size = 12, face = "bold"),  
    axis.title = element_text(color = "black", size = 14, face = "bold"), 
    panel.background = element_rect(fill = "#EBEBEB"),  
    plot.background = element_rect(fill = "#F5F5F5")  
  )

print(wykres_score)

Możemy zauważyć, że najwięcej produkcji ma ocenę w przedziale od 6 do 7 i 7-8, z kolei najmniej jest produkcji które mają ocenę poniżej bądź równą 1. Tak jak zauważyliśmy wcześniej część produkcji nie zostala prawdopodobnie oceniona (311).

Możemy również zobaczyć, które produkcje mają najniższe i najwyższe oceny.

Najniżej oceniane:

na.omit(titles[titles$tmdb_score <=1, "title"])

## # A tibble: 11 × 1
##    title                                 
##    <chr>                                 
##  1 Inborn Pair                           
##  2 Beyblade Burst Turbo                  
##  3 What She Put on the Table             
##  4 DTC –Yukemuri Junjo Hen– from HiGH&LOW
##  5 Bonboné                               
##  6 Definition Please                     
##  7 Horrid Henry's Gross Day Out          
##  8 El límite infinito                    
##  9 Queer Eye Germany                     
## 10 Mommy Issues                          
## 11 Mad Crazy Colombian Comedians

min_score_index <- which.min(titles$tmdb_score)
titles[min_score_index, "title"]

## # A tibble: 1 × 1
##   title               
##   <chr>               
## 1 Beyblade Burst Turbo

Najwyżej oceniane:

na.omit(titles[titles$tmdb_score == 10, "title"])

## # A tibble: 75 × 1
##    title                                      
##    <chr>                                      
##  1 Pink Zone                                  
##  2 Little Baby Bum                            
##  3 Dharmakshetra                              
##  4 Raja, Rasoi Aur Anya Kahaniyaan            
##  5 The Haunted House                          
##  6 Rainbow Ruby                               
##  7 Thomas & Friends: Full Steam To The Rescue!
##  8 Transformers: Rescue Bots Academy          
##  9 Rainbow Rangers                            
## 10 Unrequited Love                            
## # ℹ 65 more rows

Produkcji ocenianych na 10 na platformie TMDB jest aż 75.

Zbiór danych - Credits

Odnosząc się do zbioru danych dotyczących aktorów i reżyserów, możemy zidentyfikować na przykład osobę, która wzięła udział w największej ilości produkcji i w jakim charakterze (aktor/reżyser). Możemy również sprawdzić stosunek aktorów do reżyserów w naszych danych, albo ogólną ilość osób występująca w zbiorze danych.

Na początek zweryfikujmy osoby (zmienna name), które wystąpiły najwięcej i najmniej razy w naszym zbiorze danych. Dodatkowo podzielmy poszukiwania, ze względu na to czy byli to aktorzy, czy reżyserowie (zmienna role).

Aktorzy - najczęściej:

actor_credits <- subset(credits, role == "ACTOR")
actor_name_counts <- table(actor_credits$name)
max_actor_frequency <- max(actor_name_counts)
most_frequent_actor_names <- names(actor_name_counts[actor_name_counts == max_actor_frequency])
most_frequent_actor_counts <- actor_name_counts[actor_name_counts == max_actor_frequency]
print(most_frequent_actor_counts)

## 
##         Boman Irani Kareena Kapoor Khan 
##                  25                  25

Boman Irani oraz Kareena Kapoor Khan to aktorzy, którzy pojawili się 25 razy (najwięcej w naszym zbiorze danych).

Aktorzy - najmniej:

actor_credits <- subset(credits, role == "ACTOR")
actor_name_counts <- table(actor_credits$name)
min_actor_frequency <- min(actor_name_counts)
least_frequent_actor_names <- names(actor_name_counts[actor_name_counts == min_actor_frequency])
least_frequent_actor_counts <- actor_name_counts[actor_name_counts == min_actor_frequency]
length(least_frequent_actor_counts)

## [1] 40007

Okazuje się, że ponad połowa rekordów w zbiorze danych (40007) dotyczy aktorów, którzy wsytąpili tylko raz w jakiejś produkcji.

Reżyser - najczęściej:

director_credits <- subset(credits, role == "DIRECTOR")
director_name_counts <- table(director_credits$name)
max_director_frequency <- max(director_name_counts)
most_frequent_director_names <- names(director_name_counts[director_name_counts == max_director_frequency])
most_frequent_director_counts <- director_name_counts[director_name_counts == max_director_frequency]
print(most_frequent_director_counts)

## Raúl Campos 
##          20

Raúl Campos to osoba, która pełniła funkcje reżysera w największej liczbie produkcji (20) w naszym zbiorze danych.

Reżyser - najmniej:

director_credits <- subset(credits, role == "DIRECTOR")
director_name_counts <- table(director_credits$name)
min_director_frequency <- min(director_name_counts)
least_frequent_director_names <- names(director_name_counts[director_name_counts == min_director_frequency])
least_frequent_director_counts <- director_name_counts[director_name_counts == min_director_frequency]
length(least_frequent_director_counts)

## [1] 2822

Prawie 3 tysiące rekordów obejmuje udział reżyserów w tylko jednej produkcji.

Zmienna ****person_id*** - mówi nam o unikatowym numerze id dla każdej osoby występującej w zbiorze danych.

length(credits$person_id)

## [1] 77801

length(unique(credits$person_id))

## [1] 54589

W naszym zbiorze danych jest 77801 rekordów, natomiast 54589 z nich są unikatowe pod względem zmiennej person_id. Wynikać to może, przez to, że rekordy tych samych aktorów pojawiają się kilkurotnie w zależności od liczby wsytąpień danego aktora w innych produkcjach. Analogiczna sytuacja może dotyczyć reżyserów, którzy mogą być odpowiedzialni za więcej niż 1 produkcję.

table(credits$role)

## 
##    ACTOR DIRECTOR 
##    73251     4550

A <- table(credits$role, exclude = "DIRECTOR")/nrow(credits) * 100
D <- table(credits$role, exclude = "ACTOR")/nrow(credits) * 100
A

## 
##    ACTOR 
## 94.15175

## 
## DIRECTOR 
## 5.848254

Zdecydowana większość w naszym zbiorze to aktorzy (ok. 95% całego zbioru), jest to jedank zrozumiałe ze względu na dużą ilość osób które z reguły występują w produkcjach. Należy również pamiętać, że są tu brane pod uwagę te same osoby, które występują w różnych produkcjach. Zatem badana jest tutaj ogólna struktura zbioru danych ze względu na osobne rekordy.

Struktura_type <- c(A, D)

pie_colors <- c("#FF9999", "#66B2FF")
par(bg = "#F5F5F5")

result <- pie(Struktura_type,
              main = "Struktura występowania rekordów (aktor vs. reżyser) \n w zbiorze danych (z duplikatami)",
              labels = c("ACTOR 94.2%", "DIRECTOR 5.8%"),
              col = pie_colors,
              border = "white",
              clockwise = TRUE,
              init.angle = 90,
              cex.main = 1.1,
              cex.lab = 1.2
)

legend("topright", c("Actor 94.2%", "Director 5.8%"), 
       cex = 1.2, fill = pie_colors, bty = "n")

print(result)

## NULL

Sprawdźmy zatem, jak przedstawia się struktura zbioru danych, natomiast dla realnych unikatowych wartości pod względem id każdej z osób.

unique_credits <- credits %>%
  distinct(id, .keep_all = TRUE)

A <- table(unique_credits$role, exclude = "DIRECTOR")/nrow(unique_credits) * 100
D <- table(unique_credits$role, exclude = "ACTOR")/nrow(unique_credits) * 100
A

## 
##    ACTOR 
## 97.28548

## 
## DIRECTOR 
##  2.71452

Struktura_type <- c(A, D)

pie_colors <- c("#FF9999", "#66B2FF")
par(bg = "#F5F5F5")

result <- pie(Struktura_type,
              main = "Struktura występowania funkcji osób (aktor vs. reżyser) \n w zbiorze danych (bez duplikatów)",
              labels = c("ACTOR 94.2%", "DIRECTOR 5.8%"),
              col = pie_colors,
              border = "white",
              clockwise = TRUE,
              init.angle = 90,
              cex.main = 1.1,
              cex.lab = 1.2
)

legend("topright", c("Actor 97.3%", "Director 2.7%"), 
       cex = 1.2, fill = pie_colors, bty = "n")

print(result)

## NULL

Struktura wygląda bardzo podobnie. Różnice są minimalne (większy odsetek aktorów i mniejszy odsetek reżyserów niż poprzednio).

Braki danych i modyfikacja zbioru danych:

Na samym pczątku wróćmy do tematu, który poruszyliśmy w poprzedniej części projektu. Zweryfikowaliśmy, że takich produkcji, które trwają 0 minut jest zaledwie 14 w naszym zbiorze, który liczy w sumie 5850 rekordów, a więc jest to bardzo mały procent naszych danych (tylko 0,24% całego zbioru danych).

titles0 <- titles$title[titles$runtime == 0]

length(titles0)

## [1] 14

(length(titles0)*100)/length(titles$runtime)

## [1] 0.2393162

titles0

##  [1] "Pecados capitales"                   "Pink Zone"                          
##  [3] "La Niña"                             "Sons of the Caliphate"              
##  [5] "Borges"                              "Emily's Wonder Lab"                 
##  [7] "Nailed It! Germany"                  "นางสาวก้นครัว"                        
##  [9] "Bullsh*t the Game Show"              "Back to 15"                         
## [11] "Storybots Laugh Learn Sing"          "Vendetta: Truth, Lies and The Mafia"
## [13] "Pedal to Metal"                      "Word Party Presents: Math!"

W związku z powyższym , usuńmy te rekordy.

titles <- titles[!titles$title %in% titles0, ]

Spójrzmy jak prezentują się braki danych wg poszczególnych zmiennych w dwóch zbiorach danych:

NA_COUNTS_credits <- colSums(is.na(credits))
print(NA_COUNTS_credits)

## person_id        id      name character      role 
##         0         0         0      9772         0

W zbiorze credits braki danych widnieją w zmiennej character. Reszta zmiennych nie zawiera braków.

NA_COUNTS_titles <- colSums(is.na(titles))
print(NA_COUNTS_titles)

##                   id                title                 type 
##                    0                    1                    0 
##          description         release_year    age_certification 
##                   18                    0                 2615 
##              runtime               genres production_countries 
##                    0                    0                    0 
##              seasons              imdb_id           imdb_score 
##                 3744                  401                  479 
##           imdb_votes      tmdb_popularity           tmdb_score 
##                  495                   91                  307

W zbiorze titles możemy już zauważyć znacznie więcej zmiennych, w których występują pewne braki danych. Zanim zadecydujemy jak z nimi postąpić, zweryfikujmy również podstawowe problemy, które mogą przeszkadzać nam w poprawnym przygotowaniu danych:

Sprawdzenie pustych komórek dla zmiennych:

sum(credits$person_id == "")

## [1] 0

sum(credits$id == "")

## [1] 0

sum(credits$name == "")

## [1] 0

sum(na.omit(credits$character == ""))

## [1] 0

sum(credits$role == "")

## [1] 0

sum(titles$id == "")

## [1] 0

sum(na.omit(titles$title == ""))

## [1] 0

sum(titles$type == "")

## [1] 0

sum(na.omit(titles$description == ""))

## [1] 0

sum(titles$release_year == "")

## [1] 0

sum(na.omit(titles$age_certification == ""))

## [1] 0

sum(titles$runtime == "")

## [1] 0

sum(titles$genres == "")

## [1] 0

sum(titles$production_countries== "")

## [1] 0

sum(na.omit(titles$seasons == ""))

## [1] 0

sum(na.omit(titles$imdb_id == ""))

## [1] 0

sum(na.omit(titles$imdb_score == ""))

## [1] 0

sum(na.omit(titles$imdb_votes == ""))

## [1] 0

sum(na.omit(titles$tmdb_popularity == ""))

## [1] 0

sum(na.omit(titles$tmdb_score == ""))

## [1] 0

Żadna ze zmiennych nie posiada pustych komórek.

Sprawdzenie NULL dla zmiennych:

sum(credits$person_id == "NULL")

## [1] 0

sum(credits$id == "NULL")

## [1] 0

sum(credits$name == "NULL")

## [1] 0

sum(na.omit(credits$character == "NULL"))

## [1] 0

sum(credits$role == "NULL")

## [1] 0

sum(titles$id == "NULL")

## [1] 0

sum(na.omit(titles$title == "NULL"))

## [1] 0

sum(titles$type == "NULL")

## [1] 0

sum(na.omit(titles$description == "NULL"))

## [1] 0

sum(titles$release_year == "NULL")

## [1] 0

sum(na.omit(titles$age_certification == "NULL"))

## [1] 0

sum(titles$runtime == "NULL")

## [1] 0

sum(titles$genres == "NULL")

## [1] 0

sum(titles$production_countries== "NULL")

## [1] 0

sum(na.omit(titles$seasons == "NULL"))

## [1] 0

sum(na.omit(titles$imdb_id == "NULL"))

## [1] 0

sum(na.omit(titles$imdb_score == "NULL"))

## [1] 0

sum(na.omit(titles$imdb_votes == "NULL"))

## [1] 0

sum(na.omit(titles$tmdb_popularity == "NULL"))

## [1] 0

sum(na.omit(titles$tmdb_score == "NULL"))

## [1] 0

Żadna zmienna nie posiada wartości NULL w zbiorach danych.

Sprawdzenie komórek, które zawierają braki informacji w postaci [] dla zmiennych:

sum(credits$person_id == "[]")

## [1] 0

sum(credits$id == "[]")

## [1] 0

sum(credits$name == "[]")

## [1] 0

sum(na.omit(credits$character == "[]"))

## [1] 0

sum(credits$role == "[]")

## [1] 0

sum(titles$id == "[]")

## [1] 0

sum(na.omit(titles$title == "[]"))

## [1] 0

sum(titles$type == "[]")

## [1] 0

sum(na.omit(titles$description == "[]"))

## [1] 0

sum(titles$release_year == "[]")

## [1] 0

sum(na.omit(titles$age_certification == "[]"))

## [1] 0

sum(titles$runtime == "[]")

## [1] 0

sum(titles$genres == "[]")

## [1] 58

sum(titles$production_countries== "[]")

## [1] 227

sum(na.omit(titles$seasons == "[]"))

## [1] 0

sum(na.omit(titles$imdb_id == "[]"))

## [1] 0

sum(na.omit(titles$imdb_score == "[]"))

## [1] 0

sum(na.omit(titles$imdb_votes == "[]"))

## [1] 0

sum(na.omit(titles$tmdb_popularity == "[]"))

## [1] 0

sum(na.omit(titles$tmdb_score == "[]"))

## [1] 0

Część naszych zmiennych zawiera komórki, w której widnieje [] - zamieńmy je na NA:

titles$genres <- ifelse(titles$genres  == "[]", NA, titles$genres)
titles$production_countries <- ifelse(titles$production_countries == "[]", NA, titles$production_countries)

Spójrzmy ponownie jak prezentują się braki danych:

macierz_danych<- as.matrix(credits)

plot_missing<-aggr(macierz_danych, col=c('darkgrey','red'),
 numbers=TRUE, sortVars=TRUE,
 labels=names(macierz_danych), cex.axis=0.6,
 cex.lab=1.5,
gap=1, ylab=c('Braki',"Wzór braków"))

## 
##  Variables sorted by number of missings: 
##   Variable     Count
##  character 0.1256025
##  person_id 0.0000000
##         id 0.0000000
##       name 0.0000000
##       role 0.0000000

Wykres potwierdza wcześniej przedstawioną tabelę z liczbą braków danych wg poszczególnych zmiennych.

W zbiorze credits występują braki danych tylko w zmiennej character. Nie pojawiły się rekordy z różnymi kombinacjami braków danych.

NA_COUNTS_credits[4]

## character 
##      9772

nrow(credits)

## [1] 77801

NA_COUNTS_credits[4] / nrow(credits) * 100

## character 
##  12.56025

Niecałe 13% wszystkich rekordów zbioru danych, posiada brak danych w zmiennej character. Na chwile obecną nie jest to konieczne, aby usuwać lub imputować dane, ze względu na główne cele naszej analizy. Jeżeli w trakcie projektu będzie potrzeba poradzić sobie z takimi brakami, to wrócimy do tego zagadnienia. Na chwilę obecną nie zmieniamy danych. Pamiętajmy również, że w zbiorze wsytępują reżyserowie, którzy nie powinni mieć przypisanej zmiennej “character”, dlatego też nie powinniśmy się teraz tym przejmować.

macierz_danych<- as.matrix(titles)

plot_missing<-aggr(macierz_danych, col=c('darkgrey','red'),
 numbers=TRUE, sortVars=TRUE,
 labels=names(macierz_danych), cex.axis=0.6,
 cex.lab=1.5,
gap=1, ylab=c('Braki',"Wzór braków"))

## Warning in plot.aggr(res, ...): not enough vertical space to display
## frequencies (too many combinations)

## 
##  Variables sorted by number of missings: 
##              Variable        Count
##               seasons 0.6415352981
##     age_certification 0.4480808773
##            imdb_votes 0.0848183687
##            imdb_score 0.0820767649
##               imdb_id 0.0687114462
##            tmdb_score 0.0526045236
##  production_countries 0.0388965045
##       tmdb_popularity 0.0155928718
##                genres 0.0099383139
##           description 0.0030843043
##                 title 0.0001713502
##                    id 0.0000000000
##                  type 0.0000000000
##          release_year 0.0000000000
##               runtime 0.0000000000

Na powyższym wykresie wyraźnie widać, że w zbiorze titles braki danych znajdują się w więcej niż 1 zmiennej. Ponieważ sam zbiór posiada więcej zmiennych, a braki danych występują w kilku z nich, to utworzyły się różne kombinacje braków danych, które mogą wystąpić w danym rekordzie.

Na ten moment nie będziemy usuwać danych - wrócimy do tego tematu jeżeli zajdzie potrzeba w kolejnej części projektu.

ANALIZA WŁAŚCIWA

Zanim przejdziemy do tworzenia i analizy sieci, przypomnijmy cele projektu.

Cel - opis:

W związku z powyższym, naszym celem będzie zobrazować struktury sieci aktorów i reżyserów dla poniższych kategorii:

struktura sieci aktor-reżyser dla:

serialów
mające dobre ratingi
odpowiednio duża próba (liczba) głosów, która złożyła się na rating
dodatkowa eliminacja jednostek w grafie na podstawie jednego z parametrów

struktura sieci aktor-reżyser dla:

serialów
mające złe ratingi
odpowiednio duża próba (liczba) głosów, która złożyła się na rating
dodatkowa eliminacja jednostek w grafie na podstawie jednego z parametrów

W związku, z powyższym w pierwszej kolejności musimy odpowiednio przygotować nasze zbiory danych, które będą stanowić bazę do późniejszej analizy. Należy zatem, przygotować 2 zbiory, którymi posłużymy się w kolejnej części.

1) i 2) - Dla type = SHOW

Na początku stworzymy nowy data frame zawierający połączenia między aktorami (role = “ACTOR”) a reżyserami (role = “DIRECTOR”) w zbiorze danych “credits”, gdzie te połączenia odnoszą się do tego samego serialu (tego samego “id”). Możemy to zrobić za pomocą operacji łączenia (join) w R.

# Stwórzmy nowy data frame
connections <- credits %>%
  # Wybierzmy tylko rekordy z role = "ACTOR"
  filter(role == "ACTOR") %>%
  # Wybierzmy tylko potrzebne kolumny
  select(actor_name = name, id) %>%
  # Połączmy zbiór z samym sobą (kolejny raz), by uzyskać kombinacje aktorów dla tych samych seriali
  inner_join(credits %>%
                # Wybierzmy rekordy z role = "DIRECTOR"
                filter(role == "DIRECTOR") %>%
                # Wybierzmy tylko potrzebne kolumny
                select(director_name = name, id),
              by = "id")

## Warning in inner_join(., credits %>% filter(role == "DIRECTOR") %>% select(director_name = name, : Detected an unexpected many-to-many relationship between `x` and `y`.
## ℹ Row 59 of `x` matches multiple rows in `y`.
## ℹ Row 1 of `y` matches multiple rows in `x`.
## ℹ If a many-to-many relationship is expected, set `relationship =
##   "many-to-many"` to silence this warning.

# Połączmy zbiór connections ze zbiorem titles, aby odfiltrować rekordy odnoszące się do "SHOW"
shows <- connections %>%
  inner_join(titles %>%
               select(id, type, imdb_votes, imdb_score),
             by = "id") %>%
  filter(type == "SHOW")

head(shows)

## # A tibble: 6 × 6
##   actor_name     id      director_name   type  imdb_votes imdb_score
##   <chr>          <chr>   <chr>           <chr>      <dbl>      <dbl>
## 1 Graham Chapman ts45948 Ian MacNaughton SHOW        2151        8.1
## 2 John Cleese    ts45948 Ian MacNaughton SHOW        2151        8.1
## 3 Eric Idle      ts45948 Ian MacNaughton SHOW        2151        8.1
## 4 Terry Jones    ts45948 Ian MacNaughton SHOW        2151        8.1
## 5 Michael Palin  ts45948 Ian MacNaughton SHOW        2151        8.1
## 6 Steven Kynman  ts2760  Gary Andrews    SHOW        1785        6.1

Teraz zawęzimy zbiór shows do tych rekordów, które zawierają odpowiednią liczbę głosów i nie posiadają braków danych. Jest to istotne ze względu na precyzyjność badania, aby wyfiltrować realne głosy i nie imputować zmiennej odnoszącej się do liczby głosów, aby mieć pewność, że dane będą obrazować tylko prawdziwe i wiarygone połączenia między aktorem i reżyserem. Wielkość zbioru pozostanie wciąż na tyle duża, aby prowadzić dalszą analizę.

Usunięcie braków danych:

shows <- shows[!is.na(shows$imdb_votes), ]
nrow(shows)

## [1] 5395

Aby, oddzielić dane, które charakteryzują się wiarygodną liczbą oddanych głosów, posłużymy się pierwszym kwartylem, aby odciąć 25% obserwacji o najmniejszej próbie osób, które oddały głos. Żeby wiedzieć jaka jest optymalna wartość pierwszego kwartyla liczby głosów, od której będziemy zostawiać rekordy w zbiorze danych, stwórzmy zbiór zawierający unikatowe rekordy serialów ze zbioru shows, aby sztucznie nie polegać na statystyce ze zbioru, w którym może widnieć kilka rekordów dotyczących tego samego filmu, lecz z inną kombinacją aktora i reżysera.

shows_votes <- shows %>%
  distinct(id, .keep_all = TRUE) %>%
  select(id, imdb_votes)

Statystyki zbioru:

summary(shows_votes$imdb_votes)

##     Min.  1st Qu.   Median     Mean  3rd Qu.     Max. 
##      5.0    502.5   1724.0   4807.6   4370.0 115915.0

Teraz możemy usunąć rekordy ze zbioru shows, które zawierają wartość zmiennej imdb_votes niższą niż 502,5.

shows <- shows %>%
  filter(imdb_votes >= 502.5)

W tym momencie, możemy stworzyć zbiór seriali, które mają odpowiednią liczbę głosów w podziale na dobre i złe ratingi.

Ponownie utwórzmy zbiór z unikatowymi rekordami serialów, które pozostały w zbiorze shows, aby decyzje o tresholdzie dla ratingu podjąc na podstawie realnych danych.

shows_score <- shows %>%
  distinct(id, .keep_all = TRUE) %>%
  select(id, imdb_score)

Żeby zadecydować o odpowiednim tresholdzie, przypomnijmy poniższą wizualizację.

score_cut <- cut(shows_score$imdb_score, 
                breaks = c(-Inf, 2, 3, 4, 5, 6, 7, 8, 9, Inf),
                labels = c('<=2','2-3', '3-4','4-5','5-6','6-7','7-8','8-9', '>9'),
                include.lowest = TRUE)

score_cut[is.na(score_cut)] <- "NA"

## Warning in `[<-.factor`(`*tmp*`, is.na(score_cut), value = "NA"): niepoprawny
## poziom czynnika, wygenerowano wartość NA

score_cut <- factor(score_cut, levels = c('<=2','2-3', '3-4','4-5','5-6','6-7','7-8','8-9', '>9'))

score_data <- data.frame(score_cut)

wykres_score <- ggplot(data = score_data, aes(x = score_cut, fill = score_cut)) +
  geom_bar(color = "black") +  
  geom_text(aes(label = after_stat(count)), stat = "count", vjust = -0.5, color = "black") +  
  labs(x = "Ocena", y = "Liczebność", title = "Wykres liczebności seriali \n w poszczególnych kategoriach ocen IMBD") +
  scale_fill_brewer(palette = "Set3") +
  scale_x_discrete(drop = FALSE) +  
  scale_y_continuous(expand = expansion(mult = c(0.09, 0.09))) +  
  theme_minimal() +  
  theme(
    plot.title = element_text(color = "black", size = 16, face = "bold", hjust = 0.5), 
    axis.text = element_text(color = "black", size = 12, face = "bold"),  
    axis.title = element_text(color = "black", size = 14, face = "bold"), 
    panel.background = element_rect(fill = "#EBEBEB"),  
    plot.background = element_rect(fill = "#F5F5F5")  
  )

print(wykres_score)

Optymalnym będzie, aby podzielić zbiór na ten “gorszy” dla ocen od 7.5 w dół oraz “ten lepszy” od 7.5 w górę. Należy pamiętać, aby zachować pewien racjonalny podział, żeby w późniejszym etapie nie zostało nam zbyt mało serialów, na których podstawie zbudujemy strukturę sieci.

shows_votes_good_score <- shows %>%
  filter(imdb_score > 7.5)

head(shows_votes_good_score)

## # A tibble: 6 × 6
##   actor_name       id      director_name   type  imdb_votes imdb_score
##   <chr>            <chr>   <chr>           <chr>      <dbl>      <dbl>
## 1 Graham Chapman   ts45948 Ian MacNaughton SHOW        2151        8.1
## 2 John Cleese      ts45948 Ian MacNaughton SHOW        2151        8.1
## 3 Eric Idle        ts45948 Ian MacNaughton SHOW        2151        8.1
## 4 Terry Jones      ts45948 Ian MacNaughton SHOW        2151        8.1
## 5 Michael Palin    ts45948 Ian MacNaughton SHOW        2151        8.1
## 6 Kappei Yamaguchi ts21034 Yasunao Aoki    SHOW       15823        7.9

shows_votes_bad_score <- shows %>%
  filter(imdb_score <= 7.5)

head(shows_votes_bad_score)

## # A tibble: 6 × 6
##   actor_name      id     director_name type  imdb_votes imdb_score
##   <chr>           <chr>  <chr>         <chr>      <dbl>      <dbl>
## 1 Steven Kynman   ts2760 Gary Andrews  SHOW        1785        6.1
## 2 David Carling   ts2760 Gary Andrews  SHOW        1785        6.1
## 3 Su Douglas      ts2760 Gary Andrews  SHOW        1785        6.1
## 4 Tegwen Tucker   ts2760 Gary Andrews  SHOW        1785        6.1
## 5 Harriet Kershaw ts2760 Gary Andrews  SHOW        1785        6.1
## 6 Alex Lowe       ts2760 Gary Andrews  SHOW        1785        6.1

Usuńmy kolumnę z id, type, imdb_votes oraz imdb_score, natomiast zostawmy imiona i nazwiska aktorów i reżyserów.

shows_votes_good_score <- subset(shows_votes_good_score, select = -c(id, type, imdb_votes, imdb_score))
shows_votes_bad_score <- subset(shows_votes_bad_score, select = -c(id, type, imdb_votes, imdb_score))

Ostatecznie, zobaczmy ile rekordów liczą nasze zbiory danych.

nrow(shows_votes_good_score)

## [1] 2102

nrow(shows_votes_bad_score)

## [1] 2104

1) shows_votes_good_score

Liczba kolumn i wierszy:

dim(shows_votes_good_score)

## [1] 2102    2

Tworzenie grafu:

g_shows_votes_good_score <- graph.edgelist(as.matrix(shows_votes_good_score))

## Warning: `graph.edgelist()` was deprecated in igraph 2.0.0.
## ℹ Please use `graph_from_edgelist()` instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.

Podstawowe statystyki grafu:

Liczba węzłów/wierzchołków:

# V(g_shows_votes_good_score)
gorder(g_shows_votes_good_score)

## [1] 1608

liczba krawędzi:

# E(g_shows_votes_good_score)
gsize(g_shows_votes_good_score)

## [1] 2102

Gęstosc grafu:

graph.density(g_shows_votes_good_score, loops=F)

## Warning: `graph.density()` was deprecated in igraph 2.0.0.
## ℹ Please use `edge_density()` instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.

## [1] 0.0008134499

Komentarz: Graf nie jest “gęsty”, czyli ma niewiele krawędzi w stosunku do liczby możliwych krawędzi.

Bliskość - closeness:

c <- closeness(g_shows_votes_good_score, mode="all", weights = NA)
d <- sort(c, decreasing = TRUE)
max(d)

## [1] 1

min(d)

## [1] 0.0002214839

head(d, 5)

##    Samin Nosrat    Caroline Suh   James Acaster Daniel Lucchesi     Jon Favreau 
##               1               1               1               1               1

d <- sort(c, decreasing = FALSE)
head(d, 5)

##      Lee Ha-na    Son Eun-seo   Kim Joong-ki Baek Sung-hyun   Song Boo-Gun 
##   0.0002214839   0.0002214839   0.0002214839   0.0002214839   0.0002214839

Najniższa wartość bliskości osiągalna w naszym grafie to 0.0002214839, natomist najwyższa to 1.

Bliskość (ang. closeness) węzła nazywamy średnią długość najkrótszych ścieżek między węzłem i wszystkimi pozostałymi węzłami.

Oznacza to, że nasz graf jest stosunkowo zróżnicowany pod względem tego, czy wierzchołek jest bardziej oddalony od innych wierzchołków w grafie w obrębie tej samej skomunikowanej struktury. Występują takie, które są bardziej oddalone (nie w centrum struktury), ale również takie, które mają bardzo “szybki” dostęp do innych węzłów (są w centrum).

Pośredniczenie - betwenness:

  b <- betweenness(g_shows_votes_good_score, directed = F, weights = NA)
e <-sort(b, decreasing = TRUE)
max(e)

## [1] 45605.92

min(e)

## [1] 0

head(e, 5)

## Hong Jong-chan   Kim Won-seok   Lee Eung-bok    Kim Sok-yun    Kim Kyu-tae 
##       45605.92       43959.89       31346.16       31031.92       27362.11

e <- sort(b, decreasing = FALSE)
head(e, 5)

## Graham Chapman    John Cleese      Eric Idle    Terry Jones  Michael Palin 
##              0              0              0              0              0

Pośrednictwem (ang. betweeness) węzła nazywamy stosunek liczby najkrótszych ścieżek między dowolnymi dwoma węzłami przechodzących przez węzeł do łącznej liczby wszystkich najkrótszych ścieżek.

Wierzchołki, które mają znacznie wyższe wartości pośredniczenia w porównaniu do innych wierzchołków w tym samym grafie, są uznawane za te mające stosunkowo wysoką wartość pośredniczenia (określenie, czy dana wartość jest wysoka/niska zależy od porównania pośredniczenia z innymi węzłami w danym grafie, ponieważ, nie ma tutaj górnej granicy, którą ta miara może osiągnąć). Mogą one leżeć na wielu najkrótszych ścieżkach między innymi wierzchołkami.

Wierzchołki, które mają wartości pośredniczenia bliskie zeru, są uznawane za mające niskie pośredniczenie. Oznacza to, że rzadko leżą na najkrótszych ścieżkach między innymi wierzchołkami.

Średnia liczba krawędzi wchodzących i wychodzących z węzła/ stopień węzła:

mean(degree(g_shows_votes_good_score))

## [1] 2.614428

max(degree(g_shows_votes_good_score))

## [1] 59

min(degree(g_shows_votes_good_score))

## [1] 1

Średni stopień wierzchołka może dawać ogólne wyobrażenie o gęstości grafu. Im wyższa jest ta wartość, tym bardziej “połączony” jest graf, co oznacza, że przeciętnie wierzchołki mają więcej połączeń.

Wartość 2.614428 oznacza, że przeciętnie każdy wierzchołek w grafie ma około 2.61 połączeń.

Modyfikacja sieci:

Ponieważ, wizualizacja grafu ze wszystkimi wierzchołkami jest zbyt nieczytelna, zastosujemy jedną z metod eliminacji - filtrowanie węzłów o niskiej wartości bliskości (w tym przypadku po wstępnej analizie przyjeliśmy treshold jako wartość 0.2). Takim podejściem uzyskamy większą klarowność wizualizacji oraz strukturę, pokazującą najciekawsze połączenia w badanym ujęciu.

g_shows_votes_good_score <- delete.vertices(g_shows_votes_good_score, closeness(g_shows_votes_good_score, mode="all", weights = NA) < 0.2)

## Warning: `delete.vertices()` was deprecated in igraph 2.0.0.
## ℹ Please use `delete_vertices()` instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.

Wizualizacja sieci:

set.seed(6) # układ węzłów

vertex_info_good <- data.frame(name = V(g_shows_votes_good_score)$name, stringsAsFactors = FALSE)

vertex_info_good$color <- "gray"

vertex_info_good$color[vertex_info_good$name %in% shows_votes_good_score$actor_name & !vertex_info_good$name %in% shows_votes_good_score$director_name] <- "blue"

vertex_info_good$color[vertex_info_good$name %in% shows_votes_good_score$director_name & !vertex_info_good$name %in% shows_votes_good_score$actor_name] <- "red"

vertex_info_good$color[vertex_info_good$name %in% shows_votes_good_score$actor_name & vertex_info_good$name %in% shows_votes_good_score$director_name] <- "yellow"

V(g_shows_votes_good_score)$color <- vertex_info_good$color

plot.igraph(g_shows_votes_good_score,
            layout=layout_with_fr,
            vertex.size=9,
            vertex.label.cex=0.6,
            vertex.label.color="black",
            vertex.color=V(g_shows_votes_good_score)$color,
            edge.color="chartreuse4",
            edge.width=2,
            edge.curved=TRUE,
            edge.arrow.size=0.4,
            edge.lty="solid",
            main="Relacje w sieci pomiedzy wybranymi aktorami i reżyserami dla \n serialów o dobrym ratingu i odpowiedniej liczbie głosów")

legend("bottomright", legend=c("Actor", "Director", "Actor & Director"), col=c("blue", "red", "yellow"), pch=20, bty="n", cex=1, pt.cex=1.8)

set.seed(6)

plot.igraph(g_shows_votes_good_score,
            layout=layout_with_fr,
            vertex.size=9,
            vertex.label = NA,
            vertex.label.cex=0.6,
            vertex.label.color="black",
            vertex.color=V(g_shows_votes_good_score)$color,
            edge.color="chartreuse4",
            edge.width=2,
            edge.curved=TRUE,
            edge.arrow.size=0.4,
            edge.lty="solid",
            main="Relacje w sieci pomiedzy wybranymi aktorami i reżyserami dla \n serialów o dobrym ratingu i odpowiedniej liczbie głosów")

legend("bottomright", legend=c("Actor", "Director", "Actor & Director"), col=c("blue", "red", "yellow"), pch=20, bty="n", cex=1, pt.cex=1.8)

Ponieważ konkretne wnioski na podstawie wykresu zostaną ukazane w kolejnej części badania, sprawdźmy teraz jak przedstawiają się informacje węzłów, które wyróżniają się na powyższym wykresie kolorem żółtym - są to reżyserowie, którzy jednocześnie byli aktorami we własnej produkcji - Jon Favreau oraz Daniel Sloss.

shows[shows$actor_name == "Jon Favreau" & shows$director_name == "Jon Favreau",]

## # A tibble: 1 × 6
##   actor_name  id      director_name type  imdb_votes imdb_score
##   <chr>       <chr>   <chr>         <chr>      <dbl>      <dbl>
## 1 Jon Favreau ts91039 Jon Favreau   SHOW        5107        8.2

shows[shows$actor_name == "Daniel Sloss" & shows$director_name == "Daniel Sloss",]

## # A tibble: 1 × 6
##   actor_name   id       director_name type  imdb_votes imdb_score
##   <chr>        <chr>    <chr>         <chr>      <dbl>      <dbl>
## 1 Daniel Sloss ts321277 Daniel Sloss  SHOW        3443        8.5

Sprawdźmy osoby, które również współpracowały z tymi reżyserami

credits[credits$id == "ts91039",]

## # A tibble: 3 × 5
##   person_id id      name        character role    
##       <dbl> <chr>   <chr>       <chr>     <chr>   
## 1      1681 ts91039 Jon Favreau Himself   ACTOR   
## 2     16294 ts91039 Roy Choi    Himself   ACTOR   
## 3      1681 ts91039 Jon Favreau <NA>      DIRECTOR

credits[credits$id == "ts321277",]

## # A tibble: 3 × 5
##   person_id id       name         character role    
##       <dbl> <chr>    <chr>        <chr>     <chr>   
## 1    194892 ts321277 Daniel Sloss Himself   ACTOR   
## 2    159658 ts321277 Ryan Polito  <NA>      DIRECTOR
## 3    194892 ts321277 Daniel Sloss <NA>      DIRECTOR

Zidentyfikujmy teraz, czym charakteryzowały się seriale, za które Jon Favreau oraz Daniel Sloss byli odpowiedzialni.

table(titles[titles$id == "ts91039",])

## , , type = SHOW, description = Writer, director and food enthusiast Jon Favreau and chef Roy Choi explore food in and out of the kitchen with accomplished chefs and celebrity friends., release_year = 2019, age_certification = TV-MA, runtime = 31, genres = ['documentation'], production_countries = ['US'], seasons = 2, imdb_id = tt10359446, imdb_score = 8.2, imdb_votes = 5107, tmdb_popularity = 7.305, tmdb_score = 7.8
## 
##          title
## id        The Chef Show
##   ts91039             1

table(titles[titles$id == "ts321277",])

## , , type = SHOW, description = Comedian Daniel Sloss is ready to find the funny in some very dark topics, from the deeply personal to the truly irreverent., release_year = 2018, age_certification = TV-MA, runtime = 60, genres = ['comedy'], production_countries = ['US'], seasons = 1, imdb_id = tt8858472, imdb_score = 8.5, imdb_votes = 3443, tmdb_popularity = 1.694, tmdb_score = 8.2
## 
##           title
## id         Daniel Sloss: Live Shows
##   ts321277                        1

Obydwie produkcje zostały wykonane w Stanach i posiadają kategorie wiekową TV-MA, która oznaczała, że jest to skierowane do dorosłych (Wszyscy), zatem jest to dość szeroka publiczność. Zwróćmy również uwagę, na opis tych seriali:

table(titles[titles$id == "ts91039",][4])

## description
## Writer, director and food enthusiast Jon Favreau and chef Roy Choi explore food in and out of the kitchen with accomplished chefs and celebrity friends. 
##                                                                                                                                                        1

table(titles[titles$id == "ts321277",][4])

## description
## Comedian Daniel Sloss is ready to find the funny in some very dark topics, from the deeply personal to the truly irreverent. 
##                                                                                                                            1

Może to sugerować, że produkcje dotyczące popularnych reżyserów, którzy występują w rolach głównych, aby pokazać swoje własne przekonania i życie, są również typem produkcji, które ogląda szersza publiczność z zadowoleniem.

Sprawdźmy jak prezentują się podstawowe statystyki powyższego grafu. W tym celu została stworzona funkcja, którą wykorzystamy również dla grafu, który powstanie w kolejnej części projektu.

statystyki <- function(x) {
  Liczba_wezlow <- gorder(x) # Liczba węzłów/wierzchołków
  Liczba_krawedzi <- gsize(x) # liczba krawędzi
  Gestosc <- graph.density(x, loops=F) # Gęstosc grafu
  Max_bliskosc <- max(sort(closeness(x, mode="all", weights = NA), decreasing = TRUE)) # Max Bliskość - closeness
  Min_bliskosc <- min(sort(closeness(x, mode="all", weights = NA), decreasing = TRUE)) # Min Bliskość - closeness
  Max_posredniczenie <- max(sort(betweenness(x, directed = F, weights = NA), decreasing = TRUE)) # Max Pośredniczenie - betwenness
  Min_posredniczenie <- min(sort(betweenness(x, directed = F, weights = NA), decreasing = TRUE)) # Min Pośredniczenie - betwenness
  Mean_stopien <- mean(degree(x)) # Średnia liczba krawędzi wchodzących i wychodzących z węzła/ stopień węzła
  Max_stopien <- max(degree(x)) # Maksymalna liczba krawędzi wchodzących i wychodzących z węzła/ stopień węzła
  Min_stopien <- min(degree(x)) # Minimalna liczba krawędzi wchodzących i wychodzących z węzła/ stopień węzła
  return(c(Liczba_wezlow = Liczba_wezlow, Liczba_krawedzi = Liczba_krawedzi, Gestosc = Gestosc, Max_bliskosc = Max_bliskosc, Min_bliskosc = Min_bliskosc, Max_posredniczenie = Max_posredniczenie, Min_posredniczenie = Min_posredniczenie, Mean_stopien = Mean_stopien, Max_stopien = Max_stopien, Min_stopien = Min_stopien))
}

stats_good <- statystyki(g_shows_votes_good_score)
stats_good

##      Liczba_wezlow    Liczba_krawedzi            Gestosc       Max_bliskosc 
##        65.00000000        42.00000000         0.01009615         1.00000000 
##       Min_bliskosc Max_posredniczenie Min_posredniczenie       Mean_stopien 
##         0.20000000         3.00000000         0.00000000         1.29230769 
##        Max_stopien        Min_stopien 
##         3.00000000         0.00000000

Uwaga: Interpretacja i wnioski z powyższych statystyk zostaną pokazane w kolejnej części projektu.

2) shows_votes_bad_score

Liczba kolumn i wierszy:

dim(shows_votes_bad_score)

## [1] 2104    2

Tworzenie grafu:

g_shows_votes_bad_score <- graph.edgelist(as.matrix(shows_votes_bad_score))

Podstawowe statystyki grafu:

Liczba węzłów/wierzchołków:

# V(g_shows_votes_bad_score)
gorder(g_shows_votes_bad_score)

## [1] 1732

liczba krawędzi:

# E(g_shows_votes_bad_score)
gsize(g_shows_votes_bad_score)

## [1] 2104

Gęstosc grafu:

graph.density(g_shows_votes_bad_score, loops=F)

## [1] 0.0007017797

Komentarz: Graf nie jest “gęsty”, czyli ma niewiele krawędzi w stosunku do liczby możliwych krawędzi.

Bliskość - closeness:

c <- closeness(g_shows_votes_bad_score, mode="all", weights = NA)
d <- sort(c, decreasing = TRUE)
max(d)

## [1] 1

min(d)

## [1] 0.0003079766

head(d, 5)

## James Cromwell     Jesse Moss  Andrew Schulz     AlexxMedia     Syra Madad 
##              1              1              1              1              1

d <- sort(c, decreasing = FALSE)
head(d, 5)

##      Jung Yu-mi   Hyun Woo-seok    Park Hae-eun Kwon Young-chan     Park Se-jin 
##    0.0003079766    0.0003079766    0.0003079766    0.0003079766    0.0003079766

Najniższa wartość bliskości osiągalna w naszym grafie to 0.0003079766, natomist najwyższa to 1.

Bliskość (ang. closeness) węzła nazywamy średnią długość najkrótszych ścieżek między węzłem i wszystkimi pozostałymi węzłami.

Pośredniczenie - betwenness:

b <- betweenness(g_shows_votes_bad_score, directed = F, weights = NA)
e <-sort(b, decreasing = TRUE)
max(e)

## [1] 26092.52

min(e)

## [1] 0

head(e, 5)

## Song Hyun-wook  Kim Mi-kyeong    Oh Jin-seok  Lee Myung-woo  Kang Shin-hyo 
##       26092.52       15142.73       15063.54       13789.19       12783.10

e <- sort(b, decreasing = FALSE)
head(e, 5)

##   Steven Kynman   David Carling      Su Douglas   Tegwen Tucker Harriet Kershaw 
##               0               0               0               0               0

Średnia liczba krawędzi wchodzących i wychodzących z węzła/ stopień węzła:

mean(degree(g_shows_votes_bad_score))

## [1] 2.429561

max(degree(g_shows_votes_bad_score))

## [1] 29

min(degree(g_shows_votes_bad_score))

## [1] 1

Wartość 2.429561 oznacza, że przeciętnie każdy wierzchołek w grafie ma około 2.43 połączeń.

Modyfikacja sieci:

# g_shows_votes_bad_score <- delete.vertices(g_shows_votes_bad_score, closeness(g_shows_votes_bad_score, mode="all", weights = NA) < 0.2)
closeness_values <- closeness(g_shows_votes_bad_score, mode="all", weights = NA)
vertices_to_delete <- which(closeness_values < 0.2)
g_shows_votes_bad_score <- delete.vertices(g_shows_votes_bad_score, vertices_to_delete)

Wizualizacja sieci:

set.seed(2)

vertex_info_bad <- data.frame(name = V(g_shows_votes_bad_score)$name, stringsAsFactors = FALSE)

vertex_info_bad$color <- "gray"

vertex_info_bad$color[vertex_info_bad$name %in% shows_votes_bad_score$actor_name & !vertex_info_bad$name %in% shows_votes_bad_score$director_name] <- "blue"

vertex_info_bad$color[vertex_info_bad$name %in% shows_votes_bad_score$director_name & !vertex_info_bad$name %in% shows_votes_bad_score$actor_name] <- "red"

vertex_info_bad$color[vertex_info_bad$name %in% shows_votes_bad_score$actor_name & vertex_info_bad$name %in% shows_votes_bad_score$director_name] <- "yellow"

V(g_shows_votes_bad_score)$color <- vertex_info_bad$color

plot.igraph(g_shows_votes_bad_score,
            layout=layout_with_fr,
            vertex.size=9,
            vertex.label.cex=0.6,
            vertex.label.color="black",
            vertex.color=V(g_shows_votes_bad_score)$color,
            edge.color="chartreuse4",
            edge.width=2,
            edge.curved=TRUE,
            edge.arrow.size=0.4,
            edge.lty="solid",
            main="Relacje w sieci pomiedzy wybranymi aktorami i reżyserami dla \n serialów o złym ratingu i odpowiedniej liczbie głosów")

legend("bottomright", legend=c("Actor", "Director", "Actor & Director"), col=c("blue", "red", "yellow"), pch=20, bty="n", cex=1, pt.cex=1.8)

set.seed(2)

plot.igraph(g_shows_votes_bad_score,
            layout=layout_with_fr,
            vertex.size=9,
            vertex.label = NA,
            vertex.label.cex=0.6,
            vertex.label.color="black",
            vertex.color=V(g_shows_votes_bad_score)$color,
            edge.color="chartreuse4",
            edge.width=2,
            edge.curved=TRUE,
            edge.arrow.size=0.4,
            edge.lty="solid",
            main="Relacje w sieci pomiedzy wybranymi aktorami i reżyserami dla \n serialów o złym ratingu i odpowiedniej liczbie głosów")

legend("bottomright", legend=c("Actor", "Director", "Actor & Director"), col=c("blue", "red", "yellow"), pch=20, bty="n", cex=1, pt.cex=1.8)

Ponieważ konkretne wnioski na podstawie wykresu zostaną ukazane w kolejnej części badania, sprawdźmy teraz jak przedstawiają się informacje węzła, który wyróżnia się na powyższym wykresie kolorem żółtym - jest to reżyser, który jednocześnie był aktorem we własnej produkcji - Chris Lilley.

credits[credits$name == "Chris Lilley",]

## # A tibble: 2 × 5
##   person_id id      name         character role    
##       <dbl> <chr>   <chr>        <chr>     <chr>   
## 1    104871 ts89876 Chris Lilley <NA>      ACTOR   
## 2    104871 ts89876 Chris Lilley <NA>      DIRECTOR

Sprawdźmy osoby, które również współpracowały z tym reżyserem.

credits[credits$id == "ts89876",]

## # A tibble: 2 × 5
##   person_id id      name         character role    
##       <dbl> <chr>   <chr>        <chr>     <chr>   
## 1    104871 ts89876 Chris Lilley <NA>      ACTOR   
## 2    104871 ts89876 Chris Lilley <NA>      DIRECTOR

Wygląda na to, że w tym serialu nie było żadnych dodatkowych aktorów/reżyserów.

Zidentyfikujmy teraz, czym charakteryzował się serial, za który Chris Lilley był odpowiedzialny.

table(titles[titles$id == "ts89876",])

## , , type = SHOW, description = This mockumentary series follows the peculiar lives of six eccentric -- and sometimes obscene -- misfits who march to their own beat., release_year = 2019, age_certification = TV-MA, runtime = 36, genres = ['comedy'], production_countries = ['US'], seasons = 1, imdb_id = tt8164794, imdb_score = 6.5, imdb_votes = 3179, tmdb_popularity = 3.871, tmdb_score = 6.2
## 
##          title
## id        Lunatics
##   ts89876        1

Zwróćmy również uwagę, na opis:

table(titles[titles$id == "ts89876",][4])

## description
## This mockumentary series follows the peculiar lives of six eccentric -- and sometimes obscene -- misfits who march to their own beat. 
##                                                                                                                                     1

Ponieważ nie znamy nazwy postaci, którą grał reżyser, to nie jesteśmy w stanie stwierdzić na jakiej zasadzie Chris Lilley uczestniczył we własnej produkcji. Kategoria jako komedia wraz z opisem może sugerować na pewną “odważniejszą” produkcję.

Sprawdźmy jak prezentują się podstawowe statystyki powyższego grafu.

stats_bad <- statystyki(g_shows_votes_bad_score)
stats_bad

##      Liczba_wezlow    Liczba_krawedzi            Gestosc       Max_bliskosc 
##       87.000000000       50.000000000        0.006682705        1.000000000 
##       Min_bliskosc Max_posredniczenie Min_posredniczenie       Mean_stopien 
##        0.200000000        3.000000000        0.000000000        1.149425287 
##        Max_stopien        Min_stopien 
##        3.000000000        0.000000000

Uwaga: Interpretacja i wnioski z powyższych statystyk i wykresów zostaną pokazane w kolejnej części projektu w postaci bardziej szczegółowej.

Wizualne i opisowe porównanie sieci dla seriali o dobrym vs. złym ratingu

Porównajmy dwa grafy ze sobą na wykresach:

par(mfrow=c(1,2))

set.seed(6)

# wizualizacja 1 - dobre seriale

plot.igraph(g_shows_votes_good_score,
            layout=layout_with_fr,
            vertex.size=9,
            vertex.label = NA,
            vertex.label.cex=0.6,
            vertex.label.color="black",
            vertex.color=V(g_shows_votes_good_score)$color,
            edge.color="chartreuse4",
            edge.width=2,
            edge.curved=TRUE,
            edge.arrow.size=0.4,
            edge.lty="solid",
            main="Good shows")

legend("bottomright", legend=c("Actor", "Director", "Actor & Director"), col=c("blue", "red", "yellow"), pch=20, bty="n", cex=0.6, pt.cex=0.9)


# wizualizacja 2 - złe seriale

set.seed(2)

plot.igraph(g_shows_votes_bad_score,
            layout=layout_with_fr,
            vertex.size=9,
            vertex.label = NA,
            vertex.label.cex=0.6,
            vertex.label.color="black",
            vertex.color=V(g_shows_votes_bad_score)$color,
            edge.color="chartreuse4",
            edge.width=2,
            edge.curved=TRUE,
            edge.arrow.size=0.4,
            edge.lty="solid",
            main="Bad shows")

legend("bottomright", legend=c("Actor", "Director", "Actor & Director"), col=c("blue", "red", "yellow"), pch=20, bty="n", cex=0.6, pt.cex=0.9)

Podsumujmy jak prezentowały się statystyki grafów i sprawdźmy czy występują jakieś różnice i podobieństwa.

stats_good

##      Liczba_wezlow    Liczba_krawedzi            Gestosc       Max_bliskosc 
##        65.00000000        42.00000000         0.01009615         1.00000000 
##       Min_bliskosc Max_posredniczenie Min_posredniczenie       Mean_stopien 
##         0.20000000         3.00000000         0.00000000         1.29230769 
##        Max_stopien        Min_stopien 
##         3.00000000         0.00000000

stats_bad

##      Liczba_wezlow    Liczba_krawedzi            Gestosc       Max_bliskosc 
##       87.000000000       50.000000000        0.006682705        1.000000000 
##       Min_bliskosc Max_posredniczenie Min_posredniczenie       Mean_stopien 
##        0.200000000        3.000000000        0.000000000        1.149425287 
##        Max_stopien        Min_stopien 
##        3.000000000        0.000000000

Statystyka grafu	Good Shows	Bad Shows
Liczba_wezlow	65	87
Liczba_krawedzi	42	50
Gestosc	0.01009615	0.006682705
Max_bliskosc	1	1
Min_bliskosc	0.2	0.2
Max_posredniczenie	3	3
Min_posredniczenie	0	0
Mean_stopien	1.29230769	1.149425287
Max_stopien	3	3
Min_stopien	0	0

Różnice grafów - wnioski:

Graf przedstawiający złe seriale, posiada więcej węzłów, niż graf odnoszący się do dobrych serialów o 22 (pomimo bardzo podobnej liczebności obserwacji w zbiorze danych, na których podstawie powstały grafy oraz mimo eliminacji wierzchołków posługując się kryterium bliskości).
Można powiedzieć, że główna struktura (centrum) złych serialów w sieci aktorzy vs. reżyserowie jest poniekąd bardziej rozbudowana, niż dla seriali dobrych. Innymi słowy - w ogólności jest mniej węzłów w centrum struktury dobrych serialów. Być może jest to wskazówka do tego, aby przypuszczać, że “trudniej” jest być wpływowym aktorem / reżyserem w dobrych produkcjach, niż w tych, które są uznawane za gorsze.
Liczba krawędzi również jest większa w przypadku sieci złych serialów, natomiast warto zauważyć, że różnica jest już znacznie mniejsza (różnica = 8), niż dla liczby węzłów (22).
Można dojść do wniosku, że pomimo znacznie większej liczby wierzchołków w sieci złych seriali, sieć ta nie jest znacznie bardziej “połączona” / “skomunikowana” jakby można było przypuszczać. Przyrost węzłów nie pokrywa się z przyrostem krawędzi, zatem pojawiło się tam więcej bezpośrednich / pojedynczych połączeń, lub występują pojedyncze nieskomunikowane jednostki.
Gęstość grafu złych seriali jest mniejsza od gęstości grafu dobrych seriali o zaledwie 0.003413445. Obydwie struktury nie są “gęste”, czyli mają niewiele krawędzi w stosunku do liczby możliwych krawędzi, które mogłyby wystąpić w grafie. Mała różnica między tymi dwoma strukturami, minimalnie wskazuje na stosunkowo “lepsze” skomunikowanie wierzchołków w mniejszym grafie - dla dobrych seriali.
Średni stopień wierzchołka może dawać ogólne wyobrażenie o gęstości grafu. Im wyższa jest ta wartość, tym bardziej “połączony” jest graf, co oznacza, że przeciętnie wierzchołki mają więcej połączeń. W naszym przypadku różnica między grafami wynosi 0.1428824 i ponownie wartość ta jest wyższa w przypadku grafu “Good Shows”, co wydaje się bardzo sensowną informacją nawiązując do poprzedniego wniosku.
Wartość różnicy 0.1428824 oznacza, że przeciętnie każdy wierzchołek w grafie “Good Shows” ma o około 0.14 połączeń więcej, niż w przypadku grafu “Bad Shows”. Innymi słowy oznacza to, że przeciętnie każdy wierzchołek w grafie “Bad Shows” ma o około 0.14 połączeń mniej, niż w przypadku grafu “Good Shows”.
Dodatkowo w obydwóch sieciach - dla seriali dobrych i złych, widzimy, że pojawiają się osoby, które jednocześnie pełniły funkcje aktora i reżysera we własnej produkcji, natomiast tylko w grafie “Good Shows” widnieje jedna osoba, która jednocześnie będąc aktorem we własnym serialu, pojawiła się również jako aktor u innego reżysera. Być może, jest to również jeden z kluczów do sukcesu i zdobycia istotnej pozycji w sieci.

Podobieństwa grafów - wnioski:

Obydwa grafy posiadają te same najniższe i najwyższe wskaźniki bliskości, pośredniczenia oraz stopnia. Patrząc na taką informację można wywnioskować, że niezależnie od sukcesu serialu, struktury między aktorami i reżyserami mieszczą się w pewnych scharakteryzowanych granicach pod względem wymienionych parametrów.
Ponieważ w obydwóch grafach można znaleźć podgrupy węzłów, które są skomunikowane ze sobą 1:1 (jeden aktor - jeden reżyser), to mają bezpośredni kontakt ze sobą, dlatego też mają jedyną i zarazem najkrótszą ścieżkę dostępu do siebie na wzajem - jest to równoznaczne z tym, że największa możliwa osiągalna wartość bliskości, czyli 1 jest osiągana.
Możemy zatem zaznaczyć, że niezależnie od tego, czy serial był dobry, czy zły, to w głównych strukturach sieci widzimy bezpośrednie relacje między najważniejszymi aktorami i reżyserami (relacja 1:1), którzy mimo eliminacji węzłów nieistotnych z punktu widzenia badania, zostali wyróżnieni w ostatecznej analizie.
Analogicznie, można zwrócić uwagę na podgrupy węzłów, które składają się z więcej, niż 2 wierzchołków. Tego typu podgrupy, w obydwóch grafach występują w formie: 2 aktorów - 1 reżyser, 1 aktor - 2 reżyserów, 1 aktor - 3 reżyserów, 3 aktorów - 1 reżyser, 2 aktorów - 2 reżyserów. Ponieważ takie osoby, nie są ze sobą bezpośrednio skomunikowane (każdy z każdym), to węzły nie posiadają najkrótszych możliwych ścieżek między sobą - stąd też najmniejsza osiągalna wartość bliskości równa 0.2.
Wartości pośredniczenia, które pojawiają się w obydwóch grafach to: 0, 0.5, 1 i 3. Pośrednictwo charakteryzuje odporność sieci na uszkodzenia węzła - określa, ile najkrótszych dróg zniknie w grafie w przypadku uszkodzenia danego węzła sieci. W przypadku usunięcia węzłów, których miara pośrednictwa jest największa, pojawią się największe zakłócenia działania sieci.
W podgrupach, gdzie występuje 3 aktorów i 1 reżyser lub 1 aktor i 3 reżyserów, miara ta wynosi 3 dla wierzchołka centralnego (który łączy wszystkie inne jednostki jedyną najkrótszą drogą). Można uznać, że są to osoby, które są niezwykle istotne z punktu widzenia komunikacji aktorów bądź reżyserów, którzy nie mają ze sobą bezpośredniego związku.
W przypadku wskaźnika o stopniu węzłów sytuacja wygląda bardzo podobnie w kontekście przyjmowanych maksymalnych i najmniejszych wartości - 3 i 0.
W obydwóch strukturach nie znajdziemy wierzchołka, który miałby bezpośrednio więcej niż 3 połączenia. Występują tam też jednostki, które nie posiadają połączeń, ale pozostały w naszym grafie nawet po eliminacji. Są to najprawdopodobniej ci aktorzy lub reżyserowie, którzy pod względem istotności bliskości w sieci, okazali się na tyle ważni, żeby pojawić się w ostatecznej strukturze, natomiast warto zaznaczyć, że jednocześnie osoby, z którymi te osoby współpracowały tacy nie byli.
Dodatkowo w obydwóch sieciach - dla seriali dobrych i złych, widzimy, że pojawiają się osoby, które jednocześnie pełniły funkcje aktora i reżysera we własnej produkcji.
Warto również zwrócić uwagę na pojedyncze nieskomunikowane z nikim węzły, które pojawiają się w tych dwóch strukturach – są to tylko aktorzy (nie ma tego typu reżyserów). Takie jednostki zostały w finalnym grafie po eliminacji wierzchołków posługując się kryterium bliskości. Mogłoby to oznaczać, że są to aktorzy istotni z punktu widzenia samego centrum struktury, natomiast prawdopodobnie współpracowali oni z osobami, które nie okazały się być na tyle ważne, aby pokazać się z nimi w ostatecznym grafie.

Komentarze

Przeprowadzony projekt wciąż pozostawia kilka aspektów, które mogą być interesujące do zbadania jako kontynuacja/rozszerzenie badania - np.:

Porównanie struktury sieci dobrych/złych produkcji filmowych, które również zawarte są w naszym pierwotnym zbiorze danych.
Głębsza analiza sieci powstałych grafów i zbadanie konkretnych zmiennych/cech charakterystycznych serialów/filmów między grupami.
Zmiana kryterium eliminacji wierzchołków z grafu i porównanie struktur między metodami.