O problema a seguir trata da construção de um modelo para realizar predições númericas de scores de filmes catalogados pelo IMDb (Internet Movie Database) e Rotten Tomatos. Os dados utilizados são amostras de descrições e revisões extraídas do MovieLens, IMDb e Rotten Tomatoes. Em resumo, os dados apresentam informações sobre os filmes (nome, diretor, gênero, atores, localidade, etc) e suas avaliações nos dois maiores sites de mídia social sobre filmes. Para maiores informações, baixe os dados aqui e leia o o arquivo readme.txt para detalhes sobre cada variável. 

library(dplyr, quietly=TRUE)
library(wordcloud, quietly=TRUE)
library(RColorBrewer, quietly=TRUE)

movies <- read.delim("~/Documents/ad1/problema7/movies.dat")
colnames(movies)[which(names(movies) == "id")] <- "movieID"
rt_not_using <- movies  %>% select(rtAudienceRating, rtAudienceNumRatings,spanishTitle, imdbPictureURL, rtPictureURL )
movies <- movies %>% select(-rtAudienceRating, -rtAudienceNumRatings, -spanishTitle, -imdbPictureURL, -rtPictureURL )

movies$rtAllCriticsRating <- as.numeric(as.character(movies$rtAllCriticsRating))
movies$rtAllCriticsRating[is.na(movies$rtAllCriticsRating)] = 0

movies$rtAllCriticsNumReviews <- as.numeric(as.character(movies$rtAllCriticsNumReviews))
movies$rtAllCriticsNumReviews[is.na(movies$rtAllCriticsNumReviews)] = 0

movies$rtAllCriticsNumFresh <- as.numeric(as.character(movies$rtAllCriticsNumFresh))
movies$rtAllCriticsNumFresh[is.na(movies$rtAllCriticsNumFresh)] = 0

movies$rtAllCriticsNumRotten <- as.numeric(as.character(movies$rtAllCriticsNumRotten))
movies$rtAllCriticsNumRotten[is.na(movies$rtAllCriticsNumRotten)] = 0

movies$rtAllCriticsScore <- as.numeric(as.character(movies$rtAllCriticsScore))
movies$rtAllCriticsScore[is.na(movies$rtAllCriticsScore)] = 0

movies$rtTopCriticsRating <- as.numeric(as.character(movies$rtTopCriticsRating))
movies$rtTopCriticsRating[is.na(movies$rtTopCriticsRating)] = 0

movies$rtTopCriticsNumReviews <- as.numeric(as.character(movies$rtTopCriticsNumReviews))
movies$rtTopCriticsNumReviews[is.na(movies$rtTopCriticsNumReviews)] = 0

movies$rtTopCriticsNumFresh <- as.numeric(as.character(movies$rtTopCriticsNumFresh))
movies$rtTopCriticsNumFresh[is.na(movies$rtTopCriticsNumFresh)] = 0

movies$rtTopCriticsNumRotten <- as.numeric(as.character(movies$rtTopCriticsNumRotten))
movies$rtTopCriticsNumRotten[is.na(movies$rtTopCriticsNumRotten)] = 0

movies$rtTopCriticsScore <- as.numeric(as.character(movies$rtTopCriticsScore))
movies$rtTopCriticsScore[is.na(movies$rtTopCriticsScore)] = 0

movies$rtAudienceScore <- as.numeric(as.character(movies$rtAudienceScore))
movies$rtAudienceScore[is.na(movies$rtAudienceScore)] = 0
movies <- movies[,c(1,2,3,5,4,6,7,8,9,10,11,12,13,14,15,16)]


summary(movies)
##     movieID     
##  Min.   :    1  
##  1st Qu.: 2780  
##  Median : 5421  
##  Mean   :12853  
##  3rd Qu.: 8664  
##  Max.   :65133  
##                 
##                                                 title      
##  Hamlet                                            :    6  
##  The Phantom of the Opera                          :    6  
##  August Rush                                       :    4  
##  DOA: Dead or Alive                                :    4  
##  Dracula                                           :    4  
##  Interview with the Vampire: The Vampire Chronicles:    4  
##  (Other)                                           :10169  
##      imdbID                                            rtID     
##  Min.   :    439                                         : 311  
##  1st Qu.:  82200   1075422-hamlet                        :   6  
##  Median : 113057   phantom_of_the_opera                  :   5  
##  Mean   : 202188   1010678-invasion_of_the_body_snatchers:   4  
##  3rd Qu.: 281724   august_rush                           :   4  
##  Max.   :1349938   beach                                 :   4  
##                    (Other)                               :9863  
##       year      rtAllCriticsRating rtAllCriticsNumReviews
##  Min.   :1903   Min.   :0.000      Min.   :  0.00        
##  1st Qu.:1981   1st Qu.:3.900      1st Qu.:  7.00        
##  Median :1995   Median :5.800      Median : 21.00        
##  Mean   :1988   Mean   :5.023      Mean   : 41.86        
##  3rd Qu.:2002   3rd Qu.:7.000      3rd Qu.: 55.00        
##  Max.   :2011   Max.   :9.600      Max.   :281.00        
##                                                          
##  rtAllCriticsNumFresh rtAllCriticsNumRotten rtAllCriticsScore
##  Min.   :  0.00       Min.   :  0.00        Min.   :  0.00   
##  1st Qu.:  3.00       1st Qu.:  1.00        1st Qu.: 26.00   
##  Median : 12.00       Median :  5.00        Median : 62.00   
##  Mean   : 25.24       Mean   : 16.62        Mean   : 55.43   
##  3rd Qu.: 32.00       3rd Qu.: 19.00        3rd Qu.: 85.00   
##  Max.   :265.00       Max.   :171.00        Max.   :100.00   
##                                                              
##  rtTopCriticsRating rtTopCriticsNumReviews rtTopCriticsNumFresh
##  Min.   : 0.000     Min.   : 0.000         Min.   : 0.000      
##  1st Qu.: 0.000     1st Qu.: 0.000         1st Qu.: 0.000      
##  Median : 0.000     Median : 4.000         Median : 2.000      
##  Mean   : 2.711     Mean   : 9.535         Mean   : 5.332      
##  3rd Qu.: 5.800     3rd Qu.:15.000         3rd Qu.: 7.000      
##  Max.   :10.000     Max.   :48.000         Max.   :42.000      
##                                                                
##  rtTopCriticsNumRotten rtTopCriticsScore rtAudienceScore 
##  Min.   : 0.000        Min.   :  0.00    Min.   :  0.00  
##  1st Qu.: 0.000        1st Qu.:  0.00    1st Qu.:  0.00  
##  Median : 1.000        Median : 34.00    Median : 56.00  
##  Mean   : 4.203        Mean   : 40.67    Mean   : 47.25  
##  3rd Qu.: 5.000        3rd Qu.: 77.00    3rd Qu.: 75.00  
##  Max.   :38.000        Max.   :100.00    Max.   :100.00  
##

Dentre os dados fornecidos no arquivo movies.dat, foram selecionadas as variáveis que possuem uma maior relevância para o treino de um modelo e pré-processamento de novas variáveis a serem utilizadas. São elas:

