Hoax News
2023 — A model that flags whether a news article is fake
01 Problem
A fake story spreads faster than the correction that follows it. A platform or a newsroom cannot fact-check every article that goes viral, so it needs a way to put the most suspicious ones in front of its checkers first.
The goal is a classifier that reads the title and text of a news article and tells whether it is fake.
02 Cleaning
The Kaggle Fake and Real News dataset holds 44,898 articles. Dropping exact duplicates leaves 44,689, but the same fake story was often posted again under a different subject, so once only the title and text are kept, 5,584 more copies appear.
They are removed too, leaving 39,105 unique articles, 17,908 of them fake. A story that sits in both the training and the test data would grade the model on something it has already read.
fake <- fake %>% distinct()
real <- real %>% distinct()
news <- news %>%
mutate(text = paste(title, text)) %>%
select(is_fake, text)
news <- news %>% distinct()03 Fingerprints
The two halves of the dataset come from different places, and it shows. 99% of real articles open with a Reuters dateline such as "WASHINGTON (Reuters) -", against 0% of fake ones.
The scrapers left marks too. 63% of fake titles carry curly quotes or other characters outside plain ASCII, against 0% of real ones, and the reverse holds for the article text. A model fed either signal would learn who published a story instead of whether it is true, so the dateline and every non-ASCII character are removed before training.
news <- news %>%
mutate(text = sub("^.*?\\(Reuters\\) - ", "", text, perl = TRUE))
news <- news %>%
mutate(title = gsub("[^\\x01-\\x7F]", "", title, perl = TRUE),
text = gsub("[^\\x01-\\x7F]", "", text, perl = TRUE))04 Timeline
Fake articles run from March 2015, while real ones only start in January 2016 and outnumber fake news every month from September 2017.
The two kinds were collected over different periods, so the publication date would give the answer away. The model only ever reads the title and text.
fake_viz_monthly_df <- read.csv("datasets/Fake.csv") %>%
select(date) %>%
mutate(date = mdy(date),
year = year(date),
month = month(date, label = T, abbr = F)) %>%
filter(complete.cases(.)) %>%
group_by(month, year) %>%
summarise(monthly_fake_news = n())05 Text
Every article is lowercased and stripped of numbers, stopwords, and punctuation, and every word is cut down to its stem, so "elected" and "elections" count as one term.
The 39,105 articles turn into a document-term matrix of 150,918 distinct terms.
cleaned_text_corpus <- cleanText(news$text, lang = "en", as.corpus = T)
text_dtm <- DocumentTermMatrix(cleaned_text_corpus)06 Vocabulary
The articles are split 80/20, stratified by label, into 31,285 for training and 7,820 for testing.
Only then is the vocabulary cut down, keeping a term only if it appears at least 150 times in the training articles, which leaves 4,537. Counting over every article would let the test set choose which words the model gets to see.
set.seed(1)
indices <- createDataPartition(news$is_fake,
p = 0.8,
list = FALSE)
frequent_terms <- findFreqTerms(x = text_dtm[indices, ], lowfreq = 150)
text_dtm <- text_dtm[, frequent_terms]07 Naive Bayes
Each kept term becomes a yes-or-no flag for whether the article uses it. Naive Bayes learns how often each term shows up in fake and in real news, and combines the evidence of every term an article contains.
Because it weighs every term on its own, it stays cheap with thousands of features. Laplace smoothing gives every term a small chance in both classes, so a single unseen term cannot rule an article out.
text_dtm_bn <- apply(X = text_dtm, FUN = toBernoulli, MARGIN = 2)
X_train <- text_dtm_bn[indices, ]
y_train <- news[indices, "is_fake"]
model_nb <- naiveBayes(x = X_train,
y = y_train,
laplace = 1)08 Evaluation
On the 7,820 test articles the model is 95% accurate. It catches 3,369 of the 3,581 fake articles, a sensitivity of 94%, and wrongly flags 169 of the 4,239 real ones.
For a fact-checking team, the fakes it misses matter most, because a missed fake keeps spreading, while a false alarm only costs a checker one more read.
pred_nb <- predict(model_nb, X_test, type = "class")
confusionMatrix(pred_nb, y_test, positive = "1")09 ROC
The AUC of 0.984 is the probability that the model ranks a random fake article above a random real one. That ranking is the queue a fact-checking team works from, with the most suspicious stories first and as far down the list as there is time.
pred_nb_raw <- predict(model_nb, X_test, type = "raw")
roc_nb <- pROC::roc(response = y_test,
predictor = pred_nb_raw[, "1"],
levels = c("0", "1"),
direction = "<")
pROC::auc(roc_nb)10 Signals
The terms that give fake news away are photo credits and sign-offs. The term Getty, from Getty Images photo credits, shows up 516 times more often in fake news than in real news, followed by Flickr, 21st Century Wire, and Wikimedia, and by censored swearing. Real news gives itself away with Reuters factboxes and world stories the fake sites ignore, such as the Rohingya crisis in Myanmar.
So the model has learned how these particular sites write more than which claims are false. It is a strong first filter for sources like these, not a judge of truth.
term_odds <- data.frame(term = names(model_nb$tables),
fake = sapply(model_nb$tables, function(table) table["1", "1"]),
real = sapply(model_nb$tables, function(table) table["0", "1"]),
row.names = NULL) %>%
mutate(odds = fake / real)
term_odds %>% arrange(desc(odds)) %>% head(10)Hoax News
Catches 94% of fake news — AUC 0.98