1. Understand the problem:

We are going to load up an unstructured dataset, explore it, and build a random forest model to predict if the content is AI generated or written by a human!

# install.packages(c("knitr", "markdown",
#    "readr","dplyr","ggplot2","stringr","rsample","yardstick", "scales",
#    "text2vec","ranger","Matrix", "SnowballC", "tidytext", "tidyr", "tibble" ))
# install.packages("tidyr")
# first time: go to console and run:

#install.packages("renv")
#renv::restore() # installs the pinned versions
library(readr); library(dplyr); library(ggplot2); library(stringr)
## 
## Attaching package: 'dplyr'
## The following objects are masked from 'package:stats':
## 
##     filter, lag
## The following objects are masked from 'package:base':
## 
##     intersect, setdiff, setequal, union
library(rsample); library(yardstick); library(text2vec); library(SnowballC); 
## 
## Attaching package: 'yardstick'
## The following object is masked from 'package:readr':
## 
##     spec
library(tidytext); library(tidyr); library(curl);
## Using libcurl 8.5.0 with OpenSSL/3.0.13
## 
## Attaching package: 'curl'
## The following object is masked from 'package:readr':
## 
##     parse_date
library(quanteda); library(ranger);
## Package version: 4.3.1
## Unicode version: 15.1
## ICU version: 74.2
## Parallel computing: disabled
## See https://quanteda.io for tutorials and examples.
library(quanteda.textstats)

2. Inspect the data

We are going to load it from my dropbox. Its large!

## # A tibble: 2 × 3
##   generated      n p    
##   <fct>      <int> <chr>
## 1 human     305797 63%  
## 2 ai        181436 37%
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##       1    1582    2101    2269    2723   18318

We can inspect one of the texts in full.

ACTION: Try looking at a few different texts by changing the ‘row’ selection. Confirm in the console whether you are looking at AI or human text. How will you do this?

x <- df[[1,1]] #this pulls the first row, first column cell as a scalar value
cat(x) #print as whole string
## Cars. Cars have been around since they became famous in the 1900s, when Henry Ford created and built the first ModelT. Cars have played a major role in our every day lives since then. But now, people are starting to question if limiting car usage would be a good thing. To me, limiting the use of cars might be a good thing to do.
## 
## In like matter of this, article, "In German Suburb, Life Goes On Without Cars," by Elizabeth Rosenthal states, how automobiles are the linchpin of suburbs, where middle class families from either Shanghai or Chicago tend to make their homes. Experts say how this is a huge impediment to current efforts to reduce greenhouse gas emissions from tailpipe. Passenger cars are responsible for 12 percent of greenhouse gas emissions in Europe...and up to 50 percent in some carintensive areas in the United States. Cars are the main reason for the greenhouse gas emissions because of a lot of people driving them around all the time getting where they need to go. Article, "Paris bans driving due to smog," by Robert Duffer says, how Paris, after days of nearrecord pollution, enforced a partial driving ban to clear the air of the global city. It also says, how on Monday, motorist with evennumbered license plates were ordered to leave their cars at home or be fined a 22euro fine 31. The same order would be applied to oddnumbered plates the following day. Cars are the reason for polluting entire cities like Paris. This shows how bad cars can be because, of all the pollution that they can cause to an entire city.
## 
## Likewise, in the article, "Carfree day is spinning into a big hit in Bogota," by Andrew Selsky says, how programs that's set to spread to other countries, millions of Columbians hiked, biked, skated, or took the bus to work during a carfree day, leaving streets of this capital city eerily devoid of traffic jams. It was the third straight year cars have been banned with only buses and taxis permitted for the Day Without Cars in the capital city of 7 million. People like the idea of having carfree days because, it allows them to lesson the pollution that cars put out of their exhaust from people driving all the time. The article also tells how parks and sports centers have bustled throughout the city uneven, pitted sidewalks have been replaced by broad, smooth sidewalks rushhour restrictions have dramatically cut traffic and new restaurants and upscale shopping districts have cropped up. Having no cars has been good for the country of Columbia because, it has aloud them to repair things that have needed repairs for a long time, traffic jams have gone down, and restaurants and shopping districts have popped up, all due to the fact of having less cars around.
## 
## In conclusion, the use of less cars and having carfree days, have had a big impact on the environment of cities because, it is cutting down the air pollution that the cars have majorly polluted, it has aloud countries like Columbia to repair sidewalks, and cut down traffic jams. Limiting the use of cars would be a good thing for America. So we should limit the use of cars by maybe riding a bike, or maybe walking somewhere that isn't that far from you and doesn't need the use of a car to get you there. To me, limiting the use of cars might be a good thing to do.
head(df)
## # A tibble: 6 × 3
##   text                                                           generated nchar
##   <chr>                                                          <fct>     <int>
## 1 "Cars. Cars have been around since they became famous in the … human      3289
## 2 "Transportation is a large necessity in most countries worldw… human      2738
## 3 "\"America's love affair with it's vehicles seems to be cooli… human      4428
## 4 "How often do you ride in a car? Do you drive a one or any ot… human      4013
## 5 "Cars are a wonderful thing. They are perhaps one of the worl… human      4698
## 6 "The electrol college system is an unfair system, people don'… human      3311
glimpse(df)
## Rows: 487,233
## Columns: 3
## $ text      <chr> "Cars. Cars have been around since they became famous in the…
## $ generated <fct> human, human, human, human, human, human, human, human, huma…
## $ nchar     <int> 3289, 2738, 4428, 4013, 4698, 3311, 2551, 2470, 2707, 3290, …