correlationMatrix <- cor(movies[,5:16])
print(correlationMatrix)
##                               year rtAllCriticsRating
## year                    1.00000000        -0.08697184
## rtAllCriticsRating     -0.08697184         1.00000000
## rtAllCriticsNumReviews  0.44896295         0.31657222
## rtAllCriticsNumFresh    0.31786942         0.44526785
## rtAllCriticsNumRotten   0.44139360         0.01358606
## rtAllCriticsScore      -0.29074063         0.73467776
## rtTopCriticsRating      0.40648775         0.44070261
## rtTopCriticsNumReviews  0.51125813         0.28248214
## rtTopCriticsNumFresh    0.39028201         0.40263772
## rtTopCriticsNumRotten   0.44441316         0.02131484
## rtTopCriticsScore       0.06877740         0.66385044
## rtAudienceScore         0.20406194         0.65415288
##                        rtAllCriticsNumReviews rtAllCriticsNumFresh
## year                                0.4489629            0.3178694
## rtAllCriticsRating                  0.3165722            0.4452679
## rtAllCriticsNumReviews              1.0000000            0.8749527
## rtAllCriticsNumFresh                0.8749527            1.0000000
## rtAllCriticsNumRotten               0.7584292            0.3480042
## rtAllCriticsScore                   0.1096032            0.3600583
## rtTopCriticsRating                  0.6492456            0.6626118
## rtTopCriticsNumReviews              0.9599808            0.8142587
## rtTopCriticsNumFresh                0.8262553            0.9404940
## rtTopCriticsNumRotten               0.7224335            0.3253858
## rtTopCriticsScore                   0.2992591            0.4766734
## rtAudienceScore                     0.4294734            0.4675750
##                        rtAllCriticsNumRotten rtAllCriticsScore
## year                              0.44139360       -0.29074063
## rtAllCriticsRating                0.01358606        0.73467776
## rtAllCriticsNumReviews            0.75842919        0.10960320
## rtAllCriticsNumFresh              0.34800424        0.36005829
## rtAllCriticsNumRotten             1.00000000       -0.27243998
## rtAllCriticsScore                -0.27243998        1.00000000
## rtTopCriticsRating                0.36513684        0.26334658
## rtTopCriticsNumReviews            0.76264209        0.06554977
## rtTopCriticsNumFresh              0.33381591        0.31484339
## rtTopCriticsNumRotten             0.96075244       -0.26055438
## rtTopCriticsScore                -0.06220698        0.62509744
## rtAudienceScore                   0.20215206        0.43800439
##                        rtTopCriticsRating rtTopCriticsNumReviews
## year                            0.4064878             0.51125813
## rtAllCriticsRating              0.4407026             0.28248214
## rtAllCriticsNumReviews          0.6492456             0.95998076
## rtAllCriticsNumFresh            0.6626118             0.81425867
## rtAllCriticsNumRotten           0.3651368             0.76264209
## rtAllCriticsScore               0.2633466             0.06554977
## rtTopCriticsRating              1.0000000             0.70566554
## rtTopCriticsNumReviews          0.7056655             1.00000000
## rtTopCriticsNumFresh            0.7313300             0.84645457
## rtTopCriticsNumRotten           0.3824004             0.76963187
## rtTopCriticsScore               0.5119578             0.30207479
## rtAudienceScore                 0.5517378             0.43777283
##                        rtTopCriticsNumFresh rtTopCriticsNumRotten
## year                              0.3902820            0.44441316
## rtAllCriticsRating                0.4026377            0.02131484
## rtAllCriticsNumReviews            0.8262553            0.72243351
## rtAllCriticsNumFresh              0.9404940            0.32538578
## rtAllCriticsNumRotten             0.3338159            0.96075244
## rtAllCriticsScore                 0.3148434           -0.26055438
## rtTopCriticsRating                0.7313300            0.38240036
## rtTopCriticsNumReviews            0.8464546            0.76963187
## rtTopCriticsNumFresh              1.0000000            0.31148854
## rtTopCriticsNumRotten             0.3114885            1.00000000
## rtTopCriticsScore                 0.5164290           -0.08016954
## rtAudienceScore                   0.4617981            0.22751165
##                        rtTopCriticsScore rtAudienceScore
## year                          0.06877740       0.2040619
## rtAllCriticsRating            0.66385044       0.6541529
## rtAllCriticsNumReviews        0.29925912       0.4294734
## rtAllCriticsNumFresh          0.47667337       0.4675750
## rtAllCriticsNumRotten        -0.06220698       0.2021521
## rtAllCriticsScore             0.62509744       0.4380044
## rtTopCriticsRating            0.51195785       0.5517378
## rtTopCriticsNumReviews        0.30207479       0.4377728
## rtTopCriticsNumFresh          0.51642904       0.4617981
## rtTopCriticsNumRotten        -0.08016954       0.2275117
## rtTopCriticsScore             1.00000000       0.7148116
## rtAudienceScore               0.71481158       1.0000000

Na matriz de correlação acima podemos observar quais atributos estão mais correlacionados entre si. É possível observar que os atributos relacionados a contagem representam altas correlacões, algo que já era de se esperar pois são variáreis derivadas de outros atributos no dataset. Podemos citar como exemplo o caso da variável rtAllCriticsNumReviews que representa a soma das variáveis rtAllCriticsNumFresh e rtAllCriticsNumRotten.

Pré-Processamento dos dados

Nesta fase serão formadas novas variáveis a partir dos atributos mencionados acima. Outros datasets que são utilizidados serão citados mais adiante.

Sobre Popularidade e Reputação:

Como este problema envolve produtos/serviços (no caso, os filmes) que demandam opinião pública, é interessante frisar o conceito entendido por popularidade e reputação para que se dê um sentido as variáveis aqui geradas.

Sendo assim, para este problema, é entendido como “popular” as observações com um número elevado de ocorrências, onde estas se destacam diante dos demais elementos da mesma classe. Como exemplo deste conceito podemos citar um ator que participa de muitos filmes. Neste caso, este ator é entendido como um ator popular.

Já o conceito de reputação é entendido como sendo algo que é bem ou mal-avaliado de acordo com o número de avaliações feitas. A ideia é similar a de popularidade, com a diferença de que as observações não são comparadas entre si, considerando apenas as avaliações feitas para uma dada observação.

A justificativa para utilizar tais conceitos parte da ideia de que se algo é considerado popular, isto deve agradar um público em geral, pois caso contrário não seria popular.

Variável rtAllCriticsReputation:

rtAllCritics <-  movies %>% select(rtAllCriticsScore, rtAllCriticsRating,rtAllCriticsNumReviews, rtAllCriticsNumFresh, rtAllCriticsNumRotten)

