Goal: to predict the average rating of horror movies. Click here for the data

Import Data

horror_movies <- read_csv('https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2022/2022-11-01/horror_movies.csv')
## Rows: 32540 Columns: 20
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr  (10): original_title, title, original_language, overview, tagline, post...
## dbl   (8): id, popularity, vote_count, vote_average, budget, revenue, runtim...
## lgl   (1): adult
## date  (1): release_date
## 
## ℹ 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.
skim(horror_movies)
Data summary
Name horror_movies
Number of rows 32540
Number of columns 20
_______________________
Column type frequency:
character 10
Date 1
logical 1
numeric 8
________________________
Group variables None

Variable type: character

skim_variable n_missing complete_rate min max empty n_unique whitespace
original_title 0 1.00 1 191 0 30296 0
title 0 1.00 1 191 0 29563 0
original_language 0 1.00 2 2 0 97 0
overview 1286 0.96 1 1000 0 31020 0
tagline 19835 0.39 1 237 0 12513 0
poster_path 4474 0.86 30 32 0 28048 0
status 0 1.00 7 15 0 4 0
backdrop_path 18995 0.42 29 32 0 13536 0
genre_names 0 1.00 6 144 0 772 0
collection_name 30234 0.07 4 56 0 815 0

Variable type: Date

skim_variable n_missing complete_rate min max median n_unique
release_date 0 1 1950-01-01 2022-12-31 2012-12-09 10999

Variable type: logical

skim_variable n_missing complete_rate mean count
adult 0 1 0 FAL: 32540

Variable type: numeric

skim_variable n_missing complete_rate mean sd p0 p25 p50 p75 p100 hist
id 0 1.00 445910.83 305744.67 17 146494.8 426521.00 707534.00 1033095.00 ▇▆▆▅▅
popularity 0 1.00 4.01 37.51 0 0.6 0.84 2.24 5088.58 ▇▁▁▁▁
vote_count 0 1.00 62.69 420.89 0 0.0 2.00 11.00 16900.00 ▇▁▁▁▁
vote_average 0 1.00 3.34 2.88 0 0.0 4.00 5.70 10.00 ▇▂▆▃▁
budget 0 1.00 543126.59 4542667.81 0 0.0 0.00 0.00 200000000.00 ▇▁▁▁▁
revenue 0 1.00 1349746.73 14430479.15 0 0.0 0.00 0.00 701842551.00 ▇▁▁▁▁
runtime 0 1.00 62.14 41.00 0 14.0 80.00 91.00 683.00 ▇▁▁▁▁
collection 30234 0.07 481534.88 324498.16 656 155421.0 471259.00 759067.25 1033032.00 ▇▅▅▅▅ 
data <- horror_movies %>%
    
    mutate(vote_average = log1p(vote_average)) %>%
    
    filter(vote_count != 0) %>%
    
    separate_rows(genre_names, sep = ", ") %>%
    
    filter(status == "Released") %>%
    
    select(id, vote_average, genre_names, runtime, budget, release_date, original_language) %>%
    
    na.omit()

Explore Data

identify good predictors.

budget

data %>%
    ggplot(aes(vote_average, budget)) +
    geom_point()

runtime

data %>%
    ggplot(aes(vote_average, runtime)) +
    geom_point()

title

# data %>%
    
    #tokenize title
    #unnest_tokens(output = word, input = overview) %>%
    
    # calculate avg rent per word
    #group_by(word) %>%
    #summarise(vote_average = mean(vote_average), 
             # n    = n()) %>%
    #ungroup() %>%
    
    #filter(n > 10, !str_detect(word, "\\d")) %>%
    #slice_max(order_by = vote_average, n = 20) %>%
    
    # plot
    #ggplot(aes(vote_average, fct_reorder(word, vote_average))) +
    #geom_point() +
    
    #labs(y = "Words in Overview")

EDA shortcut

# Step 1: Prepare data
data_binarized_tbl <- data %>%
    select(-id, -release_date) %>%
    binarize()

