tmdb04

ds1

tidymodels

statlearning

tmdb

random-forest

num

Published

May 17, 2023

Aufgabe

Wir bearbeiten hier die Fallstudie TMDB Box Office Prediction - Can you predict a movie’s worldwide box office revenue?, ein Kaggle-Prognosewettbewerb.

Ziel ist es, genaue Vorhersagen zu machen, in diesem Fall für Filme.

Die Daten können Sie von der Kaggle-Projektseite beziehen oder so:

d_train_path <- "https://raw.githubusercontent.com/sebastiansauer/Lehre/main/data/tmdb-box-office-prediction/train.csv"
d_test_path <- "https://raw.githubusercontent.com/sebastiansauer/Lehre/main/data/tmdb-box-office-prediction/test.csv"

Aufgabe

Reichen Sie bei Kaggle eine Submission für die Fallstudie ein! Berichten Sie den Score!

Hinweise:

Sie müssen sich bei Kaggle ein Konto anlegen (kostenlos und anonym möglich); alternativ können Sie sich mit einem Google-Konto anmelden.
Halten Sie das Modell so einfach wie möglich. Verwenden Sie als Algorithmus die lineare Regression ohne weitere Schnörkel.
Logarithmieren Sie budget und revenue.
Minimieren Sie die Vorverarbeitung (steps) so weit als möglich.
Verwenden Sie tidymodels.
Die Zielgröße ist revenue in Dollars; nicht in “Log-Dollars”. Sie müssen also rücktransformieren, wenn Sie revenue logarithmiert haben, bevor Sie Ihre Prognose einreichen.

Lösung

Vorbereitung

library(tidyverse)
library(tidymodels)
library(finetune)
library(doParallel)
library(tictoc)

d_train_raw <- read_csv(d_train_path)
d_test_raw <- read_csv(d_test_path)

Sicher ist sicher:

d_train_backup <- d_train_raw

Mal einen Blick werfen:

glimpse(d_train_raw)

Rows: 3,000
Columns: 23
$ id                    <dbl> 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 1…
$ belongs_to_collection <chr> "[{'id': 313576, 'name': 'Hot Tub Time Machine C…
$ budget                <dbl> 1.40e+07, 4.00e+07, 3.30e+06, 1.20e+06, 0.00e+00…
$ genres                <chr> "[{'id': 35, 'name': 'Comedy'}]", "[{'id': 35, '…
$ homepage              <chr> NA, NA, "http://sonyclassics.com/whiplash/", "ht…
$ imdb_id               <chr> "tt2637294", "tt0368933", "tt2582802", "tt182148…
$ original_language     <chr> "en", "en", "en", "hi", "ko", "en", "en", "en", …
$ original_title        <chr> "Hot Tub Time Machine 2", "The Princess Diaries …
$ overview              <chr> "When Lou, who has become the \"father of the In…
$ popularity            <dbl> 6.575393, 8.248895, 64.299990, 3.174936, 1.14807…
$ poster_path           <chr> "/tQtWuwvMf0hCc2QR2tkolwl7c3c.jpg", "/w9Z7A0GHEh…
$ production_companies  <chr> "[{'name': 'Paramount Pictures', 'id': 4}, {'nam…
$ production_countries  <chr> "[{'iso_3166_1': 'US', 'name': 'United States of…
$ release_date          <chr> "2/20/15", "8/6/04", "10/10/14", "3/9/12", "2/5/…
$ runtime               <dbl> 93, 113, 105, 122, 118, 83, 92, 84, 100, 91, 119…
$ spoken_languages      <chr> "[{'iso_639_1': 'en', 'name': 'English'}]", "[{'…
$ status                <chr> "Released", "Released", "Released", "Released", …
$ tagline               <chr> "The Laws of Space and Time are About to be Viol…
$ title                 <chr> "Hot Tub Time Machine 2", "The Princess Diaries …
$ Keywords              <chr> "[{'id': 4379, 'name': 'time travel'}, {'id': 96…
$ cast                  <chr> "[{'cast_id': 4, 'character': 'Lou', 'credit_id'…
$ crew                  <chr> "[{'credit_id': '59ac067c92514107af02c8c8', 'dep…
$ revenue               <dbl> 12314651, 95149435, 13092000, 16000000, 3923970,…