rtAllCritics$rtAllCriticsReputation <- round(rtAllCritics$rtAllCriticsNumFresh/rtAllCritics$rtAllCriticsNumReviews, digits = 2)
rtAllCritics$rtAllCriticsReputation[is.na(rtAllCritics$rtAllCriticsReputation)] = 0
rtAllCritics <- rtAllCritics %>% select(rtAllCriticsScore, rtAllCriticsRating,rtAllCriticsReputation)
summary(rtAllCritics)
##  rtAllCriticsScore rtAllCriticsRating rtAllCriticsReputation
##  Min.   :  0.00    Min.   :0.000      Min.   :0.0000        
##  1st Qu.: 26.00    1st Qu.:3.900      1st Qu.:0.2700        
##  Median : 62.00    Median :5.800      Median :0.6200        
##  Mean   : 55.43    Mean   :5.023      Mean   :0.5575        
##  3rd Qu.: 85.00    3rd Qu.:7.000      3rd Qu.:0.8600        
##  Max.   :100.00    Max.   :9.600      Max.   :1.0000

A partir das variáveis de prefixo rtAllCritics foi gerada uma variável referente a reputação de um filme baseada nas críticas. Sendo assim, um filme com uma boa reputação possui valor próximo ou máximo igual a 1, e um filme com baixa reputação valor próximo ou igual a 0.

Variável rtTopCriticsReputation:

rtTopCritics <- movies %>% select(rtTopCriticsScore, rtTopCriticsRating,rtTopCriticsNumReviews, rtTopCriticsNumFresh, rtTopCriticsNumRotten)

rtTopCritics$rtTopCriticsReputation <- round(rtTopCritics$rtTopCriticsNumFresh / rtTopCritics$rtTopCriticsNumReviews, digits = 2)
rtTopCritics$rtTopCriticsReputation[is.na(rtTopCritics$rtTopCriticsReputation)] = 0
rtTopCritics <- rtTopCritics %>% select(rtTopCriticsScore, rtTopCriticsRating, rtTopCriticsReputation)
summary(rtTopCritics)
##  rtTopCriticsScore rtTopCriticsRating rtTopCriticsReputation
##  Min.   :  0.00    Min.   : 0.000     Min.   :0.0000        
##  1st Qu.:  0.00    1st Qu.: 0.000     1st Qu.:0.0000        
##  Median : 34.00    Median : 0.000     Median :0.3500        
##  Mean   : 40.67    Mean   : 2.711     Mean   :0.4084        
##  3rd Qu.: 77.00    3rd Qu.: 5.800     3rd Qu.:0.7800        
##  Max.   :100.00    Max.   :10.000     Max.   :1.0000

Similar a variável anterior, esta tenta explicar a reputação de um filme baseada nas melhores críticas feitas aos filmes.

Movie Directors

Os dados a seguir são referentes as seguintes informações dos filmes:

movies_directors <- read.delim("~/Documents/ad1/problema7/movie_directors.dat")
summary(movies_directors)
##     movieID                 directorID             directorName 
##  Min.   :    1   alfred_hitchcock:  48   Alfred Hitchcock:  48  
##  1st Qu.: 2780   woody_allen     :  40   Woody Allen     :  40  
##  Median : 5426   clint_eastwood  :  32   Clint Eastwood  :  32  
##  Mean   :12861   akira_kurosawa  :  30   Akira Kurosawa  :  30  
##  3rd Qu.: 8666   martin_scorsese :  30   Martin Scorsese :  30  
##  Max.   :65133   steven_spielberg:  29   Steven Spielberg:  29  
##                  (Other)         :9946   (Other)         :9946
movies_directors <- arrange(movies_directors, directorName)

directors <- movies_directors %>% group_by(directorName) %>% summarise(num_movies = n()) %>% arrange(-num_movies)
directors <- data.frame(directors)
directors <- directors %>% arrange(-num_movies)
Diretores mais populares

A nuvem de palavras acima (ou mais conhecida como cloudword) exibe os diretores que mais dirigiram filmes nos dados de estudo. No dataset consta pouco mais de 4 mil nomes. Na imagem acima estão os 100 nomes com mais títulos dirigidos.

Variável director_popularity

movies_directors <- merge(movies_directors, directors,by = "directorName", all.x = TRUE)
movies_directors <- movies_directors %>% arrange(-num_movies)

movies_directors$director_popularity <- round((movies_directors$num_movies - min(movies_directors$num_movies)) /
                              (max(movies_directors$num_movies) -min(movies_directors$num_movies)), digits = 4)

Utilizando o conceito de popularidade já mencionado, foi calculada a popularidade de cada diretor, onde esta será associada aos filmes mais adiante.

Movie Actors:

Os dados a seguir são referentes as seguintes informações dos filmes:

movies_actors <- read.delim("~/Documents/ad1/problema7/movie_actors.dat")
movies_actors <- movies_actors %>% arrange(ranking)
summary(movies_actors)
##     movieID                    actorID                   actorName    
##  Min.   :    1   steve_buscemi     :   31   Steve Buscemi     :   31  
##  1st Qu.: 4341   samuel_l_jackson  :   29   Samuel L. Jackson :   29  
##  Median : 5154   christopher_walken:   25   Christopher Walken:   25  
##  Mean   :17683   frank_welker      :   23   Frank Welker      :   23  
##  3rd Qu.:48856   michael_caine     :   23   Michael Caine     :   23  
##  Max.   :65133   richard_jenkins   :   23   Richard Jenkins   :   23  
##                  (Other)           :77877   (Other)           :77877  
##     ranking      
##  Min.   :  1.00  
##  1st Qu.:  6.00  
##  Median : 13.00  
##  Mean   : 18.32  
##  3rd Qu.: 25.00  
##  Max.   :190.00  
## 
actors <- movies_actors %>% group_by(actorName) %>% summarise(num_movies = n())
actors <- actors %>% arrange(-num_movies)
Atores mais populares

A nuvem de palavras acima exibe os atores que possuem mais participações nos títulos encontrados no dataset. O dataset contém cerca de 46 mil atores. Estão registrados acima os cem nomes mais populares.

Variável cast_popularity

movies_actors <- merge(movies_actors, actors, by="actorName", all.x = TRUE)
movies_cast <- movies_actors %>% group_by(movieID) %>% summarise(cast_popularity = sum(num_movies))

movies_cast$cast_popularity <- round((movies_cast$cast_popularity - min(movies_cast$cast_popularity))/
                               (max(movies_cast$cast_popularity) - min(movies_cast$cast_popularity)), digits = 4)
movies_cast <- movies_cast %>% arrange(-cast_popularity)

A variável cast_popularity foi gerada com o intuito de explicar a popularidade do elenco dos filmes, somando a popularidade dos atores que formam o elenco de cada filme.

Movie Genres

Os dados a seguir são referentes as seguintes informações dos filmes:

movie_genres <- read.delim("~/Documents/ad1/problema7/movie_genres.dat")
summary(movie_genres)
##     movieID           genre     
##  Min.   :    1   Drama   :5076  
##  1st Qu.: 2802   Comedy  :3566  
##  Median : 5684   Thriller:1664  
##  Mean   :13906   Romance :1644  
##  3rd Qu.: 8961   Action  :1445  
##  Max.   :65133   Crime   :1086  
##                  (Other) :6328
genres_count <- movie_genres %>% group_by(genre) %>% summarise(num_movies = n())
genres_count <- genres_count %>% arrange(-num_movies)