data_binarized_tbl %>% glimpse()
## Rows: 44,315
## Columns: 35
## $ `vote_average__-Inf_1.66770682055808`           <dbl> 0, 0, 0, 0, 0, 0, 0, 0…
## $ vote_average__1.66770682055808_1.84054963339749 <dbl> 0, 0, 0, 0, 0, 0, 0, 0…
## $ vote_average__1.84054963339749_1.98787434815435 <dbl> 0, 0, 0, 0, 0, 0, 0, 0…
## $ vote_average__1.98787434815435_Inf              <dbl> 1, 1, 1, 1, 1, 1, 1, 1…
## $ genre_names__Action                             <dbl> 0, 0, 0, 0, 0, 0, 0, 0…
## $ genre_names__Adventure                          <dbl> 0, 0, 1, 0, 0, 0, 0, 0…
## $ genre_names__Animation                          <dbl> 0, 0, 0, 0, 0, 0, 0, 0…
## $ genre_names__Comedy                             <dbl> 0, 0, 0, 0, 0, 0, 0, 0…
## $ genre_names__Crime                              <dbl> 0, 0, 0, 0, 0, 0, 0, 0…
## $ genre_names__Drama                              <dbl> 0, 0, 0, 1, 0, 0, 0, 0…
## $ genre_names__Fantasy                            <dbl> 0, 0, 0, 0, 0, 0, 0, 0…
## $ genre_names__Horror                             <dbl> 1, 0, 0, 0, 1, 1, 0, 0…
## $ genre_names__Mystery                            <dbl> 0, 0, 0, 0, 0, 0, 1, 0…
## $ genre_names__Science_Fiction                    <dbl> 0, 0, 0, 0, 0, 0, 0, 0…
## $ genre_names__Thriller                           <dbl> 0, 1, 0, 0, 0, 0, 0, 1…
## $ genre_names__TV_Movie                           <dbl> 0, 0, 0, 0, 0, 0, 0, 0…
## $ `genre_names__-OTHER`                           <dbl> 0, 0, 0, 0, 0, 0, 0, 0…
## $ `runtime__-Inf_74`                              <dbl> 0, 0, 0, 0, 0, 0, 0, 0…
## $ runtime__74_87                                  <dbl> 0, 0, 0, 0, 0, 0, 0, 0…
## $ runtime__87_95                                  <dbl> 0, 0, 1, 1, 1, 0, 0, 0…
## $ runtime__95_Inf                                 <dbl> 1, 1, 0, 0, 0, 1, 1, 1…
## $ budget__0                                       <dbl> 1, 1, 1, 1, 1, 0, 0, 0…
## $ `budget__-OTHER`                                <dbl> 0, 0, 0, 0, 0, 1, 1, 1…
## $ original_language__cn                           <dbl> 0, 0, 0, 0, 0, 0, 0, 0…
## $ original_language__de                           <dbl> 0, 0, 0, 0, 0, 0, 0, 0…
## $ original_language__en                           <dbl> 1, 1, 1, 1, 1, 1, 1, 1…
## $ original_language__es                           <dbl> 0, 0, 0, 0, 0, 0, 0, 0…
## $ original_language__fr                           <dbl> 0, 0, 0, 0, 0, 0, 0, 0…
## $ original_language__it                           <dbl> 0, 0, 0, 0, 0, 0, 0, 0…
## $ original_language__ja                           <dbl> 0, 0, 0, 0, 0, 0, 0, 0…
## $ original_language__ko                           <dbl> 0, 0, 0, 0, 0, 0, 0, 0…
## $ original_language__pt                           <dbl> 0, 0, 0, 0, 0, 0, 0, 0…
## $ original_language__th                           <dbl> 0, 0, 0, 0, 0, 0, 0, 0…
## $ original_language__zh                           <dbl> 0, 0, 0, 0, 0, 0, 0, 0…
## $ `original_language__-OTHER`                     <dbl> 0, 0, 0, 0, 0, 0, 0, 0…
# Step 2: Correlate
data_corr_tbl <- data_binarized_tbl %>%
    correlate(vote_average__1.98787434815435_Inf)