Train-Set verschlanken

d_train_raw_reduced <-
  d_train_raw %>% 
  select(id, popularity, runtime, revenue, budget)

Test-Set verschlanken

d_test <-
  d_test_raw %>% 
  select(id,popularity, runtime, budget)

Outcome logarithmieren

Der Outcome sollte nicht im Rezept transformiert werden (vgl. Part 3, S. 30, in dieser Unterlage).

d_train <-
  d_train_raw_reduced %>% 
  mutate(revenue = if_else(revenue < 10, 10, revenue)) %>% 
  mutate(revenue = log(revenue))

Prüfen, ob das funktioniert hat:

d_train$revenue %>% is.infinite() %>% any()

[1] FALSE

Keine unendlichen Werte mehr, auf dieser Basis können wir weitermachen.

Fehlende Werte prüfen

Welche Spalten haben viele fehlende Werte?

library(easystats)
describe_distribution(d_train)

Variable   |     Mean |       SD |      IQR |              Range | Skewness | Kurtosis |    n | n_Missing
---------------------------------------------------------------------------------------------------------
id         |  1500.50 |   866.17 |  1500.50 |    [1.00, 3000.00] |     0.00 |    -1.20 | 3000 |         0
popularity |     8.46 |    12.10 |     6.88 | [1.00e-06, 294.34] |    14.38 |   280.10 | 3000 |         0
runtime    |   107.86 |    22.09 |    24.00 |     [0.00, 338.00] |     1.02 |     8.19 | 2998 |         2
revenue    |    15.97 |     3.04 |     3.37 |      [2.30, 21.14] |    -1.60 |     3.82 | 3000 |         0
budget     | 2.25e+07 | 3.70e+07 | 2.90e+07 |   [0.00, 3.80e+08] |     3.10 |    13.23 | 3000 |         0

sum_isna <- function(x) {sum(is.na(x))}

d_train %>% 
  summarise(across(everything(), sum_isna))

# A tibble: 1 × 5
     id popularity runtime revenue budget
  <int>      <int>   <int>   <int>  <int>
1     0          0       2       0      0

Rezept

Rezept definieren

rec2 <-
  recipe(revenue ~ ., data = d_train) %>% 
  step_mutate(budget = ifelse(budget == 0, NA, budget)) %>%  # log mag keine 0
  step_log(budget) %>% 
  step_impute_knn(all_predictors()) %>% 
  step_dummy(all_nominal_predictors())  %>% 
  update_role(id, new_role = "id")

rec2

Schauen Sie mal, der Log mag keine Nullen:

x <- c(1,2, NA, 0)

log(x)

[1] 0.0000000 0.6931472        NA      -Inf

Da \(log(0) = -\infty\). Aus dem Grund wandeln wir 0 lieber in NA um.

tidy(rec2)

# A tibble: 4 × 6
  number operation type       trained skip  id              
   <int> <chr>     <chr>      <lgl>   <lgl> <chr>           
1      1 step      mutate     FALSE   FALSE mutate_5IvPK    
2      2 step      log        FALSE   FALSE log_HuvzM       
3      3 step      impute_knn FALSE   FALSE impute_knn_bzUap
4      4 step      dummy      FALSE   FALSE dummy_Gm3kh

Check das Rezept

Wir berechnen das Rezept:

rec2_prepped <-
  prep(rec2, verbose = TRUE)

oper 1 step mutate [training] 
oper 2 step log [training] 
oper 3 step impute knn [training] 
oper 4 step dummy [training] 
The retained training set is ~ 0.12 Mb  in memory.

rec2_prepped

Das ist noch nicht auf einen Datensatz angewendet! Lediglich die steps wurden vorbereitet, “präpariert”: z.B. “Diese Dummy-Variablen impliziert das Rezept”.

So sieht das dann aus, wenn man das präparierte Rezept auf das Train-Sample anwendet:

d_train_baked2 <-
  rec2_prepped %>% 
  bake(new_data = NULL) 

head(d_train_baked2)