OK, we can do some tidying. Let’s change the labels to 0 (Human) and 1 (AI)

df <- df %>% mutate(
  label = ifelse(tolower(as.character(df[["generated"]])) == "human", 0L, 1L)
) %>% 
  select(-generated)

glimpse(df)
## Rows: 487,233
## Columns: 3
## $ text  <chr> "Cars. Cars have been around since they became famous in the 190…
## $ nchar <int> 3289, 2738, 4428, 4013, 4698, 3311, 2551, 2470, 2707, 3290, 2159…
## $ label <int> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…

Now we’ll check for duplicates. We want to deduplicate by text only, rather than the whole row. Let’s normalise the data first (ie case/space-insensitive)

ACTION: Why might we want to do only dedup on text, and not the whole observation? ACTION: why normalise first?

df <- df %>% 
  mutate(norm_text = tolower(str_squish(text)),
  nchar_norm = nchar(norm_text))

glimpse(df)
## Rows: 487,233
## Columns: 5
## $ text       <chr> "Cars. Cars have been around since they became famous in th…
## $ nchar      <int> 3289, 2738, 4428, 4013, 4698, 3311, 2551, 2470, 2707, 3290,…
## $ label      <int> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,…
## $ norm_text  <chr> "cars. cars have been around since they became famous in th…
## $ nchar_norm <int> 3286, 2734, 4424, 4011, 4695, 3307, 2546, 2467, 2703, 3286,…

Great. No missing values. But we have 23,004 duplications of text. This matters as duplicates can leak across train/test. duplicates count the extra rows beyuond the first for every repeated text. e.g. if the same text is repeated 3 times, it will contribute 2 to the sum.

colSums(is.na(df))
##       text      nchar      label  norm_text nchar_norm 
##          0          0          0          0          0
sum(duplicated(df$norm_text))
## [1] 23004

There is plenty of data, so we could just de-duplicate. An alternative is to split so the same norm_text never appears in both train and test sets.

ACTION: What might we want to check before removing duplicates?

# 1) How many norm_texts are duplicated at all?
# We are couting the number of unique texts that are duplicated at least once.
# The number may differ to the above measure - if a text appears 3 times, it will contribue 1 here.
dup_texts <- df %>%
  count(norm_text, name = "rows_per_text") %>%
  filter(rows_per_text > 1)

n_dup_texts <- nrow(dup_texts)

# 2) Which duplicated norm_texts have conflicting labels?
conflict_texts <- df %>%
  group_by(norm_text) %>%
  summarise(n_labels = n_distinct(label), .groups = "drop") %>%
  filter(n_labels > 1)

n_conflict_texts <- nrow(conflict_texts)

cat("# duplicated norm_text values: ", n_dup_texts, "\n",
    "# duplicated norm_text with conflicting labels: ", n_conflict_texts, "\n",
    "share with conflicts: ", round(100 * n_conflict_texts / n_dup_texts, 2), "%\n", sep = "")
