Text classification in R is fun. While there are many possible approaches this blog post proposes a Keras (with Tensorflow backend) workflow based on vocabulary of lemmatized tokens.

The workflow proposed is particularly advantageous for text in languages other than English, with complicated inflected forms - remember ROMANES EUNT DOMUS scene from the Life of Brian?

The tokenisation and lemmatisation is performed using R package udpipe. The main classification work is done via keras, with light help of caret and with dplyr pipes used to hold everything together.

library(tidyverse) # mainly dplyr
library(udpipe)    # tokenization & lemmatization
library(caret)     # used to split the dataset to train / test
library(keras)     # because Keras :)

As a “problem” to solve I will train my model to determine autorship of Tweet data, using timelines of two popular accounts.

I will be using a dataset of 1000 tweets; half each by Hadley Wickham and Marie Kondo. It contains lots and lots of tidines, and some sparkling with joy.

The dataset was collected with help of rtweet library and can be downloaded by running below quoted code.

It is also necessary to download the udpipe model. I am storing it in tempdir(), but in a real world situation it will make more sense to store it in a permanent place. The models tend to be large.

# directory for source data files
network_path <- 'http://www.jla-data.net/ENG/2019-01-25-vocabulary-based-text-classification_files/'

tf_tweets <- tempfile(fileext = ".csv") # create a temporary csv file
download.file(paste0(network_path, 'tidy_tweets.csv'), tf_tweets, quiet = T)
tweets <- read.csv(tf_tweets, stringsAsFactors = F) # read the tweet data in

# download current udpipe model for English
udtarget <- udpipe_download_model(language = "english",
                                  model_dir = tempdir())
# load the model
udmodel <- udpipe_load_model(file = udtarget$file_model) 

table(tweets$name) # verify structure of downloaded tweets
## 
## hadleywickham    MarieKondo 
##           500           500

The first step is applying the udpipe_annotate() function to the text of tweets. I am storing the id of the tweet as document id, enabling me to join the tweet data to individual words and lemmas later.

words <- udpipe_annotate(udmodel, x = tweets$text, doc_id = tweets$id) %>% 
  as.data.frame() %>%
  select(id = doc_id, token, lemma, upos, sentence_id) %>%
  mutate(id = as.numeric(id))

The second step is construction of vocabulary. It is a simple data frame containg two fields: lemma, and id. It will be used to translate the lemmas to integers, to be fed to the keras model.

vocabulary <- words %>%
  count(lemma) %>%
  ungroup() %>%
  arrange(desc(n)) %>%
  filter(n >= 5) %>% # little prediction value in rarer words
  mutate(id_slovo = row_number()) %>% # unique id per lemma
  select(lemma, id_slovo)

The third part is preparing keras input matrix. It starts as a dataframe (later converted to matrix) with 150 numerical columns, padded with zeroes. I yet have to see a 150 word tweet, so the size has some reserve.

This is a rather complicated pipe, and while it does the work required it looks as a candidate for refactoring (I have a vague feeling that I am not properly using the fill argument of the spread() function).

# 150 zeroes for each tweet id for padding
vata <- expand.grid(id = unique(words$id),
                    word_num = 1:150,
                    id_slovo = 0)

word_matrix <- words %>% # words
  # filtering join! words not in vocabulary are discarded
  inner_join(vocabulary, by = c('lemma' = 'lemma')) %>% 
  select(id, lemma, id_slovo) %>%
  group_by(id) %>%
  mutate(word_num = row_number()) %>% # 
  ungroup() %>%
  select(id, word_num, id_slovo) %>% # relevant columns
  rbind(vata) %>% # bind the 150 zeroes per tweet
  group_by(id, word_num) %>%
  mutate(id_slovo = max(id_slovo)) %>% # will include duplicites
  ungroup() %>%
  unique() %>% # remove duplicites
  spread(word_num, id_slovo) # spread to matrix format

keras_input <- tweets %>%
  select(id, name, text) %>%
  inner_join(word_matrix, by = c('id' = 'id'))