# A tibble: 6 × 5
     id popularity runtime budget revenue
  <dbl>      <dbl>   <dbl>  <dbl>   <dbl>
1     1      6.58       93   16.5    16.3
2     2      8.25      113   17.5    18.4
3     3     64.3       105   15.0    16.4
4     4      3.17      122   14.0    16.6
5     5      1.15      118   15.8    15.2
6     6      0.743      83   15.9    15.0

d_train_baked2 %>% 
  map_df(sum_isna)

# A tibble: 1 × 5
     id popularity runtime budget revenue
  <int>      <int>   <int>  <int>   <int>
1     0          0       0      0       0

Keine fehlenden Werte mehr in den Prädiktoren.

Nach fehlenden Werten könnte man z.B. auch so suchen:

datawizard::describe_distribution(d_train_baked2)

Variable   |    Mean |     SD |     IQR |              Range | Skewness | Kurtosis |    n | n_Missing
-----------------------------------------------------------------------------------------------------
id         | 1500.50 | 866.17 | 1500.50 |    [1.00, 3000.00] |     0.00 |    -1.20 | 3000 |         0
popularity |    8.46 |  12.10 |    6.88 | [1.00e-06, 294.34] |    14.38 |   280.10 | 3000 |         0
runtime    |  107.85 |  22.08 |   24.00 |     [0.00, 338.00] |     1.02 |     8.20 | 3000 |         0
budget     |   16.09 |   1.89 |    1.90 |      [0.00, 19.76] |    -2.93 |    18.71 | 3000 |         0
revenue    |   15.97 |   3.04 |    3.37 |      [2.30, 21.14] |    -1.60 |     3.82 | 3000 |         0

So bekommt man gleich noch ein paar Infos über die Verteilung der Variablen. Praktische Sache.

Check Test-Sample

Das Test-Sample backen wir auch mal, um zu prüfen, das alles läuft:

d_test_baked2 <-
  bake(rec2_prepped, new_data = d_test)

d_test_baked2 %>% 
  head()

# A tibble: 6 × 4
     id popularity runtime budget
  <dbl>      <dbl>   <dbl>  <dbl>
1  3001       3.85      90   15.8
2  3002       3.56      65   11.4
3  3003       8.09     100   16.4
4  3004       8.60     130   15.7
5  3005       3.22      92   14.5
6  3006       8.68     121   16.1

Sieht soweit gut aus.

Kreuzvalidierung / Resampling

Hier ist nur aus Gründen der Rechenzeit auf kleine Werte von \(v\) und \(r\) ausgewichen worden. Besser wäre z.B. \(v=10\) und \(r=3\).

cv_scheme <- vfold_cv(d_train,
                      v = 3, 
                      repeats = 1)

Modelle

LM

mod_lm <-
  linear_reg()

Workflow-Set

Hier nur ein sehr kleiner Workflow-Set.

Das ist übrigens eine gute Strategie: Erstmal mit einem kleinen Prozess anfangen, und dann sukzessive erweitern.

preproc2 <- list(rec1 = rec2)
models2 <- list(lm1 = mod_lm)
 
 
all_workflows2 <- workflow_set(preproc2, models2)

Fitten und tunen

tmdb_model_set2 <-
    all_workflows2 %>% 
    workflow_map(resamples = cv_scheme,
                 control = control_grid(verbose = TRUE),
                 fn = "tune_race_anova")

Finalisieren

tmdb_model_set2 %>% 
  collect_metrics() %>% 
  arrange(-mean) %>% 
  head(10)

# A tibble: 2 × 9
  wflow_id .config          preproc model .metric .estimator  mean     n std_err
  <chr>    <chr>            <chr>   <chr> <chr>   <chr>      <dbl> <int>   <dbl>
1 rec1_lm1 Preprocessor1_M… recipe  line… rmse    standard   2.46      3  0.119 
2 rec1_lm1 Preprocessor1_M… recipe  line… rsq     standard   0.349     3  0.0326

best_model_params2 <-
extract_workflow_set_result(tmdb_model_set2, "rec1_lm1") %>% 
  select_best()

Warning: No value of `metric` was given; metric 'rmse' will be used.

best_model_params2

# A tibble: 1 × 1
  .config             
  <chr>               