movie_genres <- merge(movie_genres, genres_count, by = "genre", all.x = TRUE)

movie_genres <- movie_genres %>% group_by(movieID) %>% 
                summarise(genre_popularity = sum(genre_popularity=sum(num_movies)))

movie_genres$genre_popularity <- round((movie_genres$genre_popularity - min(movie_genres$genre_popularity))/
                                 (max(movie_genres$genre_popularity) - min(movie_genres$genre_popularity)), digits = 4)
Gêneros mais populares

Foram exibidos acima os genêros mais comuns aos filmes estudados neste problema. Lembrando que um filme pode ser composto por mais de um gênero. Mesmo assim, um gênero pode ser entendido como mais predominante de acordo com o enredo de um filme.

Movie Countries

Os dados a seguir são referentes as seguintes informações dos filmes:

movie_countries <- read.delim("~/Documents/ad1/problema7/movie_countries.dat")
countries_count <- movie_countries %>% group_by(country) %>% summarise(num_movies = n())
countries_count <- countries_count %>% arrange(-num_movies)

countries_count$country_popularity <- round((countries_count$num_movies - min(countries_count$num_movies))/
                                        (max(countries_count$num_movies) - min(countries_count$num_movies)), digits = 4)

movie_countries <- merge(movie_countries, countries_count, by="country", all.x=TRUE)
Países com mais filmes produzidos

É possível observar acima o destaque aos Estados Unidos e Reino Unido (UK), países estes que mais produzem filmes segundo o dataset considerado no estudo.

Ainda sobre os países de origem dos filmes, foi calculado a popularidade de um país em relação ao número de títulos que este produz. A popularidade de um filme é representada por um valor compreendido num intervalo entre 0 e 1. Esta variável é gerada a partir de uma normalização simples realizada sobre o número de ocorrências de um dado país.

Movie Tags

Os dados a seguir são referentes as seguintes informações dos filmes:

movie_tags <- read.delim("~/Documents/ad1/problema7/movie_tags.dat")
tags <- read.delim("~/Documents/ad1/problema7/tags.dat")
colnames(tags) <- c("tagID","tag")

movie_tags <- merge(movie_tags, tags, by="tagID", all.x = TRUE)


tags_count <- movie_tags %>% group_by(tag) %>% summarise(num_movies = n())
tags_count <- tags_count %>% arrange(-num_movies)

movie_tags <- merge(movie_tags, tags_count, by="tag", all.x = TRUE)

movie_tags_pop <- movie_tags %>% group_by(movieID) %>% summarise(tag_popularity = sum(num_movies))
movie_tags_pop <- movie_tags_pop %>% arrange(-tag_popularity)

movie_tags_pop$tag_popularity <- round((movie_tags_pop$tag_popularity - min(movie_tags_pop$tag_popularity))
                                       /(max(movie_tags_pop$tag_popularity) - min(movie_tags_pop$tag_popularity)),digits = 4)

movies_tag_w <- movie_tags %>% group_by(movieID) %>% summarise(tags_weight = sum(tagWeight))
movies_tag_w <- movies_tag_w %>% arrange(-tags_weight)

movies_tag_w$tags_weight <- round( (movies_tag_w$tags_weight - min(movies_tag_w$tags_weight))/
                (max(movies_tag_w$tags_weight) - min(movies_tag_w$tags_weight)),digits = 4)
Tags mais populares

As tags mais populares foram exibidas acima. Um detalhe importante é que as tags podem ser criadas pelos próprios usuários, podendo ser consideradas indícios de popularidade para um filme.

Além do número de ocorrência das tags, também foi considerado o peso que uma tag possui em um filme. O peso das tags ajuda a classificar o filme, indicando que o conteúdo de um dado filme tem mais a ver com uma tag ou outra.

Dataset para treino

Nesta etapa foi construído o dataset que será utilizado no treinamento dos modelos. Alguns pontos importantes devem ser ressaltados aqui:

O dataset dos filmes é composto por pouco mais de 10 mil observações, onde cada uma representa um filme. O trabalho de treino e teste para predição é feito tendo a rtAudienceScore como variável resposta. Sabendo disso e observando a variável em questão, foi observado que o número de observações com valor igual a zero é bastante elevado e, levantando a suspeita de que tais filmes com esses valores não foram bem avaliados. 

nrow(filter(movies, rtAudienceScore == 0))
## [1] 2855

Sendo assim, as observações com a variável resposta igual a zero foram removidas dos dados de treino e teste, afim de dar maior consistência para o treino dos modelos. Já as observações com os valores iguais a zero foram consideradas os dados reais do problema, onde utilizando o melhor modelo obtido seria feita a predição para os filmes que não possuem avaliação, sugerindo scores para os mesmos. 

df <- movies %>% select(movieID,year,rtAllCriticsRating,rtAllCriticsScore,rtTopCriticsRating,rtTopCriticsScore,
                        rtAudienceScore)

direc <- movies_directors %>% select(movieID, director_popularity)
df <- merge(df, direc, by="movieID", all.x = TRUE)

df <- merge(df, movies_cast, by="movieID", all.x = TRUE)

df <- merge(df, movie_genres, by="movieID", all.x = TRUE)

countries <- movie_countries %>% select(movieID, country_popularity)
df <- merge(df, countries, by="movieID", all.x = TRUE)

df <- merge(df, movie_tags_pop, by="movieID", all.x = TRUE)

df <- merge(df, movies_tag_w, by="movieID", all.x = TRUE)


df <- df[c(1:6,8:13,7)]
str(df)
## 'data.frame':    10197 obs. of  13 variables:
##  $ movieID            : int  1 2 3 4 5 6 7 8 9 10 ...
##  $ year               : int  1995 1995 1993 1995 1995 1995 1954 1995 1995 1995 ...
##  $ rtAllCriticsRating : num  9 5.6 5.9 5.6 5.3 7.7 7.4 4.2 5.2 6.8 ...
##  $ rtAllCriticsScore  : num  100 46 66 56 47 86 90 25 53 80 ...
##  $ rtTopCriticsRating : num  8.5 5.8 7 5.5 5.4 7.2 7.2 0 5.6 6.2 ...
##  $ rtTopCriticsScore  : num  100 40 83 45 20 82 100 50 55 63 ...
##  $ director_popularity: num  0.0851 0.1064 0.234 0.0426 0.1489 ...
##  $ cast_popularity    : num  0.365 0.262 0.245 0.291 0.228 ...
##  $ genre_popularity   : num  0.393 0.137 0.347 0.685 0.238 ...
##  $ country_popularity : num  1 1 1 1 1 ...
##  $ tag_popularity     : num  0.4224 0.0824 0.0082 NA 0.0503 ...
##  $ tags_weight        : num  0.3796 0.1306 0.0245 NA 0.0449 ...
##  $ rtAudienceScore    : num  81 61 66 79 64 92 87 45 40 78 ...
df[is.na(df)] <- 0