data_corr_tbl
## # A tibble: 35 × 3
##    feature           bin                               correlation
##    <fct>             <chr>                                   <dbl>
##  1 vote_average      1.98787434815435_Inf                   1     
##  2 vote_average      1.84054963339749_1.98787434815435     -0.327 
##  3 vote_average      -Inf_1.66770682055808                 -0.324 
##  4 vote_average      1.66770682055808_1.84054963339749     -0.306 
##  5 runtime           -Inf_74                                0.215 
##  6 runtime           87_95                                 -0.133 
##  7 runtime           74_87                                 -0.130 
##  8 original_language en                                    -0.0880
##  9 genre_names       Animation                              0.0753
## 10 original_language ja                                     0.0574
## # ℹ 25 more rows
# Step 3: Plot
data_corr_tbl %>%
    plot_correlation_funnel()
## Warning: ggrepel: 24 unlabeled data points (too many overlaps). Consider
## increasing max.overlaps

Build Models

Split Data

#data <- sample_n(data, 100)

#Split into train and test dataset
set.seed(1234)
data_split <- rsample::initial_split(data)
data_train <- training(data_split)
data_test <- testing(data_split)

#Further split training dataset for cross-validation
set.seed(4321)
data_cv <- rsample::vfold_cv(data_train)
data_cv
## #  10-fold cross-validation 
## # A tibble: 10 × 2
##    splits               id    
##    <list>               <chr> 
##  1 <split [29912/3324]> Fold01
##  2 <split [29912/3324]> Fold02
##  3 <split [29912/3324]> Fold03
##  4 <split [29912/3324]> Fold04
##  5 <split [29912/3324]> Fold05
##  6 <split [29912/3324]> Fold06
##  7 <split [29913/3323]> Fold07
##  8 <split [29913/3323]> Fold08
##  9 <split [29913/3323]> Fold09
## 10 <split [29913/3323]> Fold10
library(usemodels)
## Warning: package 'usemodels' was built under R version 4.3.3
usemodels::use_xgboost(vote_average ~ ., data = data_train)
## xgboost_recipe <- 
##   recipe(formula = vote_average ~ ., data = data_train) %>% 
##   step_zv(all_predictors()) 
## 
## xgboost_spec <- 
##   boost_tree(trees = tune(), min_n = tune(), tree_depth = tune(), learn_rate = tune(), 
##     loss_reduction = tune(), sample_size = tune()) %>% 
##   set_mode("classification") %>% 
##   set_engine("xgboost") 
## 
## xgboost_workflow <- 
##   workflow() %>% 
##   add_recipe(xgboost_recipe) %>% 
##   add_model(xgboost_spec) 
## 
## set.seed(18151)
## xgboost_tune <-
##   tune_grid(xgboost_workflow, resamples = stop("add your rsample object"), grid = stop("add number of candidate points"))
xgboost_recipe <- 
  recipe(formula = vote_average ~ ., data = data_train) %>% 
    recipes::update_role(id, new_role = "id") %>%
    step_date(release_date, keep_original_cols = FALSE) %>%
    step_other(original_language) %>%
    step_dummy(genre_names, original_language, release_date_dow, release_date_month) %>%
    step_YeoJohnson(runtime)

