Predict #TidyTuesday NYT bestsellers

This is the latest in my series of screencasts demonstrating how to use the tidymodels packages. This screencast walks through how to use wordpiece tokenization for text feature engineering, as well as how to create a REST API to deploy your model. Let’s learn more about all this using the #TidyTuesday dataset on NYT bestsellers, which comes to us via Post45. 📚

Here is the code I used in the video, for those who prefer reading instead of or in addition to video.

Explore data

Our modeling goal is to predict which NYT bestsellers will be on the bestsellers list for a long time, based on the book’s author.

library(tidyverse)
nyt_titles <- read_tsv('https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2022/2022-05-10/nyt_titles.tsv')

glimpse(nyt_titles)

Rows: 7,431
Columns: 8
$ id          <dbl> 0, 1, 10, 100, 1000, 1001, 1002, 1003, 1004, 1005, 1006, 1…
$ title       <chr> "\"H\" IS FOR HOMICIDE", "\"I\" IS FOR INNOCENT", "''G'' I…
$ author      <chr> "Sue Grafton", "Sue Grafton", "Sue Grafton", "W. Bruce Cam…
$ year        <dbl> 1991, 1992, 1990, 2012, 2006, 2016, 1985, 1994, 2002, 1999…
$ total_weeks <dbl> 15, 11, 6, 1, 1, 3, 16, 5, 4, 1, 3, 2, 11, 6, 9, 8, 1, 1, …
$ first_week  <date> 1991-05-05, 1992-04-26, 1990-05-06, 2012-05-27, 2006-02-1…
$ debut_rank  <dbl> 1, 14, 4, 3, 11, 1, 9, 7, 7, 12, 13, 5, 12, 2, 11, 13, 2, …
$ best_rank   <dbl> 2, 2, 8, 14, 14, 7, 2, 10, 12, 17, 13, 13, 8, 5, 5, 11, 4,…

How is total_weeks on the NYT bestseller list distributed?

nyt_titles %>%
  ggplot(aes(total_weeks)) +
  geom_histogram(bins = 40)

Which authors have been on the list the most?

nyt_titles %>%
  group_by(author) %>%
  summarise(
    n = n(),
    total_weeks = median(total_weeks)
  ) %>%
  arrange(-n)

# A tibble: 2,206 × 3
   author                 n total_weeks
   <chr>              <int>       <dbl>
 1 Danielle Steel       116         5.5
 2 Stuart Woods          63         2  
 3 Stephen King          54        15  
 4 Robert B. Parker      47         4  
 5 John Sandford         44         5  
 6 David Baldacci        42        10  
 7 Dean Koontz           40         5.5
 8 Mary Higgins Clark    40         9  
 9 Sandra Brown          40         4  
10 Nora Roberts          38         5  
# … with 2,196 more rows

That Danielle Steel! Amazing!!

Build a model

Let’s start our modeling by setting up our “data budget.” We’ll subset down to only author and total_weeks, transform the total_weeks variable to “long” and “short, and stratify by our outcome total_weeks.

library(tidymodels)

set.seed(123)
books_split <-
  nyt_titles %>%
  transmute(
    author,
    total_weeks = if_else(total_weeks > 4, "long", "short")
  ) %>%
  na.omit() %>%
  initial_split(strata = total_weeks)
books_train <- training(books_split)
books_test <- testing(books_split)

set.seed(234)
book_folds <- vfold_cv(books_train, strata = total_weeks)
book_folds

#  10-fold cross-validation using stratification 
# A tibble: 10 × 2
   splits             id    
   <list>             <chr> 
 1 <split [5012/558]> Fold01
 2 <split [5013/557]> Fold02
 3 <split [5013/557]> Fold03
 4 <split [5013/557]> Fold04
 5 <split [5013/557]> Fold05
 6 <split [5013/557]> Fold06
 7 <split [5013/557]> Fold07
 8 <split [5013/557]> Fold08
 9 <split [5013/557]> Fold09
10 <split [5014/556]> Fold10

How is total_weeks distributed?

books_train %>% count(total_weeks)

# A tibble: 2 × 2
  total_weeks     n
  <chr>       <int>
1 long         2721
2 short        2849

