Oceny filmów i ich przewidywanie

Od czego zależą oceny filmów? Jak będzie oceniony film, który dopiero powstaje? Dawno temu, czyli gdzieś około roku, może nawet półtora temu, zebrałem z Filmwebu prawie całą ówczesną bazę danych o filmach. Wykorzystałem biblioteki napisane w PHP korzystające z (nie)oficjalnego API Filmwebu budując skrypt, który dla kolejnych ID “produktów” (produktów, bo Filmweb ma nie tylko filmy, ale również seriale i gry) i pobierał odpowiednie informacje (do ID bodaj 770 tys.): rok produkcji filmu, jego polski i oryginalny tytuł, czas trwania, gatunki, twórców i obsadę oraz liczbę ocen i średnią ocenę (na moment pobrania danych). Powstało kilka plików CSV (pliki relacyjne) z dużą ilością danych. Dzisiaj z tego skorzystamy i pooglądamy jak zmieniał się przemysł filmowy. Pliki zgromadzone zostały w formie CSV, po wyczyszczeniu danych wpakowałem wszystko w jeden plik z danymi. Wczytajmy sobie te dane:

library(tidyverse)
library(gridExtra)

theme_set(theme_minimal())

load("filmweb_data.rda")

Na początek zobaczymy jak zmieniają się oceny filmów w zależności od roku produkcji. Aby dane o ocenie były wiarygodne potrzebujemy jakiejś próbki ocen - liczba oddanych głosów musi być znacząca, aby średnia była wiarygodna. Przyjmijmy, że jest to 70-percentyl (czyli będziemy brać pod uwagę tylko te filmy na które oddano “górne” 30% liczby głosów), co daje co najmniej 234 głosów.

# minimalna liczba głosów
minFilmVotes <- quantile(movies$FilmVotes, 0.7, na.rm = TRUE)

movies %>%
   filter(FilmVotes >= minFilmVotes) %>%
   ggplot() +
   geom_point(aes(filmYear, filmRate), color="lightgreen", alpha=0.1) +
   geom_smooth(aes(filmYear, filmRate), color="blue") +
   scale_x_continuous(breaks = seq(1880, 2020, 10)) +
   scale_y_continuous(breaks = 1:10, limits = c(0,10)) +
   labs(x = "Rok produkcji", y = "Ocena filmu")

Po gęstości upakowania zielonych punktów widać, że produkuje się coraz więcej filmów. Jednocześnie widać też, że rozpiętość ocen dla tych filmów jest coraz większa - wiadomo, im więcej produkujesz tym większa szansa na arcydzieło jak i na babola. Trend jest jednak taki, że nowsze filmy są coraz niżej oceniane (średnio). Zobaczmy jeszcze jak wygląda rozkład ocen - czyli jakie oceny nadawane są najczęściej (to trochę uproszczenie, bo mamy tylko ocenę średnią, ale przecież bierze się ona ze składowych):

movies %>%
   filter(FilmVotes >= minFilmVotes) %>%
   ggplot() +
   geom_histogram(aes(filmRate),
                  fill="lightgreen", color="black",
                  binwidth = 1) +
   scale_x_continuous(limits = c(0,10), breaks = 1:10) +
   labs(x = "Ocena filmu")

Najczęściej nadawaną oceną jest siódemka, następna w kolejności jest szóstka. Ocen skrajnych jest mało. I tak jest zawsze jeśli mamy tego typu skalę i dużo produktów do oceny. Co ciekawe - przy obliczaniu NPS (Net Promoter Score - wersja angielska tłumaczy jak liczy się ten wskaźnik) wartości 7 i 8 nie są brane pod uwagę. Z czego może wynikać ta popularność szóstek i siódemek? Z kilku powodów:

• oceniamy filmy, które widzieliśmy, bo przecież nie będziemy marnować czasu na gnioty i wybieramy raczej coś potencjalnie wartościowego. Taki wybór nas zadowala (ocena dobra lub bardzo dobra w skali Filmwebu) stąd najwięcej ocen 6 i 7
• filmów wybitnych jest mało
• gniotów jest mało, albo ich nie oglądamy (patrz punkt pierwszy)
• w zestawieniu z ocenami zależnymi od roku produkcji może być trochę tak, że cenimy filmy stare, bo ktoś powiedział że to arcydzieła - nawet jeśli “Obywatel Kane” jest nudny (nie jest, jest rewelacyjny) to dajemy mu 8, 9 albo i 10 gwiazdek, bo to w końcu najlepszy film wszech czasów… według krytyków, Akademii i tak dalej, i tak dalej…
• druga opcja tłumacząca wyższe oceny dla starszych filmów to sentyment - film widzieliśmy dawno, niewiele pamiętamy, a to co pamiętamy to głównie emocje wokół seansu (bo byliśmy pierwszy raz w kinie, bo byliśmy młodzi i ogólnie bardziej oceniamy młodość niż sam film)

Ja dodatkowo oceniam filmy w kontekście - przede wszystkim gatunku, ale też czasu powstania filmu i tego co twórcy mieli szansę zobaczyć wcześniej. Dlatego właśnie “Obywatel Kane” jest w mojej opinii arcydziełem - przed tym filmem nie było takiego grania światłem, nie było ujęć z podłogi, a także nie było takiego sposobu prowadzenia opowieści. Z ciekawości policzmy coś w rodzaju wskaźnika NPS dla gatunków:

library(reshape2)

NPS <- movies %>%
   filter(FilmVotes >= minFilmVotes) %>%
   mutate(filmRate=round(filmRate)) %>%
   left_join(movie_genres, by="filmID") %>%
   filter(!is.na(genreID)) %>%
   select(genreID, filmRate) %>%
   dcast(genreID ~ filmRate, length)

NPS$Bad <- rowSums(NPS[, 2:6])/rowSums(NPS[,2:10]) # za złe oceny unajemy 1-5 włącznie
NPS$Good <- rowSums(NPS[, 9:10])/rowSums(NPS[,2:10]) # za dobre - 8-10
NPS$NPS <- 100*(NPS$Good - NPS$Bad)

NPS %>%
   select(genreID, NPS) %>%
   left_join(dict_genre, by="genreID") %>%
   arrange(NPS) %>%
   mutate(genreName = factor(genreName, levels=genreName)) %>%
   ggplot() +
   geom_bar(aes(genreName, NPS,
                fill = ifelse(NPS > 0, "good", "bad")),
            color = "black",
            stat = "identity", show.legend = FALSE) +
   geom_text(aes(genreName, y = ifelse(NPS > 0, -5, 5),
                 label = round(NPS, 1))) +
   geom_hline(yintercept = 50, color = "blue") +
   coord_flip() +
   labs(x = "Gatunek", y = "NPS") +
   scale_fill_manual(values = c("good" = "lightgreen", "bad" = "red")) +
   scale_y_continuous(breaks = seq(-100, 100, 25))

Jak czytać ten wykres? Im dłuższy zielony pasek tym większa jest przewaga ocen dobrych nad złymi. Za oceny dobre uznajemy tutaj 8 gwiazdek i więcej, za złe - do pięciu gwiazdek włącznie. Wskaźnik NPS mówi o tym jak bardzo klienci są skłonni polecać usługę lub towar znajomym (im większy tym bardziej, wartości poniżej zera to już odradzanie; wartości powyżej 50 uznawane są jako “doskonałe”). Tutaj w jakimś uproszczeniu możemy przyjąć, że filmy przyrodnicze będą polecane (jako interesujące, z ładnymi zdjęciami - na pewno mają przewagę ocen wysokich nad niższymi), a filmy z kategorii “xxx” (też można by powiedzieć, że przyrodnicze…) będą odradzane, nie należy ich oglądać. Bo są słabo oceniane, a nie ze względu na treść. Na koniec tych rozważań zobaczmy najlepsze filmy według roku produkcji:

movies %>%
   filter(FilmVotes >= minFilmVotes) %>%
   select(filmID, filmTitle, filmYear, filmRate) %>%
   group_by(filmYear) %>%
   mutate(filmRate_max = max(filmRate)) %>%
   ungroup() %>%
   filter(filmRate == filmRate_max) %>%
   select(filmYear, filmTitle, filmRate) %>%
   arrange(filmYear) %>%
   mutate(filmRate = round(filmRate, 2)) %>%
   knitr::kable()

