Many organizations have a substantial amount of human-generated text
from which they are not extracting a proportional amount of insight. For
example, open-ended questions are found in most surveys—but are rarely
given the same amount of attention (if any attention at all) as the
easier-to-analyze quantitative data. I have tested out many supposedly
“AI-powered” or “NLP-driven” tools for analyzing text in my career, and
I haven’t found anything to be useful at finding topics or modeling
sentiment when fed real data. I wrote on my
reservations about common topic modeling methods over four years
ago, where I showed how I perform exploratory analysis on text data
based on word co-occurrences. That was an unsupervised
approach: No a priori topics are given to a model to learn from. It
looks at patterns of how frequently words are used together to infer
topics.
I lay out my approach for supervised topic modeling in short
texts (e.g., open-response survey data) here. My philosophy is one where
there is no free lunch: If you want data that make sense for your
specific organization and use case, you’re gonna actually have to
read and consider the text you get. This isn’t using
statistical learning to do the job for you—it is using these models as a
tool to work with. You can’t solve this purely from the command
line. There will need to be many humans in the loop. This process can be
a grind, but what you’ll come out of it with is a scalable, bespoke
model. I don’t think I’m saying anything particularly revolutionary in
this post, but hopefully the walk-through and code might help you
develop a similar workflow.
The working example I’m using here are Letterboxd reviews for Wes
Anderson’s newest film, Asteroid City.
Step 1: Thematic Content Analysis
Create a coding corpus that is a random sample (maybe 2000 cases,
depending on how long each piece of text is, how much bandwidth you have
for this project, etc.) from your entire corpus of text (e.g., reviews,
open-ended responses, help tickets). Perform a thematic
content analysis in partnership with colleagues. I am not a
qualitative methodologist by any means, but I start by reading the
entirety of the random sample. Then I read through the coding corpus
again, taking notes about key themes. I look at these themes, and I
think about how they may be grouped together. I talk with my colleagues
to see what they think. We discuss if certain themes can be combined or
if they need to be kept separate. We talk about the maximum number of
themes we think we should be looking for. We finalize themes, discuss
what they mean in detail, and name them. From these readings and
conversations, I write a standardized coding manual that others can use
to read responses and code according to the themes.
In my example, I wrote an R script (see Appendix A or my
GitHub) to scrape Letterboxd for reviews. For each possible rating
(0.5 stars to 5.0 stars, in increments of half stars), I pulled six
pages. Each page had twelve reviews. Ten possible ratings, six pages
each, and twelve reviews per page multiplies out to 720 reviews. In the
process of coding, I dropped any review that was not written in
English—a limitation of mine here due to me making the regrettable
decision to study Latin in college (although an apropos course
for a Wes Anderson blog post).
I decided to stick to just one theme for the purposes of this
exercise: Did the review discuss the visual style of the film? Anderson
is known for his distinctive visual style, which at this point is
unfortunately a bit of a cultural meme. There was a whole
Instagram/TikTok trend of posting videos of oneself in the style of
Anderson; there’s those cynical, intellectually
vapid, artless, AI-generated simulacra imagining [insert well-known
intellectual property here] in the Andersonian style; and there’s even a
Hertz (the rent-a-car company) commercial that references the meme,
which in turn references the style (Baudrillard’s head would be
spinning, folks).
This visual style, by my eye, was solidified by the time of The
Grand Budapest Hotel. Symmetrical framing, meticulously organized
sets, the use of miniatures, a pastel color palette contrasted with
saturated primary colors, distinctive costumes, straight lines, lateral
tracking shots, whip pans, and so on. However, I did not consider
aspects of Anderson’s style that are unrelated to the visual sense. This
is where defining the themes with a clear line matters—and often there
will be ambiguities, but one must do their best, because the process
we’re doing is fundamentally a simplification of the rich diversity of
the text. Thus, I did not consider the following to be in Anderson’s
visual style: stories involving precocious children, fraught
familial relations, uncommon friendships, dry humor, monotonous
dialogue, soundtracks usually involving The Kinks, a fascination with
stage productions, nesting doll narratives, or a decidedly twee yet
bittersweet tone.
Step 2: Independent Coders
This is where you will need organizational buy-in and the help of
your colleagues. Recruit fellow researchers (or subject experts) that
have domain expertise. For example, if the text data are all reviews for
a specific app, make sure you recruit colleagues that have knowledge
about that specific app. I generate standardized Google Sheets where
each row is a text response, each column is a theme, and I send
them—along with the coding manual—to the coders. They are instructed to
put in a “1” wherever a text touches on that theme as is described in
the coding manual. I have each piece of text coded by two independent
coders. After everyone is done, I resolve disagreements by a third-party
vote (which may or may not be myself). Combine the various Google Sheets
(I use the
For Asteroid City reviews, I just did this on a Saturday
afternoon myself. Any piece of text that touched on the visual style was
flagged with a “1,” while the rest were marked as “0.” The text I pulled
was abbreviated for longer reviews; however, I don’t mind this, as I
feel it stays true to the analogy of short open-ended survey responses
that way.
Step 3: Train the Models
This is where I stand on the shoulders of Emil Hvitfeldt and Julia
Silge by way of their book, Supervised
Machine Learning for Text Analysis in R. I define an entire
machine learning workflow (i.e., data processing, cross-validation,
model selection, and holdout performance), and then I package this
workflow into convenient wrapper functions. This allows me to use that
wrapper function on each column, so that every theme gets its own model.
I write the cross-validation results and final models out as RDS files
so that I can access them later.
The wrapper functions are in Appendix B below and at my
GitHub. It’s, uh, long. (I go against my own imperative to
write modular code here, but if there’s a less verbose way of defining
this workflow, please genuinely let me know.) I am making three basic
functions: one to create the train/test split, another to perform
cross-validation, and a third to pull the best model.
The prep_data function takes your data, the name of the
outcome and text variables, and how large of a holdout set you want.
You can change exactly what pre-processing steps and algorithms you
want to use from what I have. But I have found that the processing of
the data usually is more influential than a specific model. So in the
wrapper function do_cv, I am trying out all combinations of
the following:
- Stop words: None, SMART, or ISO (different lists of stop
words)
- N-grams: Words only or words and bigrams
- Stemming: Yes or no
- Word frequency filtering: Words used 1 or more times in the corpus,
2 or more times, or 5 or more
- Algorithm: Elastic net or random forest
This leaves 3 * 2 * 2 * 3 * 2 = 72 combinations of pre-processors and
algorithm combinations. The models were tuned according to grid search
(the size of which is an argument to the do_cv function)
using k-fold validation (where k is also an argument). You could add
other pre-processing steps (e.g., word embeddings) or other algorithms
(e.g., XGBoost, neural networks) to the body of this function.
When that’s done, the best_model function will pull
everything you need to know about the model that performed best in
cross-validation, and it will give you performance metrics on the
holdout set.
When all is said and done, the actual running of the code then looks
deceptively simple:
library(tidyverse)
source("funs.R")
dat <- read_csv("ratings_coded.csv") %>%
filter(visual_style != 9) # remove non-english
set.seed(1839)
dat <- prep_data(dat, "visual_style", "text", .20)
cv_res <- do_cv(training(dat), 4, 10)
write_rds(cv_res, "visual_style-res.rds")
mod <- best_model(dat, cv_res, "roc_auc")
Where funs.R is a file that includes the functions in
Appendix B. This has a 20% holdout set, 4 folds, and a grid search with
size 10. It then writes out those results to an RDS object. Lastly, we
pull the best model according to the area under the ROC curve. If you
had multiple codes, you could write a for loop here for the
name of each column (e.g.,
prep_data(dat, i, "text", .20)).
Step 4: Use the Models
First, let’s check out what some of these objects look like. Let’s
take a look at the metrics for the first model that went into the
cross-validation results set.
cv_res <- read_rds("visual_style-res.rds")
cv_res$cv_res$result[[1]]$.metrics
## [[1]]
## # A tibble: 60 × 6
## penalty mixture .metric .estimator .estimate .config
## <dbl> <dbl> <chr> <chr> <dbl> <chr>
## 1 0.000000787 0.0698 accuracy binary 0.774 Preprocessor1_Model01
## 2 0.000000787 0.0698 sensitivity binary 0.923 Preprocessor1_Model01
## 3 0.000000787 0.0698 specificity binary 0 Preprocessor1_Model01
## 4 0.000000787 0.0698 precision binary 0.828 Preprocessor1_Model01
## 5 0.000000787 0.0698 f_meas binary 0.873 Preprocessor1_Model01
## 6 0.000000787 0.0698 roc_auc binary 0.777 Preprocessor1_Model01
## 7 0.000374 0.166 accuracy binary 0.774 Preprocessor1_Model02
## 8 0.000374 0.166 sensitivity binary 0.923 Preprocessor1_Model02
## 9 0.000374 0.166 specificity binary 0 Preprocessor1_Model02
## 10 0.000374 0.166 precision binary 0.828 Preprocessor1_Model02
## # ℹ 50 more rows
##
## [[2]]
## # A tibble: 60 × 6
## penalty mixture .metric .estimator .estimate .config
## <dbl> <dbl> <chr> <chr> <dbl> <chr>
## 1 0.000000787 0.0698 accuracy binary 0.767 Preprocessor1_Model01
## 2 0.000000787 0.0698 sensitivity binary 0.913 Preprocessor1_Model01
## 3 0.000000787 0.0698 specificity binary 0.286 Preprocessor1_Model01
## 4 0.000000787 0.0698 precision binary 0.808 Preprocessor1_Model01
## 5 0.000000787 0.0698 f_meas binary 0.857 Preprocessor1_Model01
## 6 0.000000787 0.0698 roc_auc binary 0.714 Preprocessor1_Model01
## 7 0.000374 0.166 accuracy binary 0.767 Preprocessor1_Model02
## 8 0.000374 0.166 sensitivity binary 0.913 Preprocessor1_Model02
## 9 0.000374 0.166 specificity binary 0.286 Preprocessor1_Model02
## 10 0.000374 0.166 precision binary 0.808 Preprocessor1_Model02
## # ℹ 50 more rows
##
## [[3]]
## # A tibble: 60 × 6
## penalty mixture .metric .estimator .estimate .config
## <dbl> <dbl> <chr> <chr> <dbl> <chr>
## 1 0.000000787 0.0698 accuracy binary 0.667 Preprocessor1_Model01
## 2 0.000000787 0.0698 sensitivity binary 1 Preprocessor1_Model01
## 3 0.000000787 0.0698 specificity binary 0.167 Preprocessor1_Model01
## 4 0.000000787 0.0698 precision binary 0.643 Preprocessor1_Model01
## 5 0.000000787 0.0698 f_meas binary 0.783 Preprocessor1_Model01
## 6 0.000000787 0.0698 roc_auc binary 0.824 Preprocessor1_Model01
## 7 0.000374 0.166 accuracy binary 0.667 Preprocessor1_Model02
## 8 0.000374 0.166 sensitivity binary 1 Preprocessor1_Model02
## 9 0.000374 0.166 specificity binary 0.167 Preprocessor1_Model02
## 10 0.000374 0.166 precision binary 0.643 Preprocessor1_Model02
## # ℹ 50 more rows
##
## [[4]]
## # A tibble: 60 × 6
## penalty mixture .metric .estimator .estimate .config
## <dbl> <dbl> <chr> <chr> <dbl> <chr>
## 1 0.000000787 0.0698 accuracy binary 0.733 Preprocessor1_Model01
## 2 0.000000787 0.0698 sensitivity binary 0.913 Preprocessor1_Model01
## 3 0.000000787 0.0698 specificity binary 0.143 Preprocessor1_Model01
## 4 0.000000787 0.0698 precision binary 0.778 Preprocessor1_Model01
## 5 0.000000787 0.0698 f_meas binary 0.84 Preprocessor1_Model01
## 6 0.000000787 0.0698 roc_auc binary 0.745 Preprocessor1_Model01
## 7 0.000374 0.166 accuracy binary 0.7 Preprocessor1_Model02
## 8 0.000374 0.166 sensitivity binary 0.870 Preprocessor1_Model02
## 9 0.000374 0.166 specificity binary 0.143 Preprocessor1_Model02
## 10 0.000374 0.166 precision binary 0.769 Preprocessor1_Model02
## # ℹ 50 more rows
What we see here is the 6 metrics for each of the 10 tunings from the
grid search. We get four tibbles here—one for each fold. The
.config tells us that this is pre-processor 1. What does
this refer to?
cv_res$wfs$wflow_id[[1]]
## [1] "word_nostop_nostem_f2_elasticnet"
This is looking at just words, no stop words, no stemming, a minimum
use of 2 in the corpus, and the elastic net.
But what we want to know is which model is best. We used
best_model for that above.
mod$best_id
## [1] "word_smart_stemmed_f2_randforest"
mod$best_params
## # A tibble: 1 × 3
## mtry min_n .config
## <int> <int> <chr>
## 1 20 34 Preprocessor1_Model09
What performed best in cross-validation was only looking at words,
using the SMART dictionary for stop words, stemming, only considering
words used at least twice in the corpus, and using the random forest
while considering 20 words at a time with a minimum leaf size of 34.
We can also look at the holdout metrics:
mod$ho_metrics
## # A tibble: 1 × 7
## accuracy precision sensitivity specificity est_pct_class est_pct_prob act_pct
## <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 0.765 0.762 0.994 0.110 0.0327 0.191 0.259
You’ll be familiar with the first four, but the last three are ones I
use. Often, I am using these types of models to estimate, “How many
people are talking about X theme?” So, I don’t care as much about
individual-level predictions as I do about the aggregate. I do this by
averaging up the estimated probabilities (est_pct_prob) and
using that as my estimate. So here, I would say that about 19% of
reviews are discussing Anderson’s visual style. The actual percent
(act_pct) is a bit more at about 26%. But not bad for a
Saturday afternoon.
What about variable importance? What words are helping us figure out
if the review touches on Wes’s visual style or not?
print(mod$var_imp, n = 10)
## # A tibble: 368 × 2
## Variable Importance
## <fct> <dbl>
## 1 color 1.56
## 2 visual 1.35
## 3 cool 1.02
## 4 audienc 0.994
## 5 shot 0.940
## 6 plot 0.751
## 7 design 0.575
## 8 pretti 0.554
## 9 set 0.503
## 10 landscap 0.492
## # ℹ 358 more rows
And yeah, this makes sense. The last thing we can do is plug in
new reviews that have gone up since I made the model and
generate predictions for them. The first and the third talk about visual
style, while the others do not.
new_reviews <- tibble(
text = c("Kodak film and miniatures make for a cool movie",
"To me, Wes never misses",
paste(
"Visuals and characters were stunning as always but the dual plot",
"was hard to follow and the whole thing felt a bit hollow"
),
"my head hurts idk how i feel about this yet",
"Me after asking AI to write me a wes anderson script")
)
# predict on these
predict(mod$fit, new_reviews, type = "prob")
## # A tibble: 5 × 2
## .pred_0 .pred_1
## <dbl> <dbl>
## 1 0.675 0.325
## 2 0.955 0.0448
## 3 0.545 0.455
## 4 0.968 0.0317
## 5 0.870 0.130
Unfortunately, we don’t get hits on our two that actually are about
his style. In the aggregate, we see 40% of these new reviews about his
style. Averaging up the .pred_1 column only gives us about
20%, but we can’t be surprised about that big of a miss from just five
new reviews.
Step 5: Scale and Maintain
You’ve got the best model(s) in-hand. What now? You scale it! In Step
1, we only looked at a random sample of maybe 2000 pieces of text. But
you may have much, much more than that; you might be continuously
collecting new text data that adhere to the coding manual. Use the
predict() function on those cases. Then what I do is
average up the predicted probabilities to get an estimate of how many
people are talking about a given theme. But you could also use the
predicted probabilities to decide which users to email about a specific
theme, for example. Since your coding scheme came from a specific prompt
or data source, make sure that you are applying it only to text that
come from this same generating mechanism (e.g., survey question,
feedback prompt, ticketing system).
What is absolutely crucial here is keeping humans in
the loop. As new data come in, figure out a regular cadence where you
generate a (smaller than the original) random sample of data, code it,
and then see how your predictions are holding up to new data.
(After checking performance, these newly coded cases can then
be added to the training set and the model can be updated to include
them.) Also, read through these data to see if the coding manual needs
to be updated, themes are no longer relevant, or new themes need to be
added. This is, again, a grind of a process. But it is a way of scaling
up the unique expertise of the humans in your organization to data that
generally doesn’t get much attention. And, in my experience, keeping
humans in the loop is not only good for model performance, but reading
real responses from real people helps you as a researcher understand
your data and your users (or respondents or whoever is generating the
data) better.
Appendix A
library(rvest)
library(tidyverse)
# 12 reviews per page
# 10 possible ratings
# 6 pages each
# n = 720 reviews total
base_url1 <- "https://letterboxd.com/film/asteroid-city/reviews/rated/"
base_url2 <- "/by/activity/page/"
ratings <- seq(.5, 5, .5)
pages <- 6
# people often say to use purrr::map or an apply statement instead of a for
# loop. but if it fails, I want to know where, and I want to keep the data
# we already collected. so I'm initializing an empty data frame and then
# slotting the data in one page at a time
dat <- tibble(rating = vector("double"), text = vector("character"))
for (r in ratings) {
pg <- 1
while (pg < 7) {
url <- paste0(base_url1, r, base_url2, pg)
txt <- url %>%
read_html() %>%
html_nodes(".collapsible-text") %>%
html_text2() %>%
map_chr(str_replace_all, fixed("\n"), " ")
dat <- bind_rows(dat, tibble(rating = r, text = txt))
cat("finished page", pg, "of", r, "stars\n")
pg <- pg + 1
Sys.sleep(runif(1, 0, 10))
}
}
write_csv(dat, "ratings_uncoded.csv")
Appendix B
# funs -------------------------------------------------------------------------
library(textrecipes)
library(vip)
library(stopwords)
library(tidymodels)
library(workflowsets)
library(tidyverse)
# prepare data for modeling, do train/test split
# default at a holdout set of 15%
# stratify on the outcome variable
prep_data <- function(dat, y, txt, prop) {
dat %>%
transmute(text = .data[[txt]], y = factor(.data[[y]])) %>%
initial_split(prop, strata = y)
}
# do cross-validation with the same, pre-defined, hard-coded engines and recipes
# n_folds is number of folds; grid_size is the size of the grid
do_cv <- function(dat_train, n_folds, grid_size) {
# define recipes -------------------------------------------------------------
## base ----------------------------------------------------------------------
rec_base <- recipe(y ~ text, dat_train)
## tokenize ------------------------------------------------------------------
rec_word_nostop <- rec_base %>%
step_tokenize(
text,
token = "words"
)
rec_word_smart <- rec_base %>%
step_tokenize(
text,
token = "words",
options = list(stopwords = stopwords(source = "smart"))
)
rec_word_iso <- rec_base %>%
step_tokenize(
text,
token = "words",
options = list(stopwords = stopwords(source = "stopwords-iso"))
)
rec_both_nostop <- rec_base %>%
step_tokenize(
text,
token = "skip_ngrams",
options = list(
n = 2,
k = 0
)
)
rec_both_smart <- rec_base %>%
step_tokenize(
text,
token = "skip_ngrams",
options = list(
stopwords = stopwords(source = "smart"),
n = 2,
k = 0
)
)
rec_both_iso <- rec_base %>%
step_tokenize(
text,
token = "skip_ngrams",
options = list(
stopwords = stopwords(source = "stopwords-iso"),
n = 2,
k = 0
)
)
## stem ----------------------------------------------------------------------
rec_word_nostop_stemmed <- rec_word_nostop %>%
step_stem(text)
rec_word_smart_stemmed <- rec_word_smart %>%
step_stem(text)
rec_word_iso_stemmed <- rec_word_iso %>%
step_stem(text)
rec_both_nostop_stemmed <- rec_both_nostop %>%
step_stem(text)
rec_both_smart_stemmed <- rec_both_smart %>%
step_stem(text)
rec_both_iso_stemmed <- rec_both_iso %>%
step_stem(text)
## filter, weight ------------------------------------------------------------
rec_word_nostop_f2 <- rec_word_nostop %>%
step_tokenfilter(text, min_times = 2, max_tokens = 5000) %>%
step_tf(text, weight_scheme = "binary")
rec_word_smart_f2 <- rec_word_smart %>%
step_tokenfilter(text, min_times = 2, max_tokens = 5000) %>%
step_tf(text, weight_scheme = "binary")
rec_word_iso_f2 <- rec_word_iso %>%
step_tokenfilter(text, min_times = 2, max_tokens = 5000) %>%
step_tf(text, weight_scheme = "binary")
rec_both_nostop_f2 <- rec_both_nostop %>%
step_tokenfilter(text, min_times = 2, max_tokens = 5000) %>%
step_tf(text, weight_scheme = "binary")
rec_both_smart_f2 <- rec_both_smart %>%
step_tokenfilter(text, min_times = 2, max_tokens = 5000) %>%
step_tf(text, weight_scheme = "binary")
rec_both_iso_f2 <- rec_both_iso %>%
step_tokenfilter(text, min_times = 2, max_tokens = 5000) %>%
step_tf(text, weight_scheme = "binary")
rec_word_nostop_stemmed_f2 <- rec_word_nostop_stemmed %>%
step_tokenfilter(text, min_times = 2, max_tokens = 5000) %>%
step_tf(text, weight_scheme = "binary")
rec_word_smart_stemmed_f2 <- rec_word_smart_stemmed %>%
step_tokenfilter(text, min_times = 2, max_tokens = 5000) %>%
step_tf(text, weight_scheme = "binary")
rec_word_iso_stemmed_f2 <- rec_word_iso_stemmed %>%
step_tokenfilter(text, min_times = 2, max_tokens = 5000) %>%
step_tf(text, weight_scheme = "binary")
rec_both_nostop_stemmed_f2 <- rec_both_nostop_stemmed %>%
step_tokenfilter(text, min_times = 2, max_tokens = 5000) %>%
step_tf(text, weight_scheme = "binary")
rec_both_smart_stemmed_f2 <- rec_both_smart_stemmed %>%
step_tokenfilter(text, min_times = 2, max_tokens = 5000) %>%
step_tf(text, weight_scheme = "binary")
rec_both_iso_stemmed_f2 <- rec_both_iso_stemmed %>%
step_tokenfilter(text, min_times = 2, max_tokens = 5000) %>%
step_tf(text, weight_scheme = "binary")
rec_word_nostop_f5 <- rec_word_nostop %>%
step_tokenfilter(text, min_times = 5, max_tokens = 5000) %>%
step_tf(text, weight_scheme = "binary")
rec_word_smart_f5 <- rec_word_smart %>%
step_tokenfilter(text, min_times = 5, max_tokens = 5000) %>%
step_tf(text, weight_scheme = "binary")
rec_word_iso_f5 <- rec_word_iso %>%
step_tokenfilter(text, min_times = 5, max_tokens = 5000) %>%
step_tf(text, weight_scheme = "binary")
rec_both_nostop_f5 <- rec_both_nostop %>%
step_tokenfilter(text, min_times = 5, max_tokens = 5000) %>%
step_tf(text, weight_scheme = "binary")
rec_both_smart_f5 <- rec_both_smart %>%
step_tokenfilter(text, min_times = 5, max_tokens = 5000) %>%
step_tf(text, weight_scheme = "binary")
rec_both_iso_f5 <- rec_both_iso %>%
step_tokenfilter(text, min_times = 5, max_tokens = 5000) %>%
step_tf(text, weight_scheme = "binary")
rec_word_nostop_stemmed_f5 <- rec_word_nostop_stemmed %>%
step_tokenfilter(text, min_times = 5, max_tokens = 5000) %>%
step_tf(text, weight_scheme = "binary")
rec_word_smart_stemmed_f5 <- rec_word_smart_stemmed %>%
step_tokenfilter(text, min_times = 5, max_tokens = 5000) %>%
step_tf(text, weight_scheme = "binary")
rec_word_iso_stemmed_f5 <- rec_word_iso_stemmed %>%
step_tokenfilter(text, min_times = 5, max_tokens = 5000) %>%
step_tf(text, weight_scheme = "binary")
rec_both_nostop_stemmed_f5 <- rec_both_nostop_stemmed %>%
step_tokenfilter(text, min_times = 5, max_tokens = 5000) %>%
step_tf(text, weight_scheme = "binary")
rec_both_smart_stemmed_f5 <- rec_both_smart_stemmed %>%
step_tokenfilter(text, min_times = 5, max_tokens = 5000) %>%
step_tf(text, weight_scheme = "binary")
rec_both_iso_stemmed_f5 <- rec_both_iso_stemmed %>%
step_tokenfilter(text, min_times = 5, max_tokens = 5000) %>%
step_tf(text, weight_scheme = "binary")
rec_word_nostop <- rec_word_nostop %>%
step_tf(text, weight_scheme = "binary")
rec_word_smart <- rec_word_smart %>%
step_tf(text, weight_scheme = "binary")
rec_word_iso <- rec_word_iso %>%
step_tf(text, weight_scheme = "binary")
rec_both_nostop <- rec_both_nostop %>%
step_tf(text, weight_scheme = "binary")
rec_both_smart <- rec_both_smart %>%
step_tf(text, weight_scheme = "binary")
rec_both_iso <- rec_both_iso %>%
step_tf(text, weight_scheme = "binary")
rec_word_nostop_stemmed <- rec_word_nostop_stemmed %>%
step_tf(text, weight_scheme = "binary")
rec_word_smart_stemmed <- rec_word_smart_stemmed %>%
step_tf(text, weight_scheme = "binary")
rec_word_iso_stemmed <- rec_word_iso_stemmed %>%
step_tf(text, weight_scheme = "binary")
rec_both_nostop_stemmed <- rec_both_nostop_stemmed %>%
step_tf(text, weight_scheme = "binary")
rec_both_smart_stemmed <- rec_both_smart_stemmed %>%
step_tf(text, weight_scheme = "binary")
rec_both_iso_stemmed <- rec_both_iso_stemmed %>%
step_tf(text, weight_scheme = "binary")
## define specs --------------------------------------------------------------
spec_elasticnet <- logistic_reg(
mode = "classification",
engine = "glmnet",
penalty = tune(),
mixture = tune()
)
spec_randforest <- rand_forest(
mode = "classification",
mtry = tune(),
min_n = tune(),
trees = 500
) %>%
set_engine(engine = "ranger", importance = "impurity")
# make workflowset -----------------------------------------------------------
wfs <- workflow_set(
preproc = list(
word_nostop_nostem_f2 = rec_word_nostop_f2,
word_smart_nostem_f2 = rec_word_smart_f2,
word_iso_nostem_f2 = rec_word_iso_f2,
both_nostop_nostem_f2 = rec_both_nostop_f2,
both_smart_nostem_f2 = rec_both_smart_f2,
both_iso_nostem_f2 = rec_both_iso_f2,
word_nostop_stemmed_f2 = rec_word_nostop_stemmed_f2,
word_smart_stemmed_f2 = rec_word_smart_stemmed_f2,
word_iso_stemmed_f2 = rec_word_iso_stemmed_f2,
both_nostop_stemmed_f2 = rec_both_nostop_stemmed_f2,
both_smart_stemmed_f2 = rec_both_smart_stemmed_f2,
both_iso_stemmed_f2 = rec_both_iso_stemmed_f2,
word_nostop_nostem_f5 = rec_word_nostop_f5,
word_smart_nostem_f5 = rec_word_smart_f5,
word_iso_nostem_f5 = rec_word_iso_f5,
both_nostop_nostem_f5 = rec_both_nostop_f5,
both_smart_nostem_f5 = rec_both_smart_f5,
both_iso_nostem_f5 = rec_both_iso_f5,
word_nostop_stemmed_f5 = rec_word_nostop_stemmed_f5,
word_smart_stemmed_f5 = rec_word_smart_stemmed_f5,
word_iso_stemmed_f5 = rec_word_iso_stemmed_f5,
both_nostop_stemmed_f5 = rec_both_nostop_stemmed_f5,
both_smart_stemmed_f5 = rec_both_smart_stemmed_f5,
both_iso_stemmed_f5 = rec_both_iso_stemmed_f5,
word_nostop_nostem_f0 = rec_word_nostop,
word_smart_nostem_f0 = rec_word_smart,
word_iso_nostem_f0 = rec_word_iso,
both_nostop_nostem_f0 = rec_both_nostop,
both_smart_nostem_f0 = rec_both_smart,
both_iso_nostem_f0 = rec_both_iso,
word_nostop_stemmed_f0 = rec_word_nostop_stemmed,
word_smart_stemmed_f0 = rec_word_smart_stemmed,
word_iso_stemmed_f0 = rec_word_iso_stemmed,
both_nostop_stemmed_f0 = rec_both_nostop_stemmed,
both_smart_stemmed_f0 = rec_both_smart_stemmed,
both_iso_stemmed_f0 = rec_both_iso_stemmed
),
models = list(
elasticnet = spec_elasticnet,
randforest = spec_randforest
),
cross = TRUE
)
# do cross-validation
folds <- vfold_cv(dat_train, v = n_folds)
# get result of cross-validation
cv_res <- wfs %>%
workflow_map(
"tune_grid",
grid = grid_size,
resamples = folds,
metrics = metric_set(
accuracy,
sensitivity,
specificity,
precision,
f_meas,
roc_auc
),
verbose = TRUE
)
# return the entire workflow set and the results of cross-validation
return(list(wfs = wfs, cv_res = cv_res))
}
# take results from cross-validation, get a final model and held-out metrics
best_model <- function(dat, cv_out, metric = "roc_auc") {
# get the id of the best model, as according to the specified metric
best_id <- cv_out$cv_res %>%
rank_results(rank_metric = metric) %>%
filter(.metric == metric & rank == 1) %>%
pull(wflow_id)
# get the name of the model
# if you name the workflow sets differently, this step will change
# it's based on the hardcoded names I gave them in defining the workflow set
m <- str_split(best_id, "_")[[1]][[5]]
# get best parameters, do final fit
best_params <- cv_out$cv_res %>%
extract_workflow_set_result(best_id) %>%
select_best(metric = metric)
final_fit <- cv_out$cv_res %>%
extract_workflow(best_id) %>%
finalize_workflow(best_params) %>%
fit(training(dat))
# run it on the holdout data
dat_test <- testing(dat)
# if glmnet, feed it the right penalty
# I'm pretty sure this is necessary,
# because glmnet fits many lambda as it's more efficient
if (m == "elasticnet") {
dat_test <- bind_cols(
dat_test,
predict(final_fit, dat_test, penalty = best_params$penalty),
predict(final_fit, dat_test, type = "prob", penalty = best_params$penalty)
)
} else {
dat_test <- bind_cols(
dat_test,
predict(final_fit, dat_test),
predict(final_fit, dat_test, type = "prob")
)
}
# define metrics to output
ms <- metric_set(accuracy, sensitivity, specificity, precision)
# return metrics
metrics_res <- ms(dat_test, truth = y, estimate = .pred_class) %>%
select(-.estimator) %>%
spread(.metric, .estimate) %>%
mutate(
est_pct_class = mean(dat_test$.pred_class == 1),
est_pct_prob = mean(dat_test$.pred_1),
act_pct = mean(dat_test$y == 1)
)
# get variable importance, which depends on the model
if (m == "randforest") {
var_imp <- final_fit %>%
extract_fit_parsnip() %>%
vi() %>%
mutate(
Variable = str_remove_all(Variable, "tf_text_"),
Variable = factor(Variable, Variable)
)
} else if (m == "elasticnet") {
var_imp <- final_fit %>%
tidy() %>%
filter(
penalty == best_params$penalty &
term != "(Intercept)" &
estimate > 0
) %>%
arrange(desc(abs(estimate))) %>%
select(-penalty) %>%
mutate(
term = str_remove_all(term, "tf_text_"),
term = factor(term, term)
)
} else {
# if you add more models, this is where you'd change the code to get
# variable importance for that specific class of model output
var_imp <- NA
}
return(
list(
best_id = best_id,
best_params = best_params,
var_imp = var_imp,
fit = final_fit,
ho_metrics = metrics_res
)
)
}