1 Preprocessor1_Model1

Finalisieren

Finalisieren bedeutet:

Besten Workflow identifizieren (zur Erinnerung: Workflow = Rezept + Modell)
Den besten Workflow mit den optimalen Modell-Parametern ausstatten
Damit dann den ganzen Train-Datensatz fitten
Auf dieser Basis das Test-Sample vorhersagen

best_wf2 <- 
all_workflows2 %>% 
  extract_workflow("rec1_lm1")

best_wf2

══ Workflow ════════════════════════════════════════════════════════════════════
Preprocessor: Recipe
Model: linear_reg()

── Preprocessor ────────────────────────────────────────────────────────────────
4 Recipe Steps

• step_mutate()
• step_log()
• step_impute_knn()
• step_dummy()

── Model ───────────────────────────────────────────────────────────────────────
Linear Regression Model Specification (regression)

Computational engine: lm

best_wf_finalized2 <- 
  best_wf2 %>% 
  finalize_workflow(best_model_params2)

best_wf_finalized2

══ Workflow ════════════════════════════════════════════════════════════════════
Preprocessor: Recipe
Model: linear_reg()

── Preprocessor ────────────────────────────────────────────────────────────────
4 Recipe Steps

• step_mutate()
• step_log()
• step_impute_knn()
• step_dummy()

── Model ───────────────────────────────────────────────────────────────────────
Linear Regression Model Specification (regression)

Computational engine: lm

Final Fit

fit_final2 <-
  best_wf_finalized2 %>% 
  fit(d_train)

fit_final2

══ Workflow [trained] ══════════════════════════════════════════════════════════
Preprocessor: Recipe
Model: linear_reg()

── Preprocessor ────────────────────────────────────────────────────────────────
4 Recipe Steps

• step_mutate()
• step_log()
• step_impute_knn()
• step_dummy()

── Model ───────────────────────────────────────────────────────────────────────

Call:
stats::lm(formula = ..y ~ ., data = data)

Coefficients:
(Intercept)   popularity      runtime       budget  
    1.26186      0.03755      0.01289      0.80752

preds <- 
fit_final2 %>% 
  predict(new_data = d_test)

head(preds)

# A tibble: 6 × 1
  .pred
  <dbl>
1  15.3
2  11.4
3  16.1
4  16.0
5  14.3
6  16.1

Achtung, wenn die Outcome-Variable im Rezept verändert wurde, dann würde obiger Code nicht durchlaufen.

Grund ist hier beschrieben:

When predict() is used, it only has access to the predictors (mirroring how this would work with new samples). Even if the outcome column is present, it is not exposed to the recipe. This is generally a good idea so that we can avoid information leakage.

One approach is the use the skip = TRUE option in step_log() so that it will avoid that step during predict() and/or bake(). However, if you are using this recipe with the tune package, there will still be an issue because the metric function(s) would get the predictions in log units and the observed outcome in the original units.

The better approach is, for simple transformations like yours, to log the outcome outside of the recipe (before data analysis and the initial split).

Submission df

submission_df <-
  d_test %>% 
  select(id) %>% 
  bind_cols(preds) %>% 
  rename(revenue = .pred)

head(submission_df)

# A tibble: 6 × 2
     id revenue
  <dbl>   <dbl>
1  3001    15.3
2  3002    11.4
3  3003    16.1
4  3004    16.0
5  3005    14.3
6  3006    16.1

Zurücktransformieren

submission_df <-
  submission_df %>% 
  mutate(revenue = exp(revenue)-1)

head(submission_df)

# A tibble: 6 × 2
     id   revenue
  <dbl>     <dbl>
1  3001  4435143.
2  3002    91755.
3  3003  9782986.
4  3004  8573795.
5  3005  1598106.
6  3006 10061439.

Hier ein Beispiel, warum \(e^x-1\) genauer ist für kleine Zahlen als \(e^x\).

Abspeichern und einreichen:

write_csv(submission_df, file = "submission.csv")

Kaggle Score

Diese Submission erzielte einen Score von Score: 2.46249 (RMSLE).

sol <- 2.5

Categories:

ds1
tidymodels
statlearning
tmdb
random-forest
num