## # duplicated norm_text values: 22862
## # duplicated norm_text with conflicting labels: 5
## share with conflicts: 0.02%
# 3) How many ROWS are involved in conflicts (not just how many texts)?
n_rows_in_conflict <- df %>%
  semi_join(conflict_texts, by = "norm_text") %>%
  nrow()
cat("Rows involved in conflicts: ", n_rows_in_conflict, "\n", sep = "")
## Rows involved in conflicts: 10

OK - so it seems we have some texts repeated more than once. We have some texts with conflicting labels, luckily not many. Each conflicitng label occurs exactly twice with opposing labels (2 x 5)

At this point, the easiest is to remove all duplicates. We can add in some checks. Its always good to sanity check!

n_before <- nrow(df)

# keep the first row for each normalized text
df <- df %>% distinct(norm_text, .keep_all = TRUE)

n_after <- nrow(df)
cat("Dropped", n_before - n_after, "rows via norm_text de-dup\n")
## Dropped 23004 rows via norm_text de-dup

That’s what we expected - 23,004 rows were dropped.

Let’s inspect the balance of data and plot it

df %>% count(label) %>% 
  mutate(pct = n / sum(n)) %>% 
  arrange(label)
## # A tibble: 2 × 3
##   label      n   pct
##   <int>  <int> <dbl>
## 1     0 284465 0.613
## 2     1 179764 0.387
df %>% count(label) %>% 
  ggplot(aes(label, n)) +
  geom_col(fill='blue') +
  labs(x = "label (0=human, 1= AI)", y="count")

There is a lot of data. We’ll select just 10,000 of each to keep computation manageable. We will set a seed for reproducibility.

ACTION: Do a check that the result is what you expect. How will you approach this?

set.seed(1984)

target_n <- 10000L
df_balanced <- df %>% 
  group_by(label) %>% 
  slice_sample(n = target_n, replace = FALSE) %>% 
  ungroup() %>% 
  slice_sample(prop = 1) #shuffle

We can inspect our cleaned dataset. We’ll create a new temporary dataset called d

ACTION: What is this telling us?

# 1) Add counts 
d <- df_balanced %>%
  mutate(
    char_count = nchar_norm,
    word_count = str_count(text, "\\S+"),
    label = factor(label, levels = c(0,1), labels = c("human","ai"))
  )

# 2) summary stats by label
d %>%
  group_by(label) %>%
  summarise(
    n = n(),
    mean_chars = round(mean(char_count),1),
    median_chars = median(char_count),
    p95_chars = quantile(char_count, 0.95),
    mean_words = round(mean(word_count),1),
    median_words = median(word_count),
    p95_words = quantile(word_count, 0.95),
    .groups = "drop"
  )
## # A tibble: 2 × 8
##   label     n mean_chars median_chars p95_chars mean_words median_words
##   <fct> <int>      <dbl>        <dbl>     <dbl>      <dbl>        <dbl>
## 1 human 10000      2352.         2160      4485       424.          392
## 2 ai    10000      2131.         2064      3559       346.          340
## # ℹ 1 more variable: p95_words <dbl>
# clip x-axis to reduce the long tail 
p99_chars <- quantile(d$char_count, 1)
p99_words <- quantile(d$word_count, 1)

# 3) Character count — overlapped normalized hist
ggplot(d, aes(char_count, fill = label)) +
  geom_histogram(aes(y = after_stat(count / tapply(..count.., ..PANEL.., sum)[..PANEL..])),
                 position = "identity", alpha = 0.4, bins = 80) +
  coord_cartesian(xlim = c(0, p99_chars)) +
  labs(title = "Character count distribution by label",
       x = "Characters", y = "Proportion within panel", fill = "Label")

# 4) Word count — overlapped normalized hist
ggplot(d, aes(word_count, fill = label)) +
  geom_histogram(aes(y = after_stat(count / tapply(..count.., ..PANEL.., sum)[..PANEL..])),
                 position = "identity", alpha = 0.4, bins = 80) +
  coord_cartesian(xlim = c(0, p99_words)) +
  labs(title = "Word count distribution by label",
       x = "Words", y = "Proportion within panel", fill = "Label")

Some quickie modelling - this is part of exploring We’ll add average word length (characters/word)

ACTION: What is it telling us?

d <- d |>
  mutate(avg_word_len = ifelse(word_count > 0, char_count / word_count, NA_real_))