A czy z postępem technologii idzie wydłużenie czasu trwania filmu?

movies %>%
   filter(!is.na(FilmDuration)) %>%
   filter(FilmDuration <= quantile(FilmDuration, 0.999)) %>%
   ggplot() +
   geom_point(aes(filmYear, FilmDuration), color="lightgreen", alpha=0.1) +
   geom_smooth(aes(filmYear, FilmDuration), color="blue") +
   scale_x_continuous(breaks = seq(1880, 2020, 10)) +
   scale_y_continuous(breaks = seq(0, 300, 30)) +
   labs(x = "Rok", y = "Czas trwania filmu")

Dość przewidywalne wyniki, zależne początkowo od technologii (ciężki i grzejący się sprzęt, droga taśma), trochę pewnie też percepcji widzów szczególnie na początku XX wieku. Po II wojnie światowej ukonstytuowały się pewne standardy, między innymi około 90-110 minut czasu trwania filmu i tak już pozostało co czasów obecnych. Mamy też smugi w okolicach 10 minut(etiudy), 30 minut (krótkie filmy dokumentalne) i 60 minut (festiwalowy limit 60 minut dla filmów krótkometrażowych). Popatrzmy na to w inny sposób:

movies %>%
   filter(!is.na(FilmDuration)) %>%
   filter(FilmDuration <= quantile(FilmDuration, 0.999)) %>%
   ggplot() +
   geom_histogram(aes(FilmDuration),
                  fill="lightgreen", color="black", binwidth = 5) +
   scale_x_continuous(breaks = seq(0, 240, 15)) +
   labs(x = "Czas trwania filmu")

Sprawdźmy teraz czy ocena zależy od czasu trwania filmu?

movies %>%
   filter(!is.na(FilmDuration)) %>%
   filter(FilmDuration <= quantile(FilmDuration, 0.999)) %>%
   filter(FilmVotes >= minFilmVotes) %>%
   ggplot() +
   geom_point(aes(FilmDuration, filmRate), color="lightgreen", alpha=0.1) +
   geom_smooth(aes(FilmDuration, filmRate), color="blue") +
   scale_x_continuous(breaks = seq(0, 240, 15)) +
   scale_y_continuous(limits = c(0,10), breaks = 1:10) +
   labs(x = "Czas trwania filmu", y = "Ocena filmu")