movies_zero_score <- df %>% filter(rtAudienceScore == 0)
df <- df %>% filter(rtAudienceScore != 0)
summary(df)
##     movieID           year      rtAllCriticsRating rtAllCriticsScore
##  Min.   :    1   Min.   :1915   Min.   :0.000      Min.   :  0.00   
##  1st Qu.: 2447   1st Qu.:1987   1st Qu.:4.925      1st Qu.: 38.00   
##  Median : 5094   Median :1997   Median :6.200      Median : 66.00   
##  Mean   :13214   Mean   :1992   Mean   :5.957      Mean   : 60.66   
##  3rd Qu.: 8681   3rd Qu.:2003   3rd Qu.:7.200      3rd Qu.: 85.00   
##  Max.   :65130   Max.   :2009   Max.   :9.600      Max.   :100.00   
##  rtTopCriticsRating rtTopCriticsScore director_popularity
##  Min.   : 0.000     Min.   :  0.0     Min.   :0.0000     
##  1st Qu.: 0.000     1st Qu.: 25.0     1st Qu.:0.0213     
##  Median : 4.600     Median : 58.0     Median :0.0851     
##  Mean   : 3.738     Mean   : 55.3     Mean   :0.1267     
##  3rd Qu.: 6.500     3rd Qu.: 88.0     3rd Qu.:0.1915     
##  Max.   :10.000     Max.   :100.0     Max.   :1.0000     
##  cast_popularity   genre_popularity country_popularity tag_popularity   
##  Min.   :0.00000   Min.   :0.0096   Min.   :0.0000     Min.   :0.00000  
##  1st Qu.:0.00000   1st Qu.:0.2376   1st Qu.:0.1485     1st Qu.:0.00000  
##  Median :0.00000   Median :0.3382   Median :1.0000     Median :0.02810  
##  Mean   :0.07279   Mean   :0.3497   Mean   :0.6989     Mean   :0.06591  
##  3rd Qu.:0.10340   3rd Qu.:0.4478   3rd Qu.:1.0000     3rd Qu.:0.08755  
##  Max.   :0.97360   Max.   :1.0000   Max.   :1.0000     Max.   :0.98350  
##   tags_weight      rtAudienceScore 
##  Min.   :0.00000   Min.   : 11.00  
##  1st Qu.:0.00000   1st Qu.: 52.00  
##  Median :0.00820   Median : 68.00  
##  Mean   :0.03159   Mean   : 65.62  
##  3rd Qu.:0.03270   3rd Qu.: 80.00  
##  Max.   :1.00000   Max.   :100.00

Treino e Teste

Os dados utilizados no modelo foram divididos em treino e teste, com proporção de 90% para o treino e 10% para teste. 

require(caret, quietly=TRUE)
trainIndex <- createDataPartition(df$rtAudienceScore, p = .90, list = FALSE, times = 1)

dfTrain <- df[trainIndex,]
dfTest <- df[-trainIndex,]

Regressão Linear

ctrl <- trainControl(method = "cv", number = 10)

lmFit <- train(rtAudienceScore ~. , 
               data = select(dfTrain, -movieID), 
               method = "lm", 
               trControl = ctrl,
               metric = "RMSE")

lmFit
## Linear Regression 
## 
## 6610 samples
##   11 predictor
## 
## No pre-processing
## Resampling: Cross-Validated (10 fold) 
## 
## Summary of sample sizes: 5950, 5948, 5950, 5949, 5948, 5949, ... 
## 
## Resampling results
## 
##   RMSE      Rsquared   RMSE SD    Rsquared SD
##   12.76956  0.4870232  0.2627133  0.01969634 
## 
## 
summary(lmFit)
## 
## Call:
## lm(formula = .outcome ~ ., data = dat)
## 
## Residuals:
##     Min      1Q  Median      3Q     Max 
## -55.373  -8.333   0.931   8.554  54.167 
## 
## Coefficients:
##                       Estimate Std. Error t value Pr(>|t|)    
## (Intercept)         145.138640  26.115755   5.558 2.84e-08 ***
## year                 -0.054153   0.013023  -4.158 3.25e-05 ***
## rtAllCriticsRating    2.423962   0.197731  12.259  < 2e-16 ***
## rtAllCriticsScore     0.247212   0.013969  17.697  < 2e-16 ***
## rtTopCriticsRating    0.273819   0.064347   4.255 2.12e-05 ***
## rtTopCriticsScore    -0.031361   0.007769  -4.037 5.48e-05 ***
## director_popularity  -5.283076   1.114255  -4.741 2.17e-06 ***
## cast_popularity      -3.952399   1.219456  -3.241   0.0012 ** 
## genre_popularity      4.201262   0.954860   4.400 1.10e-05 ***
## country_popularity   -3.882905   0.382887 -10.141  < 2e-16 ***
## tag_popularity       19.104606   3.190505   5.988 2.24e-09 ***
## tags_weight          18.396092   4.653692   3.953 7.80e-05 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 12.76 on 6598 degrees of freedom
## Multiple R-squared:  0.4882, Adjusted R-squared:  0.4873 
## F-statistic: 572.1 on 11 and 6598 DF,  p-value: < 2.2e-16
plot(varImp(lmFit))

Como pode ser visto acima, a variável com mais importância diz respeito ao score baseado nas críticas. A variável que apresentou menos importância para este modelo diz respeito a popularidade do elenco (cast_popularity). 

avaliacao <- data.frame(obs = dfTrain$rtAudienceScore, pred = predict(lmFit), res = resid(lmFit))

ggplot(avaliacao, aes(y = pred, x = obs)) + 
  geom_point(alpha = 0.5, position = position_jitter(width=0.2)) + 
  stat_abline(colour = "blue") + 
  ggtitle("Observado x Previsão (validação)")

predictedVal <- predict(lmFit, dfTest)
modelvalues<-data.frame(obs = dfTest$rtAudienceScore, pred = predictedVal)

defaultSummary(modelvalues)
##       RMSE   Rsquared 
## 12.8823773  0.4719306
compare <- data.frame(obs = dfTest$rtAudienceScore, pred = predictedVal)
ggplot(compare, aes(y = pred, x = obs)) + 
  geom_point(alpha = 0.5, position = position_jitter(width=0.2)) + 
  stat_abline() + 
  ggtitle("Observado x Previsão (validação)")

ggplot(compare, aes(y = (pred - obs), x = obs)) + 
  geom_point(alpha = 0.5, position = position_jitter(width=0.2)) + 
  ggtitle("Resíduos na validação")

Mars - Multivariate Adaptive Regression Spline

marsGrid <- expand.grid(.degree = 1:2, .nprune = 2:40)

marsFit <- train(rtAudienceScore ~. , 
                 data = select(dfTrain, -movieID), 
                 method = "earth", 
                 trControl = ctrl,
                 # novidade:
                 tuneGrid = marsGrid,
                 metric = "RMSE")

