Best Picture - Oscar 2017 prediction
Lukasz Prokulski
26 stycznia 2017
Czy da się wytypować zdobywcę Oscara za pomocą matematyki?
Spróbujmy odpowiedzieć na tak postawione pytanie.
Na początek rozważmy czego możemy się dowiedzieć z ogólnodostępnych źródeł? Weźmy na przykład bazę filmów z seriwsu IMBd.com. Mamy tam takie informacje:
- średnia głosów społeczności
- ilość oddanych głosów
- mamy ocenę krytyków (wskaźnik MetaScore)
- informacje o obsadzie, reżyserze, gatunku
- informacje o czasie trwania
- koszt (budżet) filmu
- mamy przychód z kin - w weekend otwarcia oraz całkowity
- wreszcie - wiemy czy film zdobył Oscara wcześniej czy nie (w odpowiednim roku)
Spróbujmy zatem na początek pobrać potrzebne informacje wprost z IMBd.com.
Te biblioteki nam się przydadzą:
library(ggplot2)
library(dplyr)
library(rvest)
library(randomForest)Gimme data!
Poniższa funkcja pobierze informacje o nominacjach oraz wygranych w kategorii “Best Picutre” wprost ze stron IMBd.com. Na początek wystarczą nam linki do stron poszczególnych filmów:
Historia
GetBestMoviesList <- function(rok) {
# czytamy odpowiednią stronę - kolejną edycję Oscarów
page <- read_html(paste0("http://www.imdb.com/event/ev0000003/", rok))
# proszę zajrzeć w kod HTML strony - potrzebujemy tylko fragmentów
best_picture <- page %>%
html_nodes("div.award") %>%
html_node("blockquote") %>%
html_node("blockquote")
# "Best Picture" jest w pierwszym bloku
best_picture <- best_picture[1]
# pobieramy wszystkie linki z wybranego bloku
best_picture <- best_picture %>%
html_nodes("div") %>%
html_nodes("a") %>%
html_attr("href") %>%
unique()
# wykluczenie zbędnych linków
# interesują nas tylko filmy, a nie link do osoby lub wytwórnia
# usuwamy to co zbędne
best_picture <- best_picture[substr(best_picture, 1, 9)!="/company/"]
best_picture <- best_picture[substr(best_picture, 1, 8)!="/name/nm"]
# wszystkie linki włóżmy w jedną ramkę
df <- data.frame(Year=rok, MovieLink=best_picture, Won=FALSE)
# pierwszy film na liście wygrywał - oznaczmy to
df[1,3] <- TRUE
return(df)
}Skoro mamy gotową funkcję - możemy pobrać z jej pomocą informacje z kolejnych edycji Oscarów. W przykładzie ograniczamy się do lat 2000-2016.
movies_list <- data.frame()
for(y in 2000:2016) {
movies_list <- rbind(movies_list, GetBestMoviesList(y))
}Uwaga - jeśli chcemy pobrać lata wcześniejsze (np. wszystkie edycje nagrody - od 1929 roku) trzeba uważać na niespodzianki. Są dwie:
- w 1930 były dwie edycje rozdania nagród, informacje są na stronach z końcówką “/1930-1” i “/1930-2” zamiast (jak w innych przypadkach) “/1930”
- w 1933 roku nie było Oscarów - ten rok trzeba pominąć
Kiedy mamy już linki do wszystkich filmów z oznaczeniem czy film wygrał w kategorii “Best Picture” oraz w którym to było roku - warto uzupełnić linki do pełnego adresu URL. Na stronie linki są w postaci względnej (chociaż nie zawsze).
# zbudowanie pełnego urla
movies_list$MovieLink <- ifelse(substr(movies_list$MovieLink, 1, 7) == "http://",
movies_list$MovieLink,
paste0("http://www.imdb.com", movies_list$MovieLink))Nominacje 2017
Mamy historię, ale co z nominowanymi w 2017 roku? To dodajmy ręcznie. Tak - ręcznie wyszukałem te filmy i je wpisałem poniżej.
# filmy nominowane w 2017
movies_list <- rbind(movies_list, data.frame(Year=2017,
MovieLink=c("http://www.imdb.com/title/tt2543164/",
"http://www.imdb.com/title/tt3783958/",
"http://www.imdb.com/title/tt2671706/",
"http://www.imdb.com/title/tt3741834/",
"http://www.imdb.com/title/tt2119532/",
"http://www.imdb.com/title/tt4034228/",
"http://www.imdb.com/title/tt4975722/",
"http://www.imdb.com/title/tt2582782/",
"http://www.imdb.com/title/tt4846340/"),
Won=FALSE))Dane o filmie - to samo razy 122
Mamy “namiary” na wszystkie interesujące nas filmy. Czas zdobyć ich “dane szczegółowe”. Posłużymy się poniższą funkcją, którą wywołamy 122 razy (tyle ile mamy filmów).
GetMovieDetalis <- function(movie_url) {
# wczytajmy stronę z filmem
page <- read_html(movie_url)
# tytuł - interesuje nas tytuł oryginalny
title <- page %>%
html_node("div.title_wrapper") %>%
html_node("div.originalTitle") %>%
html_text()
# jeśli nie ma tytułu oryginalnego w stosownym polu - weźmy tytuł "główny"
# IMDb.com w tytule podaje tytuł zlokalizowany - w Polsce zobaczymy polskie tytuły
# dodatkowo w nawiasach po tytule jest np. rok produkcji filmu - usuwamy to
if(is.na(title)) {
title <- page %>%
html_node("div.title_wrapper") %>%
html_node("h1") %>%
html_text()
sub <- page %>%
html_node("div.title_wrapper") %>%
html_node("h1") %>%
html_node("span") %>%
html_text()
} else {
sub <- page %>%
html_node("div.title_wrapper") %>%
html_node("div.originalTitle") %>%
html_node("span") %>%
html_text()
}
title <- gsub(sub, "", title, fixed = TRUE)
title <- trimws(title)
# ocena użytkowników
rating <- page %>%
html_node("div.imdbRating") %>%
html_nodes("span") %>%
html_text()
# liczba głosóW
votes <- as.integer(gsub(",", "", rating[4]))
# ocena
rating <- as.numeric(rating[1])
# czas trwania filmu
duration <- page %>%
html_node("div.title_wrapper") %>%
html_node("div.subtext") %>%
html_node("time") %>%
html_attr("datetime")
duration <- gsub("PT", "", duration)
duration <- as.integer(gsub("M", "", duration))
# kategoria wiekowa
pgrating <- page %>%
html_node("div.title_wrapper") %>%
html_node("div.subtext") %>%
html_node("meta") %>%
html_attr("content")
# gatunki - pobieramy wszystko, na końcu wykorzystamy tylko pierwszy wskazany
genres <- page %>%
html_node("div.title_wrapper") %>%
html_node("div.subtext") %>%
html_nodes("a") %>%
html_text()
genres <- genres[1:(length(genres)-1)]
# credits
credits <- page %>% html_nodes("div.credit_summary_item")
director <- credits[1] %>% html_nodes("span.itemprop") %>% html_text()
writers <- credits[2] %>% html_nodes("span.itemprop") %>% html_text()
stars <- credits[3] %>% html_nodes("span.itemprop") %>% html_text()
# metascore
metascore <- page %>% html_node("div.metacriticScore")
# dla starszych filmów nie ma tej wartości
# aby funkcja zadziałała dla filmów z Oscarów 1929 robimy obejście :)
if(!is.na(metascore)) {
metascore <- metascore %>% html_node("span") %>% html_text() %>% as.integer()
} else {
metascore <- NA
}
# budżet
movie_details <- page %>%
html_node("div#titleDetails") %>%
html_nodes("div.txt-block") %>%
html_text()
movie_details <- trimws(gsub("\\n", "", movie_details))
movie_details <- gsub(" +", " ", movie_details)
budget <- movie_details[substr(movie_details, 1, 8)=="Budget: "]
if(length(budget)>0) {
budget <- substr(budget, 9, nchar(budget))
budget <- strsplit(budget, " ")[[1]][1]
budget <- gsub(",", "", budget)
# niektóre wartości są w funtach - przeliczmy to na dolary
# GBP -> USD, 1 GBP = 1.5 USD
budget <- ifelse(substr(budget, 1, 1)=="$",
as.integer(substr(budget, 2, nchar(budget))),
1.5*as.integer(substr(budget, 2, nchar(budget))))
} else {
# czasem nie ma informacji o budżecie - obejście
budget <- NA
}
# przychód w weekend otwarcia
# plus obejście dla brakujących danych
opening <- movie_details[substr(movie_details, 1, 17)=="Opening Weekend: "]
if(length(opening)>0) {
opening <- substr(opening, 18, nchar(opening))
opening <- strsplit(opening, " ")[[1]][1]
opening <- gsub(",", "", opening)
opening <- ifelse(substr(opening, 1, 1)=="$",
as.integer(substr(opening, 2, nchar(opening))),
1.5*as.integer(substr(opening, 2, nchar(opening))))
} else {
opening <- NA
}
# całkowity przychód
gross <- movie_details[substr(movie_details, 1, 7)=="Gross: "]
if(length(gross)>0) {
gross <- substr(gross, 8, nchar(gross))
gross <- strsplit(gross, " ")[[1]][1]
gross <- gsub(",", "", gross)
gross <- ifelse(substr(gross, 1, 1)=="$",
as.integer(substr(gross, 2, nchar(gross))),
1.5*as.integer(substr(gross, 2, nchar(gross))))
} else {
gross <- NA
}
# łączymy wszystkie dane w jedną ramkę, a właciwie jeden wiersz
df <- data.frame(Title=title,
Rating=rating,
Votes=votes,
Duration=duration,
PG=pgrating,
Genres=genres[1],
Director=director[1],
Writers=writers[1],
StarA=stars[1],
StarB=stars[2],
MetaScore=metascore,
Budget=budget,
Openning=opening,
Gross=gross)
return(df)
}Uff - mamy czym pobierać dane o filmach. Czas to zrobić!
# pobranie danych do jednej ramki
movies_dets <- data.frame()
len <- nrow(movies_list)
for(i in 1:len) {
db <- data.frame(movies_list[i,])
mdet <- GetMovieDetalis(movies_list[i,2])
db <- cbind(db, mdet)
movies_dets <- rbind(movies_dets, db)
}Proces może trochę potrwać - w końcu mamy do przekopania się przez 122 stron. Ale na koniec zgromadzimy ciekawe dane. O takie (pierwsze 10 pobranych rekordów):
| Year | MovieLink | Won | Title | Rating | Votes | Duration | PG | Genres | Director | Writers | StarA | StarB | MetaScore | Budget | Openning | Gross |
|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|
| 2000 | http://www.imdb.com/title/tt0169547/ | TRUE | American Beauty | 8.4 | 854519 | 122 | 15 | Drama | Sam Mendes | Alan Ball | Kevin Spacey | Annette Bening | 86 | 1.50e+07 | 861531 | 130058047 |
| 2000 | http://www.imdb.com/title/tt0124315/ | FALSE | The Cider House Rules | 7.4 | 80678 | 126 | PG-13 | Drama | Lasse Hallström | John Irving | Tobey Maguire | Charlize Theron | 75 | 2.40e+07 | 110098 | 57536361 |
| 2000 | http://www.imdb.com/title/tt0120689/ | FALSE | The Green Mile | 8.5 | 824505 | 189 | R | Crime | Frank Darabont | Stephen King | Tom Hanks | Michael Clarke Duncan | 61 | 6.00e+07 | 18017152 | 136801374 |
| 2000 | http://www.imdb.com/title/tt0140352/ | FALSE | The Insider | 7.9 | 136694 | 157 | R | Biography | Michael Mann | Marie Brenner | Russell Crowe | Al Pacino | 84 | 9.00e+07 | 6712361 | 28965197 |
| 2000 | http://www.imdb.com/title/tt0167404/ | FALSE | The Sixth Sense | 8.1 | 730317 | 107 | PG-13 | Drama | M. Night Shyamalan | M. Night Shyamalan | Bruce Willis | Haley Joel Osment | 64 | 4.00e+07 | 26681262 | 293501675 |
| 2001 | http://www.imdb.com/title/tt0172495/ | TRUE | Gladiator | 8.5 | 1024354 | 155 | R | Action | Ridley Scott | David Franzoni | Russell Crowe | Joaquin Phoenix | 64 | 1.03e+08 | 34819017 | 187670866 |
| 2001 | http://www.imdb.com/title/tt0241303/ | FALSE | Chocolat | 7.3 | 153929 | 121 | PG-13 | Drama | Lasse Hallström | Joanne Harris | Juliette Binoche | Judi Dench | 64 | 2.50e+07 | 157624 | 71309760 |
| 2001 | http://www.imdb.com/title/tt0190332/ | FALSE | Wo hu cang long | 7.9 | 221985 | 120 | PG-13 | Action | Ang Lee | Du Lu Wang | Yun-Fat Chow | Michelle Yeoh | 93 | 1.70e+07 | 663205 | 128067808 |
| 2001 | http://www.imdb.com/title/tt0195685/ | FALSE | Erin Brockovich | 7.3 | 139347 | 131 | R | Biography | Steven Soderbergh | Susannah Grant | Julia Roberts | Albert Finney | 73 | 5.20e+07 | 28138465 | 125548685 |
| 2001 | http://www.imdb.com/title/tt0181865/ | FALSE | Traffic | 7.6 | 173658 | 147 | R | Crime | Steven Soderbergh | Simon Moore | Michael Douglas | Benicio Del Toro | 86 | 4.80e+07 | 15517549 | 124107476 |
Co widać w danych? (obrazki!)
Na początek zobaczmy jak oceniane przez społeczność IMBd.com są filmy, które zdobyły Oscara.
# minimalna i maksymalna ocena - do skalowania wykresów
ymin <- floor(min(movies_dets$Rating))
ymax <- ceiling(max(movies_dets$Rating))movies_dets %>%
filter(Year != 2017) %>%
ggplot() +
theme_bw() +
geom_point(aes(Year, Rating, col=Won), size=5) +
geom_smooth(aes(Year, Rating, col=Won), se=FALSE, method = "loess") +
ylim(ymin, ymax) +
labs(title="Ocena IMDb.com a Oscar")
Widać, że lepiej oceniane są filmy z Oscarem. Czyli nagroda odpowiada gustom publiczności :)
A jak mają się do nagrody informacje o pieniądzach?
Najpierw budżet:
movies_dets %>%
filter(Year != 2017) %>%
ggplot() +
theme_bw() +
geom_point(aes(Year, Budget, col=Won), size=5) +
geom_smooth(aes(Year, Budget, col=Won), se=FALSE, method = "loess") +
labs(title="Budżet a Oscar - produkcja")
Filmy z Oscarem są ostatnio tańsze w produkcji - taka tendencja widoczna jest od 2008 roku. Czyli Akademia preferuje kino kameralne nad blockbustery? Sprawdźmy to po przychodach:
- z weekendu otwarcia:
movies_dets %>%
filter(Year != 2017) %>%
ggplot() +
theme_bw() +
geom_point(aes(Year, Openning, col=Won), size=5) +
geom_smooth(aes(Year, Openning, col=Won), se=FALSE, method = "loess") +
labs(title="Budżet a Oscar - weekend otwarcia")
- i z całkowitego przychodu:
movies_dets %>%
filter(Year != 2017) %>%
ggplot() +
theme_bw() +
geom_point(aes(Year, Gross, col=Won), size=5) +
geom_smooth(aes(Year, Gross, col=Won), se=FALSE, method = "loess") +
labs(title="Budżet a Oscar - całkowity przychód")
Widzieliśmy już, że publiczność wyżej ocenia filmy Oscarowe. A krytycy (oceny MetaScore)?
movies_dets %>%
filter(Year != 2017) %>%
ggplot() +
theme_bw() +
geom_point(aes(Year, MetaScore, col=Won), size=5) +
geom_smooth(aes(Year, MetaScore, col=Won), se=FALSE, method = "loess") +
labs(title="MetaScore a Oscar")
Co się stanie 26 lutego 2017?
Spróbujmy teraz przewidzieć który film wygra w kategorii “Best Picture”?
Zbudujemy model typu random forest zasilony danymi z lat 2000-2016.
Najpierw jednak trzeba podzielić dane na część uczącą i testową - próbka treningowa to będą poprzednie lata, zaś predykcję będziemy robić na roku 2017.
# wybieramy tylko potrzebne kolumny
movies_train <- movies_dets[, c(1,3,4,5,6,7,8,9, 14,15,16,17)]
# test - 2017 rok
movies_test <- movies_train[movies_train$Year == 2017, -2]
# trening - wszystko pozostałe
movies_train <- movies_train[movies_train$Year != 2017, -3]
movies_train$Won <- ifelse(movies_train$Won, 1, 0)
# dane treningowe to tylko filmy, które mają wszystkie informacje
movies_train <- na.omit(movies_train)Zbudujemy model. Banalnie - wywołując po prostu jedną fukncję. Będziemy przewidywać wartość “Won” na podstawie pozostałych danych.
# randomForest
model_rf <- randomForest(Won ~ ., movies_train, importance=TRUE)Przy okazji, sprawdźmy jakie znaczenie w modelu mają poszczególne dane opisujące film:
varImpPlot(model_rf)
Dobra, dobra - czas na przewidywania!
pred_rf <- predict(model_rf, newdata = movies_test[,-2])
movies_test_rf <- cbind(movies_test, pred_rf)
# posortujmy od razu tabelę po predykcji
movies_rf_list <- movies_test_rf %>%
arrange(desc(pred_rf)) %>%
select(Title, Rating, Votes, Genres, MetaScore, pred_rf)“And the winner is!…”
print(movies_rf_list)| Title | Rating | Votes | Genres | MetaScore | pred_rf |
|---|---|---|---|---|---|
| La La Land | 8.7 | 95928 | Comedy | 93 | 0.4037333 |
| Manchester by the Sea | 8.4 | 21889 | Drama | 96 | 0.2887333 |
| Moonlight | 8.3 | 17467 | Drama | 99 | 0.2323333 |
| Hell or High Water | 7.7 | 65574 | Crime | 88 | 0.1608333 |
| Arrival | 8.2 | 142955 | Drama | 81 | 0.1150000 |
| Hacksaw Ridge | 8.5 | 57891 | Drama | 71 | 0.1100333 |
| Lion | 8.0 | 8213 | Drama | 69 | 0.0982333 |
| Hidden Figures | 8.0 | 13169 | Biography | 74 | 0.0905333 |
| Fences | 7.7 | 9506 | Drama | 78 | 0.0499000 |
Na pierwszym miejscu (IMHO) fawort. Czy tak będzie?
Krytycy różnią się w opiniach.
Masz pytania, albo uwagi? Napisz