Widać spadek dla filmów dłuższych niż godzina (60-90 minut). Strzelam, że są to formaty telewizyjne (półtoragodzinny blok w programie - film plus reklamy), które są - nie ukrywajmy - słabszymi produkcjami niż filmy przeznaczone do dystrybucji kinowej. Aby potwierdzić taką tezę należałoby znaleźć te filmy i sprawdzić co to za gatunki… tyle tylko, że nie mamy gatunku “film telewizyjny” ;) Zobaczmy teraz jak zmieniała się popularność poszczególnych gatunków z upływem czasu. Ważne jest to, co zaburza trochę wyniki - jeden film może należeć do kilku gatunków (na przykład niemy dramat wojenny sci-fi - #oglądałbym :-).

movies %>%
   select(filmID, filmYear) %>%
   left_join(movie_genres, by="filmID") %>%
   filter(!is.na(genreID)) %>%
   count(filmYear, genreID) %>%
   mutate(p = 100*n/sum(n)) %>%
   ungroup() %>%
   left_join(dict_genre, by="genreID") %>%
   ggplot() +
   geom_bar(aes(filmYear, p, fill=genreName),
            stat="identity", color=NA, show.legend = FALSE) +
   labs(x = "Rok", y = "Procent filmów") +
   scale_x_continuous(breaks = seq(1880, 2020, 10))

Statyczny wykres jest nieczytelny (przed skalę kolorów), zobaczmy wersję interaktywną - najedź na pasek, zobaczysz informacje w dymku: <br /> Popatrzmy na to sumarycznie (bez rozdzielania na poszczególne lata) - jaki jest podział procentowy filmów wyprodukowanych w XXI wieku pomiędzy gatunki? Weźmy tylko 20 najpopularniejszych gatunków:

movies %>%
   select(filmID, filmYear) %>%
   filter(filmYear >= 2000) %>%
   left_join(movie_genres, by="filmID") %>%
   filter(!is.na(genreID)) %>%
   count(genreID) %>%
   mutate(p = 100*n/sum(n)) %>%
   ungroup() %>%
   left_join(dict_genre, by="genreID") %>%
   top_n(20, wt = p) %>%
   arrange(p) %>%
   mutate(genreName = factor(genreName, levels=genreName)) %>%
   ggplot() +
   geom_bar(aes(genreName, p), stat="identity",
            fill="lightgreen", color="black") +
   geom_text(aes(genreName, p, label=paste0(round(p, 1), "%"),
                 hjust = ifelse(p > 5, 1.1, -0.2))) +
   coord_flip() +
   labs(x = "Gatunek", y = "Udział procentowy gatunku")

Ciekawe, ale bez odniesienia nie można wiele powiedzieć. Zobaczmy lata 1940-1970: oraz podział przed 1940 rokiem: Oczywiście w pierwszej połowie XX wieku dominowały filmy nieme. Ciekawy jest spory udział animacji w latach ’40-’70. W tym samym okresie widać wzrost liczby filmów wojennych i późniejszy jej spadek. Film noir istniał w latach ’40-’50. Thriller i horror zdobywają rynek w ostatnich latach, podobnie anime - nie istniało przed 2000 rokiem (albo nie załapało się do top 20). Bez względu na okres popularne są komedie i dramaty - w końcu kino to rozrywka. Zobaczmy teraz jak zmieniał się udział filmów dziewięciu najpopularniejszych gatunków na przestrzeni lat?

movies %>%
   select(filmID, filmYear) %>%
   left_join(movie_genres, by="filmID") %>%
   filter(!is.na(genreID)) %>%
   count(filmYear, genreID) %>%
   mutate(p = 100*n/sum(n)) %>%
   ungroup() %>%
   group_by(genreID) %>%
   mutate(mp = mean(p)) %>%
   ungroup() %>%
   filter(mp >= 3.5) %>%
   left_join(dict_genre, by="genreID") %>%
   ggplot() +
   geom_area(aes(filmYear, p, fill=genreName), show.legend = FALSE) +
   facet_wrap(~genreName, ncol = 3) +
   labs(x = "Rok", y = "Udział procentowy gatunku")

Potwierdza się to zaobserwowaliśmy wyżej przy okazji wykresów słupkowych:

• film niemy się skończył
• animacja popularna w latach 1930-1950 (Walt Disney?)
• film dokumentalny zyskuje na popularności (a może po prostu Filmweb poszerza bazę o nowe produkcje, pomijając uzupełnianie historii?), a ogromny (jak na ten gatunek) udział w początkach historii kina to wszystkie te krótkie filmy typu “Wjazd pociągu na stację” czy “Wyjście robotników z fabryki” (oczywiście upraszczając)

Poszukajmy najlepszych filmów w poszczególnych gatunkach:

movies %>%
   filter(FilmVotes >= minFilmVotes) %>%
   select(filmID, filmTitle, filmYear, filmRate) %>%
   left_join(movie_genres, by="filmID") %>%
   filter(!is.na(genreID)) %>%
   distinct() %>%
   group_by(genreID) %>%
   mutate(filmRate_max = max(filmRate)) %>%
   ungroup() %>%
   filter(filmRate == filmRate_max) %>%
   left_join(dict_genre, by="genreID") %>%
   select(genreName, filmTitle, filmYear, filmRate) %>%
   arrange(genreName) %>%
   mutate(filmRate = round(filmRate, 2)) %>%
   knitr::kable()

Wiemy już jak wygląda popularność poszczególnych gatunków, jak zmieniała się ocena wszystkich filmów w czasie, a czy takie same zmiany są w ramach gatunków? Przygotujemy fukncję, która po podaniu w parametrze nazwy gatunku narysuje nam stosowny wykres:

RatesByGenre <- function(gatunek) {
   # ID gatunku
   gatunek_id <- dict_genre %>%
      filter(genreName == gatunek) %>%
      .[1, 1] %>%
      as.integer()
   
   # lista filmów gatunku
   movies_ids <- movie_genres %>%
      filter(genreID == gatunek_id) %>%
      select(filmID) %>%
      .$filmID
   
   plot <- movies %>%
      filter(filmID %in% movies_ids,
             FilmVotes >= minFilmVotes) %>%
      ggplot() +
      geom_point(aes(filmYear, filmRate), color="lightgreen", alpha=0.3) +
      geom_smooth(aes(filmYear, filmRate), color="blue") +
      labs(title=paste("Oceny filmów z gatunku:", gatunek),
           x="Rok", y="Ocena filmu") +
      scale_x_continuous(breaks = seq(1880, 2020, 10)) +
      scale_y_continuous(breaks = 1:10, limits = c(0,10))
   
   return(plot)
}

Teraz z wykorzystaniem tej funkcji zobaczmy czy thrillery są coraz lepsze czy coraz gorsze?

RatesByGenre("thriller")

Coraz więcej i coraz gorzej… niestety. To pewnie dlatego nic nie jest w stanie mnie zaskoczyć. A najlepsze filmy z tego gatunku to:

RatesByGenre("thriller")$data %>%
   select(filmTitle, filmYear, filmRate) %>%
   top_n(10, wt = filmRate) %>%
   arrange(desc(filmRate)) %>%
   mutate(filmRate = round(filmRate, 2))

Większość już widziałem (poza ostatnimi trzema i “Siedem dni w maju”). Rzeczywiście “Siedem” jest chyba najlepszy, a “Incepcji” do thrillerów bym nie zaliczał. Zobaczmy to samo dla kilku innych gatunków:

A na koniec coś, dla czego (oprócz kotów) powstał internet - pornoski: Wiele ich nie ma, trzymają stały poziom. 10 najlepszych pornosów to:

Teraz przygotujmy podobną funkcję, ale przyglądać będziemy się dokonaniom poszczególnych twórców (lub aktorów - nie bierzemy w poniższej funkcji pod uwagę roli w jakiej występuje dana osoba - czy jest reżyserem czy aktorem).

RatesByPerson <- function(osoba) {
   # ID osoby
   person_id <- persons %>%
      filter(personName == osoba) %>%
      .[1, 1] %>%
      as.integer()
   
   # lista filmów z osobą
   movies_ids <- persons_in_movies %>%
      filter(personID == person_id) %>%
      select(filmID) %>%
      .$filmID
   
   plot <- movies %>%
      filter(filmID %in% movies_ids,
             FilmVotes >= minFilmVotes) %>%
      ggplot() +
      geom_point(aes(filmYear, filmRate), color="darkgreen") +
      geom_smooth(aes(filmYear, filmRate), color="blue", se = FALSE) +
      labs(title=paste("Oceny filmów z:", osoba),
           x="Rok", y="Ocena filmu") +
      scale_x_continuous(breaks = seq(1880, 2020, 10)) +
      scale_y_continuous(breaks = 1:10, limits = c(0,10))
   
   return(plot)
}

Na początek mój ulubiony reżyser (i scenarzysta, i aktor) - Woody Allen:

RatesByPerson("Woody Allen")

i jego (lub z nim) najlepsze filmy:

RatesByPerson("Woody Allen")$data %>%
    select(filmTitle, filmYear, filmRate) %>%
    top_n(10, wt = filmRate) %>%
    arrange(desc(filmRate)) %>%
    mutate(filmRate = round(filmRate, 2))

Osobiście bardziej cenię “Annie Hall”, ale pierwsza czwórka to rzeczywiście szczyt formy Allena. Jak widać są to lata ’70, później było z górki (ale nie tak bardzo). Poptarzmy też na innych reżyserów - Oliver Stone zalicza coraz gorsze filmy:

Zaś Tarantino trzyma równy poziom:

Podobnie było z Kubrickiem:

Jeśli nie widzieliście “Zabójstwa” w reżyserii tego pana to koniecznie musicie nadrobić - film z połowy lat ’50, a wyprzedził to co oglądamy teraz o jakieś 40-50 lat. Geniusz. Zobaczmy na dwie aktorskie gwiazdy drugiej połowy XX wieku:

Teraz zajmiemy się przewidywaniami. To najciekawsza rzecz w dzisiejszym wpisie. Poniższa funkcja znajduje wszystkie filmy z podaną osobą w określonej roli i zwraca średnią ocen filmów oraz wykres ze średnią. Dzięki temu możemy skomponować dowolną grupę twórców i na podstawie średnich ocen z dotychczasowych dokonań poszczególnych osób policzyć średnią wynikową dla tak “przygotowanego” filmu.

GetMovieMean <- function(osoba_name, osoba_rola) {

   id_osoby <- persons %>%
      filter(personName == osoba_name) %>%
      .[1,1] %>%
      as.integer()
   
   id_roli <- dict_roles %>%
      filter(roleName == osoba_rola) %>%
      .[1,1] %>%
      as.integer()

   movie_list <- persons_in_movies %>%
      filter(personID == id_osoby, roleID == id_roli) %>%
      select(filmID)
   
   movie_list <- inner_join(movie_list, movies, by="filmID")
   
   movie_mean <- mean(movie_list$filmRate, na.rm=TRUE)
   
   plot <- movie_list %>%
      ggplot() +
      geom_point(aes(filmYear, filmRate), color="lightgreen") +
      geom_smooth(aes(filmYear, filmRate), color="blue", se = FALSE) +
      labs(title = paste0(osoba_rola, ": ", osoba_name),
           subtitle = paste("Średnia", round(movie_mean, 2)),
           x = "Rok produkcji",
           y = "Średnia ocena") +
      scale_x_continuous(breaks = seq(1880, 2020, 10)) +
      scale_y_continuous(breaks = 1:10, limits = c(0,10))
   
   return(list(movie_mean, plot))
}

Sprawdźmy jaki wynik da wymyślony film:

• reżyseria Quentin Tarantino
• zdjęcia Emmanuel Lubezki
• scenariusz Charlie Kaufman
• obsada: Jack Nicholson, Leonardo DiCaprio, Cate Blanchett, Charlize Theron

(powyższe nazwiska to osoby z top w poszczególnych kategoriach według Filmwebu)

# przygotowanie obsady i twórców:
movie_cast <- data.frame(matrix(c("Quentin Tarantino", "reżyser",
                                  "Charlie Kaufman", "scenarzysta",
                                  "Emmanuel Lubezki", "zdjęcia",
                                  "Jack Nicholson", "aktor",
                                  "Leonardo DiCaprio", "aktor",
                                  "Cate Blanchett", "aktor",
                                  "Charlize Theron", "aktor"),
                                ncol = 2, byrow = TRUE),
                         stringsAsFactors = FALSE)

# dla każdego wiersza tabeli wywołaj funkcję biorącą średnie
t <- mapply(GetMovieMean, movie_cast$X1, movie_cast$X2)

Wypadkowa ocena końcowa:

mean(unlist(t[1, ]))

7.040453 A wszystkie wykresy historii ocen poszczególnych osób:

grid.arrange(arrangeGrob(grobs=t[2,], ncol = 2))

Wychodzi jakiś tam wynik (całkiem niezły - średnia 7.04 plus twórcy i obsada zachęciłaby do oglądania). A co się stanie, jak wymienimy scenarzystę? Niech Tarantino napisze również scenariusz:

movie_cast <- data.frame(matrix(c("Quentin Tarantino", "reżyser",
                                  "Quentin Tarantino", "scenarzysta",
                                  "Emmanuel Lubezki", "zdjęcia",
                                  "Jack Nicholson", "aktor",
                                  "Leonardo DiCaprio", "aktor",
                                  "Cate Blanchett", "aktor",
                                  "Charlize Theron", "aktor"),
                                ncol = 2, byrow = TRUE),
                         stringsAsFactors = FALSE)

t <- mapply(GetMovieMean, movie_cast$X1, movie_cast$X2)
mean(unlist(t[1, ]))

Widzimy, że średnia 7.1 jest wyższa. Czyli jeszcze bardziej zachęca :) Teraz weźmy hipotetyczny polski film - znowu nazwiska dobrane według top Filmwebu:

movie_cast <- data.frame(matrix(c("Wojciech Smarzowski", "reżyser",
                                  "Krzysztof Kieślowski", "scenarzysta",
                                  "Piotr Sobociński Jr.", "zdjęcia",
                                  "Tomasz Kot", "aktor",
                                  "Janusz Gajos", "aktor",
                                  "Maja Ostaszewska", "aktor",
                                  "Agata Kulesza", "aktor"),
                                ncol = 2, byrow = TRUE),
                         stringsAsFactors = FALSE)

t <- mapply(GetMovieMean, movie_cast$X1, movie_cast$X2)
mean(unlist(t[1, ]))

6.62 to niewiele, nawet jak na polskie warunki. Widocznie ktoś tutaj zaniża wynik:

grid.arrange(arrangeGrob(grobs=t[2,], ncol = 2))

Tomasz Kot jest temu winny - miał w swojej karierze kilka słabych filmów (ten dołek po 2010), chociaż to świetny aktor. Sprawdźmy jak nasze przewidywania sprawdzają się w przypadku nowego filmu. Weźmy jakiś film z 2016 roku, którego nie mamy w danych, a który ma już ocenę - na przykład ostatni Allen. Znamy obsadę, zobaczymy czy ta prosta metoda się sprawdza. Ten film to Śmietanka towarzyska. Co wiemy o twórcach i obsadzie? Scenariusz i reżyseria - Woody Allen, zdjęcia - Vittorio Storaro, obsada: Jesse Eisenberg, Kristen Stewart, Steve Carell, Blake Lively. Uzupełniając odpowiednio dane i wywołując GetMovieMean() otrzymamy przewidywaną średnią ocenę 6.63, zaś na Filmwebie jest to aktualnie 6.3 (sam dałem 5 gwiazdek z komentarzem “Allen ma już swoje lata. Jessie pasuje, są żarty o Żydach, jest sposób opowiadania jak zawsze, ale nie ma pazura. Pretensjonalne w sumie”). Nasz wynik jest wyższy (te 0.3 punktu to całkiem sporo, chociaż z drugiej strony jest to tylko 3% skali 0-10). Taki uproszczony model ma jedną podstawową wadę: nie bierze pod uwagę ostatnich dokonań osoby (czy jest na fali i w świetnej formie czy też “skończył się i utył”), a całą historię. Nie bierzemy też pod uwagę oceny osoby w filmie a ocenę całego filmu. Zdażają się przypadki kiedy dobra obsada jest zmarnowana przez słaby scenariusz albo kiepską reżyserię. Wtedy nawet dobry aktor nie uciągnie całego filmu - tak jest w przypadku wspomnianego już Tomasza Kota w jakichś “Jak się pozbyć cellulitu” czy też w filmach, którym osobiście dałem “jedynkę” (a rzadko to robię): “Wyjazdach integracyjnych” i “Ciacho”. Jak można ulepszyć model? Być może model powinien odrzucać wartości odstające. Być może powinien brać po uwagę tylko kilka ostatnich filmów. Warto też pomyśleć o jakichś wagach dla poszczególnych “ról” w przygotowaniu filmu (reżyseria, scenariusz, obsada). Pytanie tylko co jest ważniejsze: reżyseria czy scenariusz? A może zdjęcia? Aby dobrać takie wagi można zastosować trick polegający na uczeniu modelu. Proces wyglądać powinien następująco:

• bierzemy jakiś losowy film
• sprawdzamy kto go tworzył
• zbieramy średnie z dokonań twórców, ale bez badanego filmu, być może też bez późniejszych filmów (czyli bierzemy tylko dokonania przed produkcją badanego filmu)
• powyższe kroki powtarzamy na przykład tysiąc razy. Albo sto tysięcy. Najlepiej 70-80 procent bazy (czyli w naszym przypadku jakieś 47 do 53 tysięcy filmów)
• z tak zgromadzonych danych (zmienne niezależne) w zestawieniu z prawdziwą oceną filmu (zmienna zależna) budujemy model - na przykład najprostrzą regresję liniową dla wielu zmiennych
• w modelu otrzymamy wagi poszczególnych ról, które możemy zastosować w przyszłości

Kto się pokusi? Zapraszam do dyskusji i prezentacji swoich dokonań - podrzućcie linki w komentarzach!