xgboost_recipe %>% prep() %>% bake(new_data = NULL) %>% glimpse()
## Rows: 33,236
## Columns: 42
## $ id                          <dbl> 551058, 554922, 674475, 43592, 728236, 274…
## $ runtime                     <dbl> 0.000000, 73.853177, 4.065768, 101.773129,…
## $ budget                      <dbl> 0.0e+00, 0.0e+00, 1.2e+01, 0.0e+00, 0.0e+0…
## $ vote_average                <dbl> 2.197225, 1.791759, 2.397895, 2.014903, 2.…
## $ release_date_year           <int> 2016, 1993, 2019, 2000, 2012, 1973, 2016, …
## $ genre_names_Adventure       <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ genre_names_Animation       <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ genre_names_Comedy          <dbl> 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, …
## $ genre_names_Crime           <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ genre_names_Documentary     <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ genre_names_Drama           <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ genre_names_Family          <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ genre_names_Fantasy         <dbl> 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ genre_names_History         <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ genre_names_Horror          <dbl> 0, 1, 0, 1, 1, 1, 0, 0, 0, 1, 0, 1, 1, 1, …
## $ genre_names_Music           <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ genre_names_Mystery         <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, …
## $ genre_names_Romance         <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, …
## $ genre_names_Science.Fiction <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ genre_names_Thriller        <dbl> 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, …
## $ genre_names_TV.Movie        <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ genre_names_War             <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ genre_names_Western         <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ original_language_es        <dbl> 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ original_language_other     <dbl> 0, 0, 0, 1, 1, 1, 0, 0, 1, 1, 1, 0, 0, 0, …
## $ release_date_dow_Mon        <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ release_date_dow_Tue        <dbl> 0, 0, 0, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0, …
## $ release_date_dow_Wed        <dbl> 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, …
## $ release_date_dow_Thu        <dbl> 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, …
## $ release_date_dow_Fri        <dbl> 0, 1, 1, 1, 0, 1, 0, 0, 1, 0, 0, 0, 0, 1, …
## $ release_date_dow_Sat        <dbl> 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 0, …
## $ release_date_month_Feb      <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ release_date_month_Mar      <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ release_date_month_Apr      <dbl> 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ release_date_month_May      <dbl> 1, 0, 0, 0, 0, 0, 0, 1, 0, 1, 1, 0, 0, 0, …
## $ release_date_month_Jun      <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, …
## $ release_date_month_Jul      <dbl> 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, …
## $ release_date_month_Aug      <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, …
## $ release_date_month_Sep      <dbl> 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ release_date_month_Oct      <dbl> 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, …
## $ release_date_month_Nov      <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ release_date_month_Dec      <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
xgboost_spec <- 
  boost_tree(trees = tune(), min_n = tune()) %>% 
  set_mode("regression") %>% 
  set_engine("xgboost") 

xgboost_workflow <- 
  workflow() %>% 
  add_recipe(xgboost_recipe) %>% 
  add_model(xgboost_spec) 

set.seed(1027)
xgboost_tune <-
  tune_grid(xgboost_workflow, resamples = data_cv, grid = 5)
## Warning: package 'xgboost' was built under R version 4.3.3

Evaluate Models

tune::show_best(xgboost_tune, metric = "rmse")
## # A tibble: 5 × 8
##   trees min_n .metric .estimator  mean     n std_err .config             
##   <int> <int> <chr>   <chr>      <dbl> <int>   <dbl> <chr>               
## 1   757     2 rmse    standard   0.265    10 0.00164 Preprocessor1_Model1
## 2  1425    16 rmse    standard   0.268    10 0.00162 Preprocessor1_Model2
## 3  1872    20 rmse    standard   0.268    10 0.00173 Preprocessor1_Model3
## 4   807    28 rmse    standard   0.276    10 0.00210 Preprocessor1_Model4
## 5   155    35 rmse    standard   0.287    10 0.00227 Preprocessor1_Model5
# Update model by selecting best hyperparameters
xgboost_fw <- tune::finalize_workflow(xgboost_workflow,
                        tune::select_best(xgboost_tune, metric = "rmse"))

# Fit the model on the entire training data and test it on the test data.
data_fit <- tune::last_fit(xgboost_fw, data_split)
tune::collect_metrics(data_fit)
## # A tibble: 2 × 4
##   .metric .estimator .estimate .config             
##   <chr>   <chr>          <dbl> <chr>               
## 1 rmse    standard       0.260 Preprocessor1_Model1
## 2 rsq     standard       0.350 Preprocessor1_Model1
tune::collect_predictions(data_fit) %>%
    ggplot(aes(vote_average, .pred)) +
    geom_point(alpha = 0.3, fill = "midnightblue") +
    geom_abline(lty = 2, color = "gray50") +
    coord_fixed()

Make Predictions