marsFit
## Multivariate Adaptive Regression Spline 
## 
## 6610 samples
##   11 predictor
## 
## No pre-processing
## Resampling: Cross-Validated (10 fold) 
## 
## Summary of sample sizes: 5949, 5949, 5948, 5949, 5949, 5949, ... 
## 
## Resampling results across tuning parameters:
## 
##   degree  nprune  RMSE      Rsquared   RMSE SD    Rsquared SD
##   1        2      13.16946  0.4543098  0.2664374  0.01996374 
##   1        3      12.93012  0.4742011  0.2901453  0.01782472 
##   1        4      12.71453  0.4915590  0.2628689  0.01520540 
##   1        5      12.63457  0.4979503  0.2397868  0.01355226 
##   1        6      12.59752  0.5008968  0.2293091  0.01263458 
##   1        7      12.57279  0.5029576  0.2245501  0.01169819 
##   1        8      12.56279  0.5037956  0.2145311  0.01146431 
##   1        9      12.52485  0.5067967  0.2306900  0.01209206 
##   1       10      12.48231  0.5100443  0.2110791  0.01143294 
##   1       11      12.47187  0.5108643  0.1891449  0.01102138 
##   1       12      12.46225  0.5116373  0.1913403  0.01128292 
##   1       13      12.43623  0.5136723  0.2083464  0.01192885 
##   1       14      12.42701  0.5144178  0.2028784  0.01125774 
##   1       15      12.40012  0.5164672  0.1891292  0.01108910 
##   1       16      12.39001  0.5172344  0.2000657  0.01230035 
##   1       17      12.38248  0.5177995  0.2144685  0.01330667 
##   1       18      12.37042  0.5187364  0.2210149  0.01376942 
##   1       19      12.36981  0.5187816  0.2206651  0.01379743 
##   1       20      12.36981  0.5187816  0.2206651  0.01379743 
##   1       21      12.36981  0.5187816  0.2206651  0.01379743 
##   1       22      12.36981  0.5187816  0.2206651  0.01379743 
##   1       23      12.36981  0.5187816  0.2206651  0.01379743 
##   1       24      12.36981  0.5187816  0.2206651  0.01379743 
##   1       25      12.36981  0.5187816  0.2206651  0.01379743 
##   1       26      12.36981  0.5187816  0.2206651  0.01379743 
##   1       27      12.36981  0.5187816  0.2206651  0.01379743 
##   1       28      12.36981  0.5187816  0.2206651  0.01379743 
##   1       29      12.36981  0.5187816  0.2206651  0.01379743 
##   1       30      12.36981  0.5187816  0.2206651  0.01379743 
##   1       31      12.36981  0.5187816  0.2206651  0.01379743 
##   1       32      12.36981  0.5187816  0.2206651  0.01379743 
##   1       33      12.36981  0.5187816  0.2206651  0.01379743 
##   1       34      12.36981  0.5187816  0.2206651  0.01379743 
##   1       35      12.36981  0.5187816  0.2206651  0.01379743 
##   1       36      12.36981  0.5187816  0.2206651  0.01379743 
##   1       37      12.36981  0.5187816  0.2206651  0.01379743 
##   1       38      12.36981  0.5187816  0.2206651  0.01379743 
##   1       39      12.36981  0.5187816  0.2206651  0.01379743 
##   1       40      12.36981  0.5187816  0.2206651  0.01379743 
##   2        2      13.16946  0.4543098  0.2664374  0.01996374 
##   2        3      12.93012  0.4742011  0.2901453  0.01782472 
##   2        4      12.68219  0.4941400  0.2578367  0.01547378 
##   2        5      12.55235  0.5044821  0.2464570  0.01489447 
##   2        6      12.50660  0.5080747  0.2677696  0.01629500 
##   2        7      12.47786  0.5103107  0.2981134  0.01754974 
##   2        8      12.43867  0.5133623  0.2857989  0.01604235 
##   2        9      12.42892  0.5141943  0.2942021  0.01668196 
##   2       10      12.41040  0.5156391  0.3007886  0.01726107 
##   2       11      12.38352  0.5176810  0.2971238  0.01663898 
##   2       12      12.39151  0.5170661  0.2978237  0.01714475 
##   2       13      12.38097  0.5178728  0.2958209  0.01750888 
##   2       14      12.37826  0.5181173  0.2693307  0.01548135 
##   2       15      12.38097  0.5179423  0.2777301  0.01651279 
##   2       16      12.37767  0.5182385  0.2875453  0.01718062 
##   2       17      12.37070  0.5187724  0.2813322  0.01664617 
##   2       18      12.36990  0.5188482  0.2846715  0.01704726 
##   2       19      12.36150  0.5194765  0.2803447  0.01680799 
##   2       20      12.36388  0.5192965  0.2856297  0.01718611 
##   2       21      12.36388  0.5192965  0.2856297  0.01718611 
##   2       22      12.36388  0.5192965  0.2856297  0.01718611 
##   2       23      12.36388  0.5192965  0.2856297  0.01718611 
##   2       24      12.36388  0.5192965  0.2856297  0.01718611 
##   2       25      12.36388  0.5192965  0.2856297  0.01718611 
##   2       26      12.36388  0.5192965  0.2856297  0.01718611 
##   2       27      12.36388  0.5192965  0.2856297  0.01718611 
##   2       28      12.36388  0.5192965  0.2856297  0.01718611 
##   2       29      12.36388  0.5192965  0.2856297  0.01718611 
##   2       30      12.36388  0.5192965  0.2856297  0.01718611 
##   2       31      12.36388  0.5192965  0.2856297  0.01718611 
##   2       32      12.36388  0.5192965  0.2856297  0.01718611 
##   2       33      12.36388  0.5192965  0.2856297  0.01718611 
##   2       34      12.36388  0.5192965  0.2856297  0.01718611 
##   2       35      12.36388  0.5192965  0.2856297  0.01718611 
##   2       36      12.36388  0.5192965  0.2856297  0.01718611 
##   2       37      12.36388  0.5192965  0.2856297  0.01718611 
##   2       38      12.36388  0.5192965  0.2856297  0.01718611 
##   2       39      12.36388  0.5192965  0.2856297  0.01718611 
##   2       40      12.36388  0.5192965  0.2856297  0.01718611 
## 
## RMSE was used to select the optimal model using  the smallest value.
## The final values used for the model were nprune = 19 and degree = 2.
plot(varImp(marsFit))

Para este modelo foram consideradas como com pouca ou nenhuma importância mais variáveis comparando com o modelo de regressão linear. Também é possível observar que com o modelo MARS foi obtida uma leve melhora nos resultados, com um RMSE levemente mais baixo e e RSquared maior. Os valores estão expostos mais adiante 

# Usando os dados de treino!
avaliacao$modelo <- "RL"

pred_mars <- data.frame(obs = dfTrain$rtAudienceScore, 
                        pred = predict(marsFit), 
                        res = dfTrain$rtAudienceScore - predict(marsFit),
                        modelo = "MARS")
avaliacao <- rbind(avaliacao, pred_mars)

ggplot(avaliacao, aes(y = pred, x = obs)) + 
  geom_point(alpha = 0.5, position = position_jitter(width=0.2)) + 
  stat_abline(colour = "blue") + 
  facet_grid(. ~ modelo) + 
  ggtitle("Observado x Previsão (validação)")