Next, let’s build a modeling workflow() with feature engineering and a linear SVM (support vector machine). To prepare the text of the author names to be used in modeling, let’s use wordpiece tokenization. This approach to subword tokenization is based on the vocabulary used by BERT (I misspoke in the video) and can be applied to new data, including new names we’ve never seen before.

library(textrecipes)

svm_spec <- svm_linear(mode = "classification")

books_rec <-
  recipe(total_weeks ~ author, data = books_train) %>%
  step_tokenize_wordpiece(author, max_chars = 10) %>%
  step_tokenfilter(author, max_tokens = 100) %>%
  step_tf(author) %>%
  step_normalize(all_numeric_predictors())

## just to see how it is working:
prep(books_rec) %>% bake(new_data = NULL) %>% glimpse()

Rows: 5,570
Columns: 101
$ total_weeks         <fct> long, long, long, long, long, long, long, long, lo…
$ tf_author_.         <dbl> -0.3243985, -0.3243985, -0.3243985, -0.3243985, -0…
$ `tf_author_'`       <dbl> -0.08715687, -0.08715687, -0.08715687, -0.08715687…
$ `tf_author_[UNK]`   <dbl> -0.1419488, -0.1419488, -0.1419488, -0.1419488, -0…
$ `tf_author_##a`     <dbl> -0.09419984, -0.09419984, -0.09419984, -0.09419984…
$ `tf_author_##ac`    <dbl> -0.07836144, -0.07836144, -0.07836144, -0.07836144…
$ `tf_author_##ci`    <dbl> -0.0771935, -0.0771935, -0.0771935, -0.0771935, -0…
$ `tf_author_##e`     <dbl> -0.1406038, -0.1406038, -0.1406038, -0.1406038, -0…
$ `tf_author_##er`    <dbl> -0.1458252, -0.1458252, -0.1458252, -0.1458252, -0…
$ `tf_author_##es`    <dbl> -0.08064783, -0.08064783, -0.08064783, -0.08064783…
$ `tf_author_##ford`  <dbl> -0.08396368, -0.08396368, -0.08396368, -0.08396368…
$ `tf_author_##in`    <dbl> -0.07951265, -0.07951265, -0.07951265, -0.07951265…
$ `tf_author_##l`     <dbl> -0.08064783, -0.08064783, -0.08064783, -0.08064783…
$ `tf_author_##m`     <dbl> -0.09024042, -0.09024042, -0.09024042, -0.09024042…
$ `tf_author_##man`   <dbl> -0.1193075, -0.1193075, -0.1193075, -0.1193075, -0…
$ `tf_author_##n`     <dbl> -0.1199358, -0.1199358, -0.1199358, -0.1199358, -0…
$ `tf_author_##ne`    <dbl> -0.08064783, -0.08064783, -0.08064783, -0.08064783…
$ `tf_author_##ont`   <dbl> -0.08819633, -0.08819633, -0.08819633, -0.08819633…
$ `tf_author_##ovich` <dbl> -0.07614065, -0.07614065, -0.07614065, -0.07614065…
$ `tf_author_##s`     <dbl> -0.1310066, -0.1310066, -0.1310066, -0.1310066, -0…
$ `tf_author_##sen`   <dbl> -0.07409856, -0.07409856, -0.07409856, -0.07409856…
$ `tf_author_##ssler` <dbl> -0.09652724, -0.09652724, -0.09652724, -0.09652724…
$ `tf_author_##well`  <dbl> -0.07951265, -0.07951265, -0.07951265, -0.07951265…
$ `tf_author_##y`     <dbl> -0.08064783, -0.08064783, -0.08064783, -0.08064783…
$ `tf_author_##z`     <dbl> -0.1111617, -0.1111617, -0.1111617, -0.1111617, -0…
$ tf_author_a         <dbl> -0.1207399, -0.1207399, -0.1207399, -0.1207399, -0…
$ tf_author_alice     <dbl> -0.0771935, -0.0771935, -0.0771935, -0.0771935, -0…
$ tf_author_and       <dbl> -0.227056, -0.227056, -0.227056, -0.227056, -0.227…
$ tf_author_ann       <dbl> -0.08064783, -0.08064783, -0.08064783, -0.08064783…
$ tf_author_anne      <dbl> -0.1111617, -0.1111617, -0.1111617, -0.1111617, -0…
$ tf_author_b         <dbl> -0.1406038, -0.1406038, -0.1406038, -0.1406038, -0…
$ tf_author_bald      <dbl> -0.0771935, -0.0771935, -0.0771935, -0.0771935, -0…
$ tf_author_barbara   <dbl> -0.0771935, -0.0771935, -0.0771935, -0.0771935, -0…
$ tf_author_brown     <dbl> -0.1019979, -0.1019979, -0.1019979, 8.1317469, -0.…
$ tf_author_by        <dbl> -0.08310031, -0.08310031, -0.08310031, -0.08310031…
$ tf_author_c         <dbl> -0.09893404, -0.09893404, -0.09893404, -0.09893404…
$ tf_author_child     <dbl> -0.07732059, -0.07732059, -0.07732059, -0.07732059…
$ tf_author_clark     <dbl> -0.09274912, -0.09274912, -0.09274912, -0.09274912…
$ tf_author_clive     <dbl> -0.1034598, -0.1034598, -0.1034598, -0.1034598, -0…
$ tf_author_co        <dbl> -0.08504102, -0.08504102, -0.08504102, -0.08504102…
$ tf_author_cr        <dbl> -0.08610525, -0.08610525, -0.08610525, -0.08610525…
$ tf_author_cu        <dbl> -0.09652724, -0.09652724, -0.09652724, -0.09652724…
$ tf_author_d         <dbl> -0.1034598, -0.1034598, -0.1034598, -0.1034598, -0…
$ tf_author_danielle  <dbl> -0.1266872, -0.1266872, -0.1266872, -0.1266872, -0…
$ tf_author_david     <dbl> -0.1222252, -0.1222252, -0.1222252, -0.1222252, -0…
$ tf_author_dean      <dbl> -0.08176765, -0.08176765, -0.08176765, -0.08176765…
$ tf_author_e         <dbl> -0.1185213, -0.1185213, -0.1185213, -0.1185213, -0…
$ tf_author_elizabeth <dbl> -0.1136183, -0.1136183, -0.1136183, -0.1136183, -0…
$ tf_author_evan      <dbl> -0.0796298, -0.0796298, -0.0796298, -0.0796298, -0…
$ tf_author_f         <dbl> -0.09985495, -0.09985495, -0.09985495, -0.09985495…
$ tf_author_frank     <dbl> -0.08819633, -0.08819633, 11.33630484, -0.08819633…
$ tf_author_gr        <dbl> -0.09224066, -0.09224066, -0.09224066, -0.09224066…
$ tf_author_griffin   <dbl> -0.08610525, -0.08610525, -0.08610525, -0.08610525…
$ tf_author_higgins   <dbl> -0.1120983, -0.1120983, -0.1120983, -0.1120983, -0…
$ tf_author_howard    <dbl> -0.07836144, -0.07836144, -0.07836144, -0.07836144…
$ tf_author_j         <dbl> -0.1646265, -0.1646265, -0.1646265, -0.1646265, -0…
$ tf_author_james     <dbl> -0.196587, -0.196587, -0.196587, -0.196587, -0.196…
$ tf_author_jan       <dbl> -0.08176765, -0.08176765, -0.08176765, -0.08176765…
$ tf_author_janet     <dbl> -0.08610525, -0.08610525, -0.08610525, -0.08610525…
$ tf_author_jeff      <dbl> -0.07836144, -0.07836144, -0.07836144, -0.07836144…
$ tf_author_john      <dbl> -0.2093925, -0.2093925, -0.2093925, -0.2093925, -0…
$ tf_author_jonathan  <dbl> -0.08064783, -0.08064783, -0.08064783, -0.08064783…
$ tf_author_judith    <dbl> -0.07951265, -0.07951265, -0.07951265, -0.07951265…
$ tf_author_k         <dbl> -0.1191634, -0.1191634, -0.1191634, -0.1191634, -0…
$ tf_author_keller    <dbl> -0.0851383, -0.0851383, -0.0851383, -0.0851383, -0…
$ tf_author_ken       <dbl> -0.08064783, -0.08064783, -0.08064783, -0.08064783…
$ tf_author_king      <dbl> -0.09991709, -0.09991709, -0.09991709, -0.09991709…
$ tf_author_ko        <dbl> -0.09322522, -0.09322522, -0.09322522, -0.09322522…
$ tf_author_l         <dbl> -0.08715687, -0.08715687, -0.08715687, -0.08715687…
$ tf_author_la        <dbl> -0.08064783, -0.08064783, -0.08064783, -0.08064783…
$ tf_author_lee       <dbl> -0.09124584, -0.09124584, -0.09124584, -0.09124584…
$ tf_author_lisa      <dbl> -0.09124584, -0.09124584, -0.09124584, -0.09124584…
$ tf_author_louis     <dbl> -0.0771935, -0.0771935, -0.0771935, -0.0771935, -0…
$ tf_author_ma        <dbl> -0.07836144, -0.07836144, -0.07836144, -0.07836144…
$ tf_author_mac       <dbl> -0.08396368, -0.08396368, -0.08396368, -0.08396368…
$ tf_author_mary      <dbl> -0.1358838, -0.1358838, -0.1358838, -0.1358838, -0…
$ tf_author_mc        <dbl> -0.08176765, -0.08176765, -0.08176765, -0.08176765…
$ tf_author_michael   <dbl> -0.1237294, -0.1237294, -0.1237294, -0.1237294, -0…
$ tf_author_nora      <dbl> -0.07836144, -0.07836144, -0.07836144, -0.07836144…
$ tf_author_o         <dbl> -0.08176765, -0.08176765, -0.08176765, -0.08176765…
$ tf_author_parker    <dbl> -0.08287274, -0.08287274, -0.08287274, -0.08287274…
$ tf_author_patterson <dbl> -0.1392703, -0.1392703, -0.1392703, -0.1392703, -0…
$ tf_author_paul      <dbl> -0.09706705, -0.09706705, -0.09706705, -0.09706705…
$ tf_author_r         <dbl> -0.1132612, -0.1132612, -0.1132612, -0.1132612, -0…
$ tf_author_richard   <dbl> -0.1160255, -0.1160255, -0.1160255, -0.1160255, -0…
$ tf_author_robert    <dbl> -0.1605555, -0.1605555, -0.1605555, -0.1605555, -0…
$ tf_author_roberts   <dbl> -0.08287274, -0.08287274, -0.08287274, -0.08287274…
$ tf_author_s         <dbl> -0.09087668, -0.09087668, -0.09087668, -0.09087668…
$ tf_author_sand      <dbl> -0.07836144, -0.07836144, -0.07836144, -0.07836144…
$ tf_author_scott     <dbl> -0.08715687, -0.08715687, -0.08715687, -0.08715687…
$ tf_author_smith     <dbl> -0.09124584, -0.09124584, -0.09124584, -0.09124584…
$ tf_author_steel     <dbl> -0.1259539, -0.1259539, -0.1259539, -0.1259539, -0…
$ tf_author_stephen   <dbl> -0.1199358, -0.1199358, -0.1199358, -0.1199358, -0…
$ tf_author_stuart    <dbl> -0.1007678, -0.1007678, -0.1007678, -0.1007678, -0…
$ tf_author_taylor    <dbl> -0.08396368, -0.08396368, -0.08396368, -0.08396368…
$ tf_author_terry     <dbl> -0.08504102, -0.08504102, -0.08504102, -0.08504102…
$ tf_author_thomas    <dbl> -0.08176765, -0.08176765, -0.08176765, -0.08176765…
$ tf_author_tom       <dbl> -0.07951265, -0.07951265, -0.07951265, -0.07951265…
$ tf_author_w         <dbl> -0.1078035, -0.1078035, -0.1078035, -0.1078035, -0…
$ tf_author_william   <dbl> -0.1152284, -0.1152284, -0.1152284, -0.1152284, -0…
$ tf_author_woods     <dbl> -0.09800482, -0.09800482, -0.09800482, -0.09800482…