m0 <- glm(label ~ word_count + char_count, data = d, family = binomial())
m1 <- glm(label ~ avg_word_len,            data = d, family = binomial())
AIC(m0); AIC(m1)   # m0 is lower (better)
## [1] 17722.09
## [1] 19175.03
summary(m0)
## 
## Call:
## glm(formula = label ~ word_count + char_count, family = binomial(), 
##     data = d)
## 
## Coefficients:
##               Estimate Std. Error z value Pr(>|z|)    
## (Intercept)  2.0314419  0.0550071   36.93   <2e-16 ***
## word_count  -0.0688718  0.0010256  -67.15   <2e-16 ***
## char_count   0.0109062  0.0001674   65.16   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 27726  on 19999  degrees of freedom
## Residual deviance: 17716  on 19997  degrees of freedom
## AIC: 17722
## 
## Number of Fisher Scoring iterations: 5
summary(m1)
## 
## Call:
## glm(formula = label ~ avg_word_len, family = binomial(), data = d)
## 
## Coefficients:
##               Estimate Std. Error z value Pr(>|z|)    
## (Intercept)  -21.57094    0.31562  -68.34   <2e-16 ***
## avg_word_len   3.72772    0.05476   68.07   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 27726  on 19999  degrees of freedom
## Residual deviance: 19171  on 19998  degrees of freedom
## AIC: 19175
## 
## Number of Fisher Scoring iterations: 5

AI definitely uses bigger words!

d <- d %>% mutate(chars_per_word = char_count / pmax(word_count, 1))

ggplot(d, aes(chars_per_word, fill = factor(label, labels=c("human","ai")))) +
  geom_density(alpha = 0.4) +
  scale_fill_brewer(palette = "Set2", name = "Label") +
  labs(title = "Avg characters per word by label", x = "Chars per word", y = "Density") +
  theme_minimal()

ggplot(d, aes(pmax(word_count), fill = factor(label, labels=c("human","ai")))) +
  geom_density(alpha = 0.4) +
  scale_fill_brewer(palette = "Set2", name = "Label") +
  labs(title = "Avg number of words by label", x = "Number of words", y = "Density") +
  theme_minimal()

Some texts are really short - let’s look at a few. You can try changing the cutoff.

idx <- head(which(d$word_count < 25), 10)
for (i in idx) {
  cat("\n---- row", i, "| label:", d$label[i], "| words:", d$word_count[i], "----\n")
  cat((d$norm_text %||% d$text)[i], "\n")
}
## 
## ---- row 3793 | label: 2 | words: 14 ----
## community service is an integral part of every individual’s development, as it provides a 
## 
## ---- row 13996 | label: 1 | words: 14 ----
## the memorable teacher ever had was a teacher in 10 word wild all students 
## 
## ---- row 18139 | label: 2 | words: 21 ----
## discuss the benefits and challenges associated with the concept of car-free cities, with particular focus on pollution reduction and transportation alternatives.

3. More interesting exploration we can do with text

We can do better than than just looking at word lengths. Let’s do some extra pre-processing on the data to get it ready

ACTION: Can you guess what the regex code is doing?

d <- df_balanced

# stratified split
# We split first before 'tokenising' so as not to leak info
set.seed(42)
split <- initial_split(d, prop = 0.8, strata = label)
train <- training(split)
test  <- testing(split)

# Targets come from these sets
y_train <- factor(train$label, levels = c(0, 1))
y_test  <- factor(test$label,  levels = c(0, 1))

clean <- function(x) {
  x |>
    str_replace_all("http[s]?://\\S+|www\\.\\S+", " ") |>
    str_replace_all("\\S+@\\S+\\.[A-Za-z]{2,}", " ") |>
    str_replace_all("&amp;|&lt;|&gt;", " ") |>
    str_replace_all("[^\\p{L}\\p{N}\\s'’-]", " ") |>
    str_squish() |>
    str_to_lower()
}

# quick test
txt <- c("Hello www.example.com — email me: A@B.com &amp; thanks!",
         "Extra   spaces, symbols!!! and 123.")
clean(txt)
## [1] "hello email me thanks"        "extra spaces symbols and 123"
train$text_clean <- clean(train$text)
test$text_clean  <- clean(test$text)

# tokenize + build vocab on TRAIN ONLY
it_tr <- itoken(train$text_clean, progressbar = FALSE)
it_te <- itoken(test$text_clean,  progressbar = FALSE)

