Apply 3
Matthew Plutzner
2026-03-30
#Import Data
download.file(
"https://raw.githubusercontent.com/rfordatascience/tidytuesday/main/data/2021/2021-03-02/youtube.csv",
destfile = "youtube.csv",
mode = "wb"
)
youtube <- read.csv("youtube.csv")
data <- youtube %>%
select(year, brand, title, funny, show_product_quickly, patriotic,
celebrity, danger, animals, use_sex, view_count, like_count) %>%
filter(like_count > 0, view_count > 0) %>%
na.omit() %>%
mutate(
like_count = log(like_count),
funny = as.factor(funny),
show_product_quickly = as.factor(show_product_quickly),
patriotic = as.factor(patriotic),
celebrity = as.factor(celebrity),
danger = as.factor(danger),
animals = as.factor(animals),
use_sex = as.factor(use_sex)
)#Explore Data views
data %>%
ggplot(aes(like_count, view_count)) +
scale_y_log10() +
geom_point()
year
data %>%
ggplot(aes(like_count, as.factor(year))) +
geom_boxplot()
title
data %>%
unnest_tokens(output = word, input = title) %>%
group_by(word) %>%
summarise(like_count = mean(like_count),
n = n()) %>%
ungroup() %>%
filter(n > 10, !str_detect(word, "\\d")) %>%
slice_max(order_by = like_count, n = 20) %>%
ggplot(aes(like_count, fct_reorder(word, like_count))) +
geom_point() +
labs(y = "words in title")
#EDA shortcut
data_binarized_tbl <- data %>%
select(-title) %>%
binarize()
data_corr_tbl <- data_binarized_tbl %>%
correlate(target = `like_count__-Inf_3.28640178400862`)
data_corr_tbl %>%
plot_correlation_funnel()## Warning: The `size` argument of `element_line()` is deprecated as of ggplot2 3.4.0.
## ℹ Please use the `linewidth` argument instead.
## ℹ The deprecated feature was likely used in the correlationfunnel package.
## Please report the issue at
## <https://github.com/business-science/correlationfunnel/issues>.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.## Warning: The `size` argument of `element_rect()` is deprecated as of ggplot2 3.4.0.
## ℹ Please use the `linewidth` argument instead.
## ℹ The deprecated feature was likely used in the correlationfunnel package.
## Please report the issue at
## <https://github.com/business-science/correlationfunnel/issues>.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.## Warning: ggrepel: 6 unlabeled data points (too many overlaps). Consider
## increasing max.overlaps
#Build models split data
set.seed(1234)
data_split <- rsample::initial_split(data)
data_train <- training(data_split)
data_test <- testing(data_split)
set.seed(2345)
data_cv <- rsample::vfold_cv(data_train)
data_cv## # 10-fold cross-validation
## # A tibble: 10 × 2
## splits id
## <list> <chr>
## 1 <split [145/17]> Fold01
## 2 <split [145/17]> Fold02
## 3 <split [146/16]> Fold03
## 4 <split [146/16]> Fold04
## 5 <split [146/16]> Fold05
## 6 <split [146/16]> Fold06
## 7 <split [146/16]> Fold07
## 8 <split [146/16]> Fold08
## 9 <split [146/16]> Fold09
## 10 <split [146/16]> Fold10library(usemodels)## Warning: package 'usemodels' was built under R version 4.5.2usemodels::use_xgboost(like_count ~ ., data = data_train)## xgboost_recipe <-
## recipe(formula = like_count ~ ., 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(81602)
## xgboost_tune <-
## tune_grid(xgboost_workflow, resamples = stop("add your rsample object"), grid = stop("add number of candidate points"))xgboost_recipe <-
recipe(formula = like_count ~ ., data = data_train) %>%
step_tokenize(title) %>%
step_tokenfilter(title, max_tokens = 10) %>%
step_tfidf(title) %>%
step_dummy(all_nominal_predictors(), one_hot = TRUE)
xgboost_recipe %>% prep() %>% juice() %>% glimpse()## Rows: 162
## Columns: 37
## $ year <int> 2013, 2009, 2008, 2002, 2013, 2009, 2007, …
## $ view_count <int> 4302, 503550, 1060001, 13245, 394, 45799, …
## $ like_count <dbl> 3.0910425, 7.3065314, 7.2327331, 3.8918203…
## $ tfidf_title_ad <dbl> 0.0000000, 0.0000000, 0.0000000, 0.0000000…
## $ tfidf_title_bowl <dbl> 0.3211279, 0.0000000, 0.0000000, 0.0000000…
## $ tfidf_title_bud <dbl> 0.0000000, 0.0000000, 0.5268168, 0.0000000…
## $ tfidf_title_budweiser <dbl> 0.0000000, 0.0000000, 0.0000000, 1.9459101…
## $ tfidf_title_commercial <dbl> 0.2592041, 1.0368166, 0.3456055, 0.0000000…
## $ tfidf_title_hyundai <dbl> 0.6170249, 0.0000000, 0.0000000, 0.0000000…
## $ tfidf_title_light <dbl> 0.0000000, 0.0000000, 0.5465811, 0.0000000…
## $ tfidf_title_pepsi <dbl> 0.0000000, 0.0000000, 0.0000000, 0.0000000…
## $ tfidf_title_super <dbl> 0.3211279, 0.0000000, 0.0000000, 0.0000000…
## $ tfidf_title_the <dbl> 0.0000000, 0.0000000, 0.0000000, 0.0000000…
## $ brand_Bud.Light <dbl> 0, 0, 1, 0, 1, 0, 0, 0, 0, 0, 0, 1, 1, 0, …
## $ brand_Budweiser <dbl> 0, 0, 0, 1, 0, 0, 1, 1, 0, 0, 1, 0, 0, 1, …
## $ brand_Coca.Cola <dbl> 0, 1, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 0, …
## $ brand_Doritos <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ brand_E.Trade <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ brand_Hynudai <dbl> 1, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, …
## $ brand_Kia <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ brand_NFL <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ brand_Pepsi <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ brand_Toyota <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ funny_FALSE. <dbl> 0, 1, 0, 0, 0, 0, 1, 0, 1, 1, 1, 1, 0, 0, …
## $ funny_TRUE. <dbl> 1, 0, 1, 1, 1, 1, 0, 1, 0, 0, 0, 0, 1, 1, …
## $ show_product_quickly_FALSE. <dbl> 0, 0, 0, 1, 0, 0, 1, 0, 1, 0, 1, 0, 0, 0, …
## $ show_product_quickly_TRUE. <dbl> 1, 1, 1, 0, 1, 1, 0, 1, 0, 1, 0, 1, 1, 1, …
## $ patriotic_FALSE. <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, …
## $ patriotic_TRUE. <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, …
## $ celebrity_FALSE. <dbl> 1, 1, 0, 1, 0, 0, 1, 1, 1, 1, 1, 0, 1, 1, …
## $ celebrity_TRUE. <dbl> 0, 0, 1, 0, 1, 1, 0, 0, 0, 0, 0, 1, 0, 0, …
## $ danger_FALSE. <dbl> 0, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1, 1, 0, 0, …
## $ danger_TRUE. <dbl> 1, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 1, 1, …
## $ animals_FALSE. <dbl> 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 1, 0, 1, 0, …
## $ animals_TRUE. <dbl> 1, 1, 0, 0, 0, 0, 1, 1, 1, 1, 0, 1, 0, 1, …
## $ use_sex_FALSE. <dbl> 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, …
## $ use_sex_TRUE. <dbl> 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, …xgboost_spec <-
boost_tree(trees = tune(), min_n = tune(), mtry = tune(), learn_rate = tune()) %>%
set_mode("regression") %>%
set_engine("xgboost")
xgboost_workflow <-
workflow() %>%
add_recipe(xgboost_recipe) %>%
add_model(xgboost_spec)
set.seed(344)
xgboost_tune <-
tune_grid(xgboost_workflow,
resamples = data_cv,
grid = 5)#eval Data
tune::show_best(xgboost_tune, metric = "rmse")## # A tibble: 5 × 10
## mtry trees min_n learn_rate .metric .estimator mean n std_err .config
## <int> <int> <int> <dbl> <chr> <chr> <dbl> <int> <dbl> <chr>
## 1 36 2000 21 0.0178 rmse standard 0.973 10 0.0748 pre0_mod5…
## 2 9 1000 40 0.316 rmse standard 1.26 10 0.0854 pre0_mod2…
## 3 27 500 30 0.001 rmse standard 1.79 10 0.127 pre0_mod4…
## 4 1 1500 11 0.00422 rmse standard 1.97 10 0.122 pre0_mod1…
## 5 18 1 2 0.0750 rmse standard 2.28 10 0.124 pre0_mod3…xgboost_fw <- tune::finalize_workflow(xgboost_workflow,
tune::select_best(xgboost_tune, metric = "rmse"))
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.892 pre0_mod0_post0
## 2 rsq standard 0.880 pre0_mod0_post0tune::collect_predictions(data_fit) %>%
ggplot(aes(like_count, .pred)) +
geom_point(alpha = 0.3, fill = "midnightblue") +
geom_abline(lty = 2, color = "gray50") +
coord_fixed()