book_wf <- workflow(books_rec, svm_spec)
book_wf

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

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

• step_tokenize_wordpiece()
• step_tokenfilter()
• step_tf()
• step_normalize()

── Model ───────────────────────────────────────────────────────────────────────
Linear Support Vector Machine Specification (classification)

Computational engine: LiblineaR 

Evaluate, finalize, and deploy model

Now that we have our modeling workflow ready to go, let’s evaluate how it performs using our resampling folds. We need to set some custom metrics because this linear SVM does not produce class probabilities.

doParallel::registerDoParallel()

set.seed(123)
books_metrics <- metric_set(accuracy, sens, spec)
book_rs <- fit_resamples(book_wf, resamples = book_folds, metrics = books_metrics)
collect_metrics(book_rs)

# A tibble: 3 × 6
  .metric  .estimator  mean     n std_err .config             
  <chr>    <chr>      <dbl> <int>   <dbl> <chr>               
1 accuracy binary     0.600    10 0.00400 Preprocessor1_Model1
2 sens     binary     0.416    10 0.00795 Preprocessor1_Model1
3 spec     binary     0.776    10 0.00877 Preprocessor1_Model1

Not what you’d call incredibly impressive, but at least we are pretty sure there’s no data leakage! 😆

Let’s use last_fit() to fit one final time to the training data and evaluate one final time on the testing data.