vocab <- create_vocabulary(it_tr, ngram = c(1L,2L))
vocab <- prune_vocabulary(vocab, term_count_min = 10, doc_proportion_max = 0.5, vocab_term_max = 200000)
vec   <- vocab_vectorizer(vocab)

X_tr  <- create_dtm(it_tr, vec)
X_te  <- create_dtm(it_te, vec)

# 4) TF-IDF (fit on train, transform test)
tfidf <- TfIdf$new(norm = "l2", sublinear_tf = TRUE)
X_tr_tfidf <- tfidf$fit_transform(X_tr)
X_te_tfidf <- tfidf$transform(X_te)

Removing stopwords (e.g. ‘and’, ‘the’, ‘a’, ‘with’) and lemmatising (e.g. walking -> walk) are commonly used in text analytics.

However - we wont’ do either here - for AI/human detection, these may carry ‘style’ signals which we don’t want to blur.

You can try it later if you wish for comparison.

ACTION: When might we want to remove stopwords / lemmatise?

Here is an example…. let’s look at the top 20 words per class

top_words_plot <- function(data, text_col = "text_clean",
                           label_col = "label",
                           top_n = 20,
                           remove_stopwords = TRUE,
                           extra_stop = character()) {

  # 1) choose stopwords
  sw <- if (remove_stopwords) {
    unique(c(tidytext::stop_words$word, extra_stop))
  } else character()

  # 2) tokenize (train set recommended)
  tokens <- data %>%
    transmute(
      label = factor(.data[[label_col]], levels = c(0,1), labels = c("human","ai")),
      text  = .data[[text_col]]
    ) %>%
    unnest_tokens(word, text, token = "words") %>%
    filter(!is.na(word), nchar(word) > 2) %>%
    filter(!str_detect(word, "^[0-9]+$")) %>%            # drop pure numbers
    { if (length(sw)) filter(., !word %in% sw) else . }  # remove stopwords if requested

  # 3) count & take top-N per class
  top_words <- tokens %>%
    count(label, word, sort = TRUE) %>%
    group_by(label) %>%
    slice_max(order_by = n, n = top_n, with_ties = FALSE) %>%
    ungroup() %>%
    mutate(word = tidytext::reorder_within(word, n, label))

  # 4) plot
  ggplot(top_words, aes(n, word, fill = label)) +
    geom_col(show.legend = FALSE) +
    facet_wrap(~ label, scales = "free_y") +
    tidytext::scale_y_reordered() +
    labs(
      title = paste("Top", top_n, if (remove_stopwords) "non-stop" else "all", "words by class"),
      x = "Count", y = NULL
    ) +
    theme_minimal()
}
# Using the training data with cleaned text column 
top_words_plot(train, text_col = "text_clean", remove_stopwords = TRUE, top_n = 20)

# Keep stopwords (style-focused view)
top_words_plot(train, text_col = "text_clean", remove_stopwords = FALSE, top_n = 20)

# Remove stopwords + add a few custom ones
top_words_plot(train, text_col = "text_clean", remove_stopwords = TRUE,
               extra_stop = c("day","life","time"))

Bigrams can be informative

We are removing ‘weak’ bigrams (both tokens are stopwords, but keeping negations)

ACTION: try removing negations

top_n <- 20

d_eda <- train %>% 
  transmute(label = factor(label, levels = c(0,1), labels = c("human","ai")),
            text  = text_clean)

# selective stopword filter for bigrams: drop only bigrams where BOTH tokens are stopwords
keep_neg <- c("not","no","nor","never")
sw <- setdiff(tidytext::stop_words$word, keep_neg)

bigrams <- d_eda %>%
  unnest_tokens(bigram, text, token = "ngrams", n = 2) %>%
  filter(!is.na(bigram)) %>%
  separate(bigram, c("w1","w2"), sep = " ", remove = FALSE) %>%
  filter(!(w1 %in% sw & w2 %in% sw)) %>%  # comment out if you don't want filtering
  count(label, bigram, sort = TRUE) %>%
  group_by(label) %>%
  slice_max(order_by = n, n = top_n, with_ties = FALSE) %>%
  ungroup() %>%
  mutate(bigram = tidytext::reorder_within(bigram, n, label))  # <-- key fix