glimpse(keras_input)
## Observations: 994
## Variables: 153
## $ id    <dbl> 1.088785e+18, 1.088785e+18, 1.088629e+18, 1.088616e+18, 1.…
## $ name  <chr> "hadleywickham", "hadleywickham", "hadleywickham", "hadley…
## $ text  <chr> "@mauro_lepore @JennyBryan That’s fine although I don’t lo…
## $ `1`   <dbl> 480, 148, 148, 481, 480, 480, 480, 11, 253, 254, 9, 254, 2…
## $ `2`   <dbl> 9, 9, 9, 9, 11, 92, 11, 70, 9, 9, 9, 9, 226, 4, 14, 11, 12…
## $ `3`   <dbl> 378, 188, 4, 4, 282, 2, 43, 511, 263, 518, 518, 518, 20, 6…
## $ `4`   <dbl> 18, 10, 37, 2, 397, 99, 27, 4, 80, 37, 32, 11, 4, 7, 2, 25…
## $ `5`   <dbl> 2, 18, 19, 6, 16, 40, 2, 100, 18, 4, 4, 2, 143, 239, 6, 25…
## $ `6`   <dbl> 11, 2, 23, 24, 26, 92, 7, 43, 2, 73, 13, 395, 21, 13, 298,…
## $ `7`   <dbl> 20, 36, 171, 11, 3, 2, 12, 46, 416, 95, 143, 185, 0, 4, 62…
## $ `8`   <dbl> 19, 11, 21, 40, 346, 492, 11, 5, 102, 13, 23, 92, 0, 127, …
## $ `9`   <dbl> 86, 43, 0, 15, 143, 99, 511, 22, 5, 3, 11, 2, 0, 21, 11, 2…
## $ `10`  <dbl> 3, 67, 0, 29, 65, 15, 4, 23, 0, 212, 15, 99, 0, 38, 68, 35…
## $ `11`  <dbl> 263, 6, 0, 330, 42, 125, 19, 95, 0, 21, 3, 15, 0, 2, 62, 0…
## $ `12`  <dbl> 101, 2, 0, 27, 41, 27, 6, 34, 0, 0, 433, 125, 0, 491, 3, 0…
## $ `13`  <dbl> 16, 213, 0, 2, 12, 2, 56, 0, 0, 0, 83, 16, 0, 8, 150, 0, 1…
## $ `14`  <dbl> 2, 32, 0, 320, 42, 7, 16, 0, 0, 0, 280, 2, 0, 0, 298, 0, 7…
## $ `15`  <dbl> 19, 37, 0, 0, 143, 102, 510, 0, 0, 0, 0, 151, 0, 0, 10, 0,…
## $ `16`  <dbl> 7, 100, 0, 0, 485, 300, 14, 0, 0, 0, 0, 14, 0, 0, 40, 0, 1…
## $ `17`  <dbl> 0, 56, 0, 0, 42, 5, 72, 0, 0, 0, 0, 38, 0, 0, 22, 0, 7, 0,…
## $ `18`  <dbl> 0, 3, 0, 0, 41, 4, 0, 0, 0, 0, 0, 19, 0, 0, 200, 0, 383, 0…
## $ `19`  <dbl> 0, 209, 0, 0, 41, 2, 0, 0, 0, 0, 0, 6, 0, 0, 554, 0, 24, 0…
## $ `20`  <dbl> 0, 21, 0, 0, 25, 151, 0, 0, 0, 0, 0, 2, 0, 0, 6, 0, 7, 0, …
## $ `21`  <dbl> 0, 0, 0, 0, 16, 145, 0, 0, 0, 0, 0, 15, 0, 0, 68, 0, 383, …
## $ `22`  <dbl> 0, 0, 0, 0, 66, 103, 0, 0, 0, 0, 0, 7, 0, 0, 166, 0, 152, …
## $ `23`  <dbl> 0, 0, 0, 0, 7, 47, 0, 0, 0, 0, 0, 143, 0, 0, 15, 0, 7, 0, …
## $ `24`  <dbl> 0, 0, 0, 0, 102, 6, 0, 0, 0, 0, 0, 0, 0, 0, 503, 0, 10, 0,…
## $ `25`  <dbl> 0, 0, 0, 0, 300, 397, 0, 0, 0, 0, 0, 0, 0, 0, 5, 0, 0, 0, …
## $ `26`  <dbl> 0, 0, 0, 0, 40, 84, 0, 0, 0, 0, 0, 0, 0, 0, 11, 0, 0, 0, 0…
## $ `27`  <dbl> 0, 0, 0, 0, 4, 131, 0, 0, 0, 0, 0, 0, 0, 0, 56, 0, 0, 0, 0…
## $ `28`  <dbl> 0, 0, 0, 0, 427, 7, 0, 0, 0, 0, 0, 0, 0, 0, 242, 0, 0, 0, …
## $ `29`  <dbl> 0, 0, 0, 0, 7, 143, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,…
## $ `30`  <dbl> 0, 0, 0, 0, 13, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ `31`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `32`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `33`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `34`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `35`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `36`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `37`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `38`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `39`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `40`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `41`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `42`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `43`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `44`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `45`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `46`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `47`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `48`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `49`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `50`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `51`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `52`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `53`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `54`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `55`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `56`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `57`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `58`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `59`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `60`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `61`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `62`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `63`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `64`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `65`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `66`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `67`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `68`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `69`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `70`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `71`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `72`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `73`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `74`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `75`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `76`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `77`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `78`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `79`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `80`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `81`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `82`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `83`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `84`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `85`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `86`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `87`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `88`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `89`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `90`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `91`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `92`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `93`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `94`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `95`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `96`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `97`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `98`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `99`  <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `100` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `101` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `102` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `103` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `104` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `105` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `106` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `107` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `108` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `109` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `110` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `111` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `112` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `113` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `114` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `115` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `116` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `117` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `118` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `119` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `120` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `121` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `122` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `123` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `124` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `125` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `126` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `127` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `128` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `129` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `130` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `131` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `132` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `133` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `134` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `135` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `136` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `137` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `138` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `139` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `140` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `141` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `142` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `143` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `144` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `145` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `146` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `147` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `148` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `149` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ `150` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…