ggplot(avaliacao, aes(y = res, x = pred)) + 
  geom_point(alpha = 0.5, position = position_jitter(width=0.1)) + 
  geom_abline(slope = 0, intercept = 0, colour = "darkred") + 
  facet_grid(. ~ modelo) + 
  ggtitle("Resíduos na validação")

predictedVal <- predict(marsFit, dfTest)
modelvalues<-data.frame(obs = dfTest$rtAudienceScore, pred = predictedVal)

defaultSummary(modelvalues)
##       RMSE   Rsquared 
## 12.4868602  0.5044091
compare$modelo <- "RL" 
pred_mars <- data.frame(obs = dfTest$rtAudienceScore, pred = predictedVal, modelo = "MARS")
compare <- rbind(compare, pred_mars)

ggplot(compare, aes(y = pred, x = obs)) + 
  geom_point(alpha = 0.5, position = position_jitter(width=0.2)) + 
  facet_grid(. ~ modelo) + 
  stat_abline() +
  ggtitle("Observado x Previsão (validação)")

ggplot(compare, aes(y = (pred - obs), x = obs)) + 
  geom_point(alpha = 0.5, position = position_jitter(width=0.2)) + 
  facet_grid(. ~ modelo) + 
  geom_abline(slope = 0, intercept = 0, colour = "darkred") + 
  ggtitle("Resíduos na validação")

Boosted LM - Boosted Linear Model

require(bst)
require(plyr)
bstLsFit <- train(rtAudienceScore ~ .,
                 data = select(df, -movieID), 
                 method = "bstLs", 
                 trControl = ctrl,
                 metric = "RMSE")

bstLsFit
## Boosted Linear Model 
## 
## 7342 samples
##   11 predictor
## 
## No pre-processing
## Resampling: Cross-Validated (10 fold) 
## 
## Summary of sample sizes: 6606, 6607, 6609, 6609, 6607, 6608, ... 
## 
## Resampling results across tuning parameters:
## 
##   mstop  RMSE      Rsquared   RMSE SD    Rsquared SD
##    50    15.24617  0.3597133  0.2436117  0.02384831 
##   100    14.41577  0.4102447  0.2323701  0.02632006 
##   150    13.89210  0.4347061  0.2331245  0.02869928 
## 
## Tuning parameter 'nu' was held constant at a value of 0.1
## RMSE was used to select the optimal model using  the smallest value.
## The final values used for the model were mstop = 150 and nu = 0.1.
summary(bstLsFit)
##              Length Class      Mode     
## y             7342  -none-     numeric  
## x            80762  -none-     numeric  
## cost             1  -none-     numeric  
## family           1  -none-     character
## learner          1  -none-     character
## yhat          7342  -none-     numeric  
## offset           1  -none-     numeric  
## ens            150  -none-     list     
## control.tree     1  -none-     list     
## risk           150  -none-     numeric  
## ctrl             4  -none-     list     
## maxdepth         1  -none-     numeric  
## xselect          6  -none-     numeric  
## coef           150  -none-     numeric  
## ensemble       150  -none-     numeric  
## ml.fit          12  lm         list     
## call             6  -none-     call     
## xNames          11  -none-     character
## problemType      1  -none-     character
## tuneValue        2  data.frame list     
## obsLevels        1  -none-     logical
predictedVal <- predict(bstLsFit, dfTest)
modelvalues<-data.frame(obs = dfTest$rtAudienceScore, pred = predictedVal)

defaultSummary(modelvalues)
##       RMSE   Rsquared 
## 13.6903647  0.4435889
pred_blm <- data.frame(obs = dfTest$rtAudienceScore, pred = predictedVal, modelo = "Boosted LM")
compare <- rbind(compare, pred_blm)

ggplot(compare, aes(y = pred, x = obs)) + 
  geom_point(alpha = 0.5, position = position_jitter(width=0.2)) + 
  facet_grid(. ~ modelo) + 
  stat_abline() +
  ggtitle("Observado x Previsão (validação)")

ggplot(compare, aes(y = (pred - obs), x = obs)) + 
  geom_point(alpha = 0.5, position = position_jitter(width=0.2)) + 
  facet_grid(. ~ modelo) + 
  geom_abline(slope = 0, intercept = 0, colour = "darkred") + 
  ggtitle("Resíduos na validação")

KNN - K-nearest Neighbors

knnFit <- train(rtAudienceScore ~. , 
                data = select(dfTrain, -movieID), 
                method = "knn", 
                trControl = ctrl,
                preProcess = c("center","scale"), 
                tuneGrid = expand.grid(.k = 3:40),
                metric = "RMSE")

knnFit
## k-Nearest Neighbors 
## 
## 6610 samples
##   11 predictor
## 
## Pre-processing: centered, scaled 
## Resampling: Cross-Validated (10 fold) 
## 
## Summary of sample sizes: 5950, 5949, 5950, 5949, 5948, 5950, ... 
## 
## Resampling results across tuning parameters:
## 
##   k   RMSE      Rsquared   RMSE SD    Rsquared SD
##    3  14.13615  0.4003405  0.3663370  0.02114288 
##    4  13.75048  0.4213149  0.3742141  0.02357433 
##    5  13.53054  0.4338691  0.3477120  0.02203796 
##    6  13.36945  0.4439748  0.3032230  0.01842446 
##    7  13.22280  0.4540610  0.3114673  0.01591593 
##    8  13.15515  0.4585641  0.3245024  0.01711997 
##    9  13.09197  0.4630103  0.3386899  0.01939234 
##   10  13.07552  0.4639670  0.3594696  0.02132531 
##   11  13.02550  0.4674459  0.3517092  0.02109821 
##   12  12.97711  0.4710929  0.3344786  0.02042727 
##   13  12.93280  0.4745370  0.3555560  0.02066641 
##   14  12.90801  0.4764637  0.3689933  0.02166592 
##   15  12.90500  0.4766615  0.3722095  0.02199746 
##   16  12.87941  0.4786424  0.3516611  0.01951580 
##   17  12.86472  0.4797789  0.3454996  0.01903337 
##   18  12.84453  0.4814064  0.3399527  0.01857762 
##   19  12.81878  0.4835229  0.3345827  0.01839206 
##   20  12.81319  0.4839587  0.3307109  0.01742999 
##   21  12.80698  0.4844891  0.3364113  0.01766169 
##   22  12.79663  0.4853415  0.3326253  0.01746698 
##   23  12.79320  0.4857234  0.3297747  0.01739582 
##   24  12.78823  0.4861288  0.3271546  0.01700612 
##   25  12.78998  0.4860210  0.3221544  0.01638738 
##   26  12.78796  0.4862476  0.3180594  0.01610852 
##   27  12.76932  0.4878363  0.3174879  0.01551355 
##   28  12.76500  0.4882945  0.3264246  0.01628314 
##   29  12.76528  0.4883359  0.3300204  0.01632468 
##   30  12.75188  0.4895132  0.3283261  0.01644270 
##   31  12.75372  0.4893930  0.3219009  0.01644019 
##   32  12.75737  0.4891498  0.3146047  0.01602057 
##   33  12.76233  0.4887714  0.3145472  0.01596540 
##   34  12.76435  0.4886670  0.3222818  0.01617696 
##   35  12.75962  0.4891696  0.3210804  0.01608670 
##   36  12.75987  0.4892124  0.3222232  0.01611333 
##   37  12.75306  0.4898018  0.3192766  0.01589636 
##   38  12.75361  0.4898128  0.3196617  0.01605576 
##   39  12.75662  0.4896138  0.3213796  0.01608325 
##   40  12.76265  0.4892057  0.3171563  0.01567630 
## 
## RMSE was used to select the optimal model using  the smallest value.
## The final value used for the model was k = 30.
predictedVal <- predict(knnFit, dfTest)
modelvalues<-data.frame(obs = dfTest$rtAudienceScore, pred = predictedVal)
defaultSummary(modelvalues)
##       RMSE   Rsquared 
## 12.7854484  0.4794035
pred_knn <- data.frame(obs = dfTest$rtAudienceScore, pred = predictedVal, modelo = "kNN")
compare <- rbind(compare, pred_knn)