ggplot(bigrams, aes(n, bigram, fill = label)) +
  geom_col(show.legend = FALSE) +
  facet_wrap(~ label, scales = "free_y") +
  tidytext::scale_y_reordered() +
  labs(title = paste("Top", top_n, "bigrams by class (train set)"),
       x = "Count", y = NULL) +
  theme_minimal()

Lets try trigrams! WARNING: If your machine is on go-slow, maybe dont run this cell!!!

top_n <- 20

d_eda <- train %>%
  transmute(label = factor(label, levels = c(0,1), labels = c("human","ai")),
            text  = text_clean)

# keep negations; build a stopword set without them
keep_neg <- c("not","no","nor","never")
sw <- setdiff(tidytext::stop_words$word, keep_neg)

tri <- d_eda %>%
  unnest_tokens(trigram, text, token = "ngrams", n = 3) %>%
  filter(!is.na(trigram)) %>%
  separate(trigram, c("w1","w2","w3"), sep = " ", remove = FALSE) %>%
  # light filter: drop if ALL THREE are stopwords (keeps negations)
  filter(!(w1 %in% sw & w2 %in% sw & w3 %in% sw)) %>%
  count(label, trigram, sort = TRUE) %>%
  group_by(label) %>%
  slice_max(order_by = n, n = top_n, with_ties = FALSE) %>%
  ungroup() %>%
  mutate(trigram = tidytext::reorder_within(trigram, n, label))

ggplot(tri, aes(n, trigram, fill = label)) +
  geom_col(show.legend = FALSE) +
  facet_wrap(~ label, scales = "free_y") +
  tidytext::scale_y_reordered() +
  labs(title = paste("Top", top_n, "trigrams by class (train)"),
       x = "Count", y = NULL) +
  theme_minimal()

We can look at TF-IDF. Here we are removing stopwords.

ACTION: Can you remember how the TF-IDF works? Why are the results so different? ACTION: Try turning off stopword removal

# 1) Build tokens from TRAIN 
d_eda <- train %>%
  transmute(label = factor(label, levels = c(0,1), labels = c("human","ai")),
            text  = text_clean)  

# Toggle stopword removal here:
remove_stop <- TRUE
sw <- if (remove_stop) tidytext::stop_words$word else character()

tokens <- d_eda %>%
  unnest_tokens(word, text, token = "words") %>%
  filter(!is.na(word), nchar(word) > 2) %>%
  filter(!str_detect(word, "^[0-9]+$")) %>%
  { if (length(sw)) filter(., !word %in% sw) else . }

top_n <- 20

tfidf_words <- tokens %>%
  count(label, word) %>%
  bind_tf_idf(term = word, document = label, n = n) %>%
  group_by(label) %>%
  slice_max(tf_idf, n = top_n, with_ties = FALSE) %>%
  ungroup() %>%
  mutate(word = tidytext::reorder_within(word, tf_idf, label))

ggplot(tfidf_words, aes(tf_idf, word, fill = label)) +
  geom_col(show.legend = FALSE) +
  facet_wrap(~ label, scales = "free_y") +
  tidytext::scale_y_reordered() +
  labs(title = paste("Top", top_n, "distinctive words by TF-IDF (train set)"),
       x = "TF-IDF", y = NULL) +
  theme_minimal()

4. Modelling

We can see that words are useful! But they can be even more useful We will build a random forest model. We have mostly used the classic randomForest package - but it needs a desne matrix which is heavy on memory. Here we will use ranger, which handles sparse matrices.

# fit
rf_fit <- ranger(
  x = X_tr_tfidf, y = y_train,
  num.trees = 100,
  mtry = max(50, floor(sqrt(ncol(X_tr_tfidf)))),
  min.node.size = 20,
  sample.fraction = 0.6,
  probability = TRUE,
  importance = "none",
  save.memory = TRUE,
  seed = 420
)
## Growing trees.. Progress: 20%. Estimated remaining time: 2 minutes, 4 seconds.
## Growing trees.. Progress: 41%. Estimated remaining time: 1 minute, 32 seconds.
## Growing trees.. Progress: 60%. Estimated remaining time: 1 minute, 4 seconds.
## Growing trees.. Progress: 78%. Estimated remaining time: 36 seconds.
## Growing trees.. Progress: 98%. Estimated remaining time: 3 seconds.
# sanity checks
class(rf_fit)            # should be "ranger"
## [1] "ranger"
str(rf_fit$predictions)  # usually NULL until you call predict()
##  num [1:16000, 1:2] 0.881 0.804 0.605 0.844 0.941 ...
##  - attr(*, "dimnames")=List of 2
##   ..$ : NULL
##   ..$ : chr [1:2] "0" "1"
# --- Make predictions on test ---
pred <- predict(rf_fit, data = X_te_tfidf)