final_rs <- last_fit(book_wf, books_split, metrics = books_metrics)
collect_metrics(final_rs)

# A tibble: 3 × 4
  .metric  .estimator .estimate .config             
  <chr>    <chr>          <dbl> <chr>               
1 accuracy binary         0.572 Preprocessor1_Model1
2 sens     binary         0.377 Preprocessor1_Model1
3 spec     binary         0.759 Preprocessor1_Model1

Notice that this is the first time we’ve used the testing data. Our metrics on the testing data are about the same as from our resampling folds.

How did we do predicting the two classes?

collect_predictions(final_rs) %>%
  conf_mat(total_weeks, .pred_class) %>%
  autoplot()

We are better at predicting the books that are on the list for a short time than those that are on for a long time.

If we decide this model is good to go and we want to use it in the future, we can extract out the fitted workflow. This object can be used for prediction:

final_fitted <- extract_workflow(final_rs)
augment(final_fitted, new_data = slice_sample(books_test, n = 1))

# A tibble: 1 × 3
  author     total_weeks .pred_class
  <chr>      <chr>       <fct>      
1 Donna Leon short       short      

## again:
augment(final_fitted, new_data = slice_sample(books_test, n = 1))

# A tibble: 1 × 3
  author         total_weeks .pred_class
  <chr>          <chr>       <fct>      