Once the full keras input is prepared I split it into training and testing parts.

set.seed(42) # Zaphod Beeblebrox advises to trust no other!

idx <- createDataPartition(keras_input$name, p = .8, list = F, times = 1) # 80 / 20 split

train_data <- keras_input[idx, ] # train dataset
test_data <- keras_input[-idx, ] # verification

With the training dataset ready a couple technical steps are necessary: converting the categorical field of author to a number, and conveting the whole input to a numerical matrix. The vocabulary size variable will be used to size keras input.

train_data <- train_data %>%
  mutate(hadley = ifelse(name == 'hadleywickham', 1,0)) %>% # binary output
  select(-id, -name, -text)

x_train <- data.matrix(train_data %>% select(-hadley)) # everything except target
y_train <- data.matrix(train_data %>% select(hadley)) # target, and target only

vocab_size <- vocabulary %>% # count unique word ids
  pull(id_slovo) %>% 
  unique() %>%
  length() + 1 # one extra for the zero padding

Once all the inputs are ready I define & train my model.

The model uses an embedding layer of the size of the vocabulary, and one bidirectional LSTM layer. As the LSTM’s are notoriously prone to overfitting a dropout layer is necessary.

The final layer is a single output node, representing the probability of a particular tweet being Hadley’s.

model <- keras_model_sequential() 

model %>% 
  layer_embedding(input_dim = vocab_size, output_dim = 256) %>%
  bidirectional(layer_lstm(units = 128)) %>%
  layer_dropout(rate = 0.5) %>% 
  layer_dense(units = 1, activation = 'sigmoid') # 1 = Hadley, 0 = Marie

model %>% 
  compile(optimizer = "rmsprop",
          loss = "binary_crossentropy",
          metrics = c("accuracy"))

history <- model %>%  # fit the model (this will take a while...)
  fit(x_train, 
      y_train, 
      epochs = 25, 
      batch_size = nrow(train_data)/5, 
      validation_split = 1/5)

summary(model)
## ___________________________________________________________________________
## Layer (type)                     Output Shape                  Param #     
## ===========================================================================
## embedding_1 (Embedding)          (None, None, 256)             146432      
## ___________________________________________________________________________
## bidirectional_1 (Bidirectional)  (None, 256)                   394240      
## ___________________________________________________________________________
## dropout_1 (Dropout)              (None, 256)                   0           
## ___________________________________________________________________________
## dense_1 (Dense)                  (None, 1)                     257         
## ===========================================================================
## Total params: 540,929
## Trainable params: 540,929
## Non-trainable params: 0
## ___________________________________________________________________________

With the model trained I verify its effectiveness on the testing dataset, using the same pre-processing as for the training data.

pred_data <- test_data %>% # expected results
  select(id, name, text)

test_data <- test_data %>%
  mutate(hadley = ifelse(name == 'hadleywickham', 1,0)) %>% # binary output
  select(-id, -name, -text) # no cheating!

x_pred <- data.matrix(test_data %>% select(-hadley)) # keras needs matrix

pred <- model %>% # let keras sweat...
  predict_proba(x_pred)

verifikace <- pred_data %>% # correct results ...
  cbind(pred) # ... joined with predictions

verifikace <- verifikace %>%
  mutate(name_pred = ifelse(pred > 0.5, 'hadleywickham', 'MarieKondo'))

conf_mtx <- table(verifikace$name, verifikace$name_pred)

print(paste0('Correctly predicted ',
             sum(diag(conf_mtx)), ' of ',
             sum(conf_mtx), ' tweets, which means ', 
             round(100 * sum(diag(conf_mtx))/sum(conf_mtx), 2), 
             '% of the total.'))
## [1] "Correctly predicted 184 of 198 tweets, which means 92.93% of the total."

Having accurary over 90% in a toy example such as this is not bad :)

It can be further improved in a number of ways - the two most obvious are including more training data (500 tweets is not that many), or adding more layers to create a more complicated model.