# Grab P(AI=1) safely by column name
pred_prob <- pred$predictions[, colnames(pred$predictions) == "1"]

# Class labels at 0.5 threshold - maybe 0.5 isn't the best threshold?
pred_cls  <- factor(ifelse(pred_prob >= 0.5, "1", "0"), levels = c("0","1"))

# --- Metrics ---
res <- tibble(truth = y_test, .pred_class = pred_cls, .prob_ai = pred_prob)

# Accuracy / Kappa
metrics(res, truth, .pred_class)
## # A tibble: 2 × 3
##   .metric  .estimator .estimate
##   <chr>    <chr>          <dbl>
## 1 accuracy binary         0.982
## 2 kap      binary         0.964
# ROC AUC
roc_auc_vec(res$truth, res$.prob_ai, event_level = "second")
## [1] 0.9975845
# Confusion matrix
conf_mat(res, truth, .pred_class)
##           Truth
## Prediction    0    1
##          0 1986   57
##          1   14 1943

Accuracy is high! We could tyr increasing num.trees or lowering min.node.size but this looks pretty good and these would increase compute.

5. Evaluation

Let’s do some evaluation:

# full metrics
res %>%
  metrics(truth, .pred_class) %>%
  bind_rows(tibble(.metric = "roc_auc", .estimator = "binary",
                   .estimate = roc_auc_vec(res$truth, res$.prob_ai, event_level = "second")))
## # A tibble: 3 × 3
##   .metric  .estimator .estimate
##   <chr>    <chr>          <dbl>
## 1 accuracy binary         0.982
## 2 kap      binary         0.964
## 3 roc_auc  binary         0.998
# Class-specific
precision_vec(res$truth, res$.pred_class, event_level = "second")
## [1] 0.9928462
recall_vec(res$truth,    res$.pred_class, event_level = "second")
## [1] 0.9715
f_meas_vec(res$truth,    res$.pred_class, beta = 1, event_level = "second")
## [1] 0.9820571
# ---- 1) Probabilities for TRAIN and TEST ----
# (make sure your labels are factors with levels c("0","1"))
y_train <- factor(y_train, levels = c("0","1"))
y_test  <- factor(y_test,  levels = c("0","1"))

pred_tr <- predict(rf_fit, data = X_tr_tfidf)$predictions
pred_te <- predict(rf_fit, data = X_te_tfidf)$predictions

p_tr <- pred_tr[, colnames(pred_tr) == "1"]  # P(AI)
p_te <- pred_te[, colnames(pred_te) == "1"]

df_tr <- tibble(dataset = "train", truth = y_train, .prob_ai = p_tr)
df_te <- tibble(dataset = "test",  truth = y_test,  .prob_ai = p_te)

# ---- 2) ROC curve data + AUCs ----
roc_df <- bind_rows(df_tr, df_te) %>%
  group_by(dataset) %>%
  roc_curve(truth, .prob_ai, event_level = "second")

auc_tbl <- bind_rows(df_tr, df_te) %>%
  group_by(dataset) %>%
  roc_auc(truth, .prob_ai, event_level = "second")

print(auc_tbl)  # shows AUC for each dataset
## # A tibble: 2 × 4
##   dataset .metric .estimator .estimate
##   <chr>   <chr>   <chr>          <dbl>
## 1 test    roc_auc binary         0.998
## 2 train   roc_auc binary         1.000
# ---- 3) Plot ----
ggplot(roc_df, aes(x = 1 - specificity, y = sensitivity, colour = dataset)) +
  geom_path(linewidth = 1) +
  geom_abline(linetype = 2) +
  coord_equal() +
  labs(
    title = "ROC: train vs test",
    x = "False Positive Rate (1 - specificity)",
    y = "True Positive Rate (sensitivity)",
    colour = "Dataset"
  ) +
  theme_minimal()

6. Deployment

ACTION: Is the model ready for deployment? Why? Why not?