1 Rita Mae Brown short       short      

We can also examine this model (which is just linear with coefficients) to understand what drives its predictions.

tidy(final_fitted) %>%
  slice_max(abs(estimate), n = 20) %>%
  mutate(
    term = str_remove_all(term, "tf_author_"),
    term = fct_reorder(term, abs(estimate))
  ) %>%
  ggplot(aes(x = abs(estimate), y = term, fill = estimate > 0)) +
  geom_col() +
  scale_x_continuous(expand = c(0, 0)) +
  scale_fill_discrete(labels = c("Fewer weeks", "More weeks")) +
  labs(x = "Estimate from linear SVM (absolute value)", y = NULL, 
       fill = "How many weeks on\nbestseller list?")

Finally, we can deploy this model as a REST API using the vetiver package.

library(vetiver)
v <- vetiver_model(final_fitted, "nyt_authors")
v

── nyt_authors ─ <butchered_workflow> model for deployment 
A LiblineaR classification modeling workflow using 1 feature

library(plumber)
pr() %>%
  vetiver_api(v)

# Plumber router with 2 endpoints, 4 filters, and 1 sub-router.
# Use `pr_run()` on this object to start the API.
├──[queryString]
├──[body]
├──[cookieParser]
├──[sharedSecret]
├──/logo
│  │ # Plumber static router serving from directory: /Library/Frameworks/R.framework/Versions/4.2-arm64/Resources/library/vetiver
├──/ping (GET)
└──/predict (POST)

## pipe to `pr_run()` to start the API