ggplot(compare, aes(y = pred, x = obs)) + 
  geom_point(alpha = 0.5, position = position_jitter(width=0.2)) + 
  facet_grid(. ~ modelo) + 
  stat_abline(colour = "darkblue") +
  #ylim(3, 8) + 
  ggtitle("Observado x Previsão (validação)")

ggplot(compare, aes(y = (pred - obs), x = obs)) + 
  geom_point(alpha = 0.5, position = position_jitter(width=0.2)) + 
  facet_grid(. ~ modelo) + 
  geom_abline(slope = 0, intercept = 0, colour = "darkred") + 
  ggtitle("Resíduos na validação")

Cubist

O treinamento do modelo com o método Cubist obteve o melhor resultado dentre os métodos testados neste problema. Com ele foi reduzido o RMSE e obtido um RSquared mais alto, indicando uma maior confiança no modelo para predição de scores para os filmes. A seguir seguem os gráficos de validação e resíduos que comparam o desempenho dos modelos utilizados neste problema. 

require(Cubist)
cubFit <- train(rtAudienceScore ~. , 
                data = select(dfTrain, -movieID), 
                method = "cubist", 
                trControl = ctrl,
                metric = "RMSE")

cubFit
## Cubist 
## 
## 6610 samples
##   11 predictor
## 
## No pre-processing
## Resampling: Cross-Validated (10 fold) 
## 
## Summary of sample sizes: 5948, 5949, 5949, 5949, 5949, 5950, ... 
## 
## Resampling results across tuning parameters:
## 
##   committees  neighbors  RMSE      Rsquared   RMSE SD    Rsquared SD
##    1          0          12.39606  0.5182951  0.3401381  0.02360469 
##    1          5          12.91126  0.4842067  0.4356028  0.03263187 
##    1          9          12.56543  0.5062310  0.3856716  0.02921584 
##   10          0          12.33420  0.5224193  0.3266527  0.02324586 
##   10          5          12.84993  0.4877882  0.4083836  0.03136029 
##   10          9          12.50543  0.5101336  0.3723997  0.02849421 
##   20          0          12.32651  0.5230233  0.3327125  0.02398172 
##   20          5          12.84597  0.4879868  0.4112892  0.03176515 
##   20          9          12.50228  0.5103081  0.3755525  0.02903219 
## 
## RMSE was used to select the optimal model using  the smallest value.
## The final values used for the model were committees = 20 and neighbors = 0.
predictedVal <- predict(cubFit, dfTest)
modelvalues<-data.frame(obs = dfTest$rtAudienceScore, pred = predictedVal)

defaultSummary(modelvalues)
##       RMSE   Rsquared 
## 12.4261684  0.5102963
pred_cub <- data.frame(obs = dfTest$rtAudienceScore, pred = predictedVal, modelo = "Cubist")
compare <- rbind(compare, pred_cub)

ggplot(compare, aes(y = pred, x = obs)) + 
  geom_point(alpha = 0.5, position = position_jitter(width=0.2)) + 
  facet_grid(. ~ modelo) + 
  stat_abline(colour = "darkblue") +
  #ylim(3, 8) + 
  ggtitle("Observado x Previsão (validação)")

É interessante notar que todos os modelos seguem um padrão nas predições, com destaque para o modelo Cubist, que apresenta os pontos mais próximos da reta, indicando maior precisão nos scores da predição. Outro ponto relevante é que, mesmo havendo um modelo com melhor desempenho, todos tiveram um desempenho bem próximos, havendo possibilidade de melhora caso seja feito novos ajustes nos mesmos. 

ggplot(compare, aes(y = (pred - obs), x = obs)) + 
  geom_point(alpha = 0.5, position = position_jitter(width=0.2)) + 
  facet_grid(. ~ modelo) + 
  geom_abline(slope = 0, intercept = 0, colour = "darkred") + 
  ggtitle("Resíduos na validação")

plot(varImp(cubFit))

Um fato curioso é quem, da mesma forma que na regressão linear, este modelo também despreza a variável que diz respeito a popularidade do elenco dos filmes.

Ainda sobre o modelo Cubist

Cubist é um modelo onde uma árvore é cultivada onde suas folhas terminais contém modelos de regressão linear. Estes modelos baseiam-se nos preditores usados em separações anteriores. Além disso, podem existir modelos lineares intermediários em cada etapa da árvore. Uma previsão é feita utilizando o modelo de regressão linear no nó terminal da árvore, mas é “suavizada” por levar em conta a previsão do modelo linear no nó anterior da árvore (que também ocorre de forma recursiva até a árvore). A árvore é reduzida a um conjunto de regras, que inicialmente são caminhos a partir do topo da árvore para a parte inferior. Regras são eliminadas através de podas e/ou combinadas para simplificação.

A previsão com este modelo se manteve constante em relação aos valores reais, mostrando uma certa coerência nos scores obtidos na predição com os valores reais. Isto deve-se a escolha das variáveis ter sido feita com uma certa coerência, seguindo os conceitos explicados anteriormente.

Extras: Realizando predição para Filmes sem Score

Após escolher o melhor modelo dentre os testados, foi realizada a predição para os filmes que possuíam scores iguais a zero. A ideia é que scores iguais a zero existiam por falta de informações ou avaliações e, a partir de um modelo sugerido, seria possível gerar uma nota para esses filmes que aparentemente não foram devidamente avaliados. 

prediction <- predict(cubFit, movies_zero_score)
prediction <- data.frame(prediction)

movies_prediction <- movies_zero_score %>% select(-rtAudienceScore)
movies_prediction <- cbind(movies_prediction,audienceScore_pred=prediction$prediction)
movies_prediction <- movies_prediction %>% arrange(-audienceScore_pred)

movies_prediction <- data.frame(movies_prediction)
write.csv(movies_prediction, file="movies_prediction.csv", row.names = FALSE, sep=";", quote = FALSE)