Data Science Capstone Notebook Text Prediction App Quanteda DT.Rmd

---
title: "Data Science Capstone Report"
author: "Codrin Kruijne"
date: "10/06/2018"
output:
  html_document:
    df_print: paged
---

## Exploring word prediction from language models
### Coursera Data Science Specialization Capstone project

The goal of the capstone proejct is to create a Shiny Web app that provides predicive text suggestion for a number of typed words.

###  Technologies used

I have explored the use of the TM and TidyText packages. However, I settled on the combination below for performance and simplicity reasons. Please note the code has been written for making a language model and web app work in this course context. The goal was more to show that I can apply a number of techniques and skills in one object, than to become an NLP expert. For more elaborate NLP it most certainly but a first step.

```{r Load Packages, message=FALSE, warning=TRUE}

require(readr) # for reading in text to build model on

require(tidyr) # for table and string manipulation
require(dplyr)
require(stringr)

require(ggplot2) # for plotting text features
require(gridExtra)

require(microbenchmark) # for comparing function performance
require(parallel) # for parallel processing

require(tidytext) # for data source characteristics
require(qdap) # for text preparation
require(quanteda) # for text tokenization

require(data.table) # for fast table calculation and lookup

```

## Training data

Three files were provided with a selection of tweets, news items and blog entries.

### Reading and cleaning data

```{r Obtaining data, cache=TRUE}

twitter_txt <- read_lines("en_US.twitter.txt") # read in tweets
news_txt <- read_lines("en_US.news.txt") # read in news items
blogs_txt <- read_lines("en_US.blogs.txt") # read in blog entries

# Lets explore this data

descriptives <- list() # create a list of descriptives to save for app

## Before anything profanity filtering of data provided
profanity_data <- readLines("https://raw.githubusercontent.com/LDNOOBW/List-of-Dirty-Naughty-Obscene-and-Otherwise-Bad-Words/master/en")

cl0 <- makeCluster(10)

# How much profanity?

descriptives$prof <- parSapply(cl0, list("Twitter profanity" = twitter_txt, "News profanity" = news_txt, "Blogs profanity" = blogs_txt), FUN = "str_count", pattern = paste(profanity_data, collapse = "|"))
descriptives$prof <- lapply(descriptives$prof, sum)

# Remove profanity

clean_txt <- parSapply(cl0, list(twitter_txt, news_txt, blogs_txt), FUN = "str_remove_all", pattern = paste(profanity_data, collapse = "|"))

stopCluster(cl0)

twitter_txt <- clean_txt[[1]]
news_txt <- clean_txt[[2]]
blogs_txt <- clean_txt[[3]]

source("data_descriptives.R")

```

## Preprocessing: cleaning sources

```{r cache=TRUE}

### Using QDAP functions for some initial cleaning and replacing

# A function for QDAP cleaning

clean_qdap <- function(sample_text){
  
  # Replace Abbreviations
  sample_text <- qdap::replace_ordinal(sample_text)
  
  # Replace Numbers With Text Representation
  sample_text <- qdap::replace_number(sample_text, remove = TRUE)
  
  # Replace Abbreviations
  sample_text <- qdap::replace_abbreviation(sample_text)
  
  # Replace Contractions
  sample_text <- qdap::replace_contraction(sample_text)
  
  # Replace Symbols With Word Equivalents
  sample_text <- qdap::replace_symbol(sample_text, # except for # and @
                                      pound = FALSE, # as we have twitter
                                      at = FALSE) # texts to process later
  
  # Remove dashes and brackets
  sample_text <- qdap::qprep(sample_text)
  
  # Remove underscores and apostrophe letters
  sample_text <- stringr::str_remove_all(sample_text,
                                         pattern = "\\'s | \\_")
  
  # Ensure spaces for better tokenization
  sample_text <- qdap::comma_spacer(sample_text)
  
  sample_text # returne cleaned text
}

# Apply QDAP cleaning parallel

cl <- makeCluster(10)

print("Total time for QDAP cleaning")
system.time(clean_samples <- parLapply(cl, list(twitter_txt, news_txt, blogs_txt), clean_qdap))

stopCluster(cl)

# Extract parallel computing results

clean_twitter <- clean_samples[[1]]
clean_news <- clean_samples[[2]]
clean_blogs <- clean_samples[[3]]

saveRDS(clean_twitter, file = "clean_twitter.rds")
saveRDS(clean_news, file = "clean_news.rds")
saveRDS(clean_blogs, file = "clean_blogs.rds")

# Clean up
rm(twitter_txt)
rm(news_txt)
rm(blogs_txt)

```

### Merging source and extracting training, hold-out and testing samples

```{r message=FALSE, warning=FALSE, cache=TRUE}

# Merging into one collection

clean_twitter <- readRDS("clean_twitter.rds")
clean_news <- readRDS("clean_news.rds")
clean_blogs <- readRDS("clean_blogs.rds")

collection_txt <- c(clean_twitter, clean_news, clean_blogs) # combine into one collection
rm(list = c("clean_twitter", "clean_news", "clean_blogs")) # remove separate source objects

print("Size of character vector with all collection elements:")
format(object.size(collection_txt), units = "auto")
print("NUmber of character elements:")
length(collection_txt)

# Creating training set, hold out set and testing set

train_frac <- 0.8 # Percentage of training set
all_ind <- 1: length(collection_txt) # creating all indecis
train_ind <- sample(all_ind, size = train_frac * length(all_ind)) # training indeces
rest_ind <- all_ind[-train_ind] # remaining indeces to be separated
hold_ind <- sample(rest_ind, size = 0.5 * length(rest_ind)) # half hold out set
test_ind <- all_ind[-c(train_ind, hold_ind)] # hals test set

train <- collection_txt[train_ind] # create training set
hold <- collection_txt[hold_ind] # create hold out set
test <- collection_txt[test_ind] # create testing set

print(paste("Training set elements: ", length(train)))
print(paste("Hold out set elements: ", length(hold)))
print(paste("Training set elements: ", length(test)))

# Clean up
rm(collection_txt)
rm(train_frac)
rm(all_ind)
rm(train_ind)
rm(rest_ind)
rm(hold_ind)
rm(test_ind)

```

# Preprocessing: tokenizing

```{r cache=TRUE}

### Quanteda functions combining to tokenize and further preprocess
quanteda_options(threads = 10) # using parallell processing; adjust for available CPU!

# First, we tokenize to sentences, so that later bigrams are not created across sentences
to_sentences <- function(sample) {
  unlist(tokens(char_tolower(sample), what = "sentence", verbose = TRUE))
}

# Extract sentences
print("Time to extract sentences out of training set:")
system.time(train_sentences <- to_sentences(train))

# A function to preprocess and tokenize to words

preprocess <- function(sample) {
  
  toks <- tokens(sample, # all lowercases
                 what = "word", # tokenize to words
                 remove_numbers = TRUE, # remove numbers
                 remove_punct = TRUE, # remove (unicode) punctuation
                 remove_symbols = TRUE, # remove (unicode) symbols
                 remove_separators = TRUE, # remove (unicode) separators 
                 remove_twitter = TRUE, # remove Twitter like @ and #
                 remove_hyphens = TRUE, # remove hyphens
                 remove_url = TRUE, # remove URLs
                 verbose = TRUE)
  
  # Additional manual preprocessing
  
  toks <- tokens_remove(toks, 
                        case_insensitive = TRUE,
                        c("(<U\\+\\w{4}>[:alnum:]*)+", # unicode
                          "RT", # retweet abbreviation
                          "DM", # direct message abbreviation
                          "[\\;\\:]\\?\\-?[\\(\\)pPD\\\\\\/\\|]", # smileys
                          "\\<3", # 'love'
                          "lol", # lol
                          "a\\.m\\.", # time abbreviations
                          "p\\.m\\.",
                          "\\d+\\:\\d+",
                          "[:digit:]{1,2}[ap]m",
                          "(.)\\1{3,}"), # remove any character repeated
                        valuetype = "regex",
                        verbose = TRUE)

  toks # return cleaned tokens
  
}

# Clean and tokenize training set
print("Time to preprocess training set:")
train_tokens <- preprocess(train_sentences)

# Save preprocessed training data
saveRDS(train_tokens, file = "train_tokens.rds")

# Clean up
rm(train)
rm(train_sentences)
rm(train_tokens)

```

## Ngram language modeling

We did language modeling with ngrams. Bi-/tri-/four-/fivegrams were extracted. N-gram relative frequencies were obtained by calculating the frequency of the ngram divided by the count of the base. 

```{r cache=TRUE}

# Extracting ngrams for training. This code seems somewhat unelegantly repetivite, but it allows for flexible changes and avoids memory problems related to using lists and lapply e.g. We use Quanteda functions below which can make use of 10 threads (on my mahcine!)

extract_ngrams <- function(sentence_tokens, ngram_size){
  
  sentence_ngrams <- tokens_ngrams(sentence_tokens,
                                   n = ngram_size,
                                   concatenator = " ")
  
  dt <- data.table(ngram = unlist(sentence_ngrams))
  
}

# For easy calculation we split the ngrams into single word columns for which we use this function

split_ngrams <- function(ngrams_dt, n){
  
  base_parts <- c("base_five",
                  "base_four",
                  "base_tri",
                  "base_bi")
  base_start <- 6 - n
  base_end <- n - 1
  ngrams_dt <- ngrams_dt %>%
                  separate(ngram,
                           into = c(base_parts[base_start:4],
                                    "follow"),
                           sep = " ",
                           fill = "left") %>%
                  unite(1:base_end, col = "base", sep = " ")
  
}

# A function for calculating Maximum Likelihood Estimations with optional add-k smoothing

mle_calculator <- function(split_ngram, smoother, voc_size) {

  k <- smoother # code was prepared for add-k smoothing
  V <- voc_size # but doing more research this does not seem to perform well
  
             # count base frequency to normalise
  dt <- split_ngram[, .(follow, base_ct = .N), by = .(base) 
               # count ngram frequency
              ][, .(base_ct, ngram_ct = .N), by = .(base, follow) 
                 # calculate the smoothed MLE
                ][ngram_ct > 3    # prune rarest observations
                  ][, .(base,
                        follow,
                        base_ct,
                        ngram_ct,
                        mle = (ngram_ct + k) / (base_ct + (k * V)))]
  
  unique(dt[!is.na(follow)]) # after counting return unique, not na rows
  
}

```

## Ngram model creation

```{r}

ngram_model <- function(toks, name = "bigram", size = 2, smoother = 1, voc_size){
  
  # Extracting ngrams
  
  ngrams_dt <- extract_ngrams(toks, size)
  str(ngrams_dt)
  
  # Splitting ngrams
  
  split_dt <- split_ngrams(ngrams_dt, size)
  str(split_dt)
  rm(ngrams_dt)
  
  # MLE ngram calculation
  
  ngram_mle <- mle_calculator(split_dt, smoother, voc_size)
  rm(split_dt)

  # Save to disk
  saveRDS(ngram_mle, file = paste0(name, "_mle.rds")) 
  
  # Succesful MLE calculation? Clean up!
  gc(verbose = TRUE)
  
  print(paste("Time to generate", name, "model on training set:"))
}

# Load tokens
train_tokens <- readRDS("train_tokens.rds")

# Calculating vocabulary size for smoothing
train_V <- length(unique(unlist(train_tokens)))

# Bigram model creation
system.time(ngram_model(train_tokens, "bigram", 2, smoother = 1, voc_size = train_V))

# Trigram model creation
system.time(ngram_model(train_tokens, "trigram", 3, smoother = 1, voc_size = train_V))

# Fourgram model creation
system.time(ngram_model(train_tokens, "fourgram", 4, smoother = 1, voc_size = train_V))

# Fivegram model creation
system.time(ngram_model(train_tokens, "fivegram", 5, smoother = 1, voc_size = train_V))

# Clean up
# rm(train_tokens)
# gc()

```

## Creating lookup tables for App

```{r cache=TRUE}

# Now lets create a lookup table from the raw bigram probabilities

ngram_probs <- function(ngram_mle) {

  dt <- data.table(ngram_mle) # select relevant columns and unique rows
  dt <- unique(dt[, .(mle), by = .(base, follow)])
  dt[order(-mle), .(follow, mle), by = base # order by mle
     ][order(-mle), .SD[1:10], by = base] # top 10
}

# Format and shorten lookup tables

system.time(bigram_lookup <- ngram_probs(readRDS("bigram_mle.rds")))
system.time(trigram_lookup <- ngram_probs(readRDS("trigram_mle.rds")))
system.time(fourgram_lookup <- ngram_probs(readRDS("fourgram_mle.rds")))
system.time(fivegram_lookup <- ngram_probs(readRDS("fivegram_mle.rds")))

# Write lookup tables to app

saveRDS(bigram_lookup, file = "WordPredictor/data/bigram_lookup.rds")
saveRDS(trigram_lookup, file = "WordPredictor/data/trigram_lookup.rds")
saveRDS(fourgram_lookup, file = "WordPredictor/data/fourgram_lookup.rds")
saveRDS(fivegram_lookup, file = "WordPredictor/data/fivegram_lookup.rds")

```

## Model evaluation: Perplexity and Accuracy

The best evaluation method is in-vivo evaluation, but perplexity is a standard alternative applied on a separate test set.

```{r cache=TRUE}

# Perplexity is a simple way to evaluate ngram models. It is basically the product of MLEs counted on the training set, applied to the test set.

# Extract sentences from test set

print("Time to extract sentences out of testing set:")
system.time(test_sentences <- to_sentences(test))

# Clean and tokenize test set in same as when modeling

print("Time to preprocess testing set:")
test_tokens <- preprocess(test_sentences)
rm(test_sentences)

# Calculating vocabulary size for perplexity calculation
print("Time to calculate vocabulary size testing set")
system.time(test_V <- length(unique(unlist(test_tokens))))

# A function to test an ngram model on testing set

test_model <- function(test_toks, name = "bigram", size = 2, voc_size){
  
  # Extract ngrams
  ngrams_dt <- extract_ngrams(test_toks, size)
  str(ngrams_dt)
  
  # Split ngrams
  split_dt <- split_ngrams(ngrams_dt, size)
  str(split_dt)
  saveRDS(split_dt, file = paste0("test_", name, "s.rds"))
  rm(ngrams_dt)
  
  # Read in model MLE
  file_name <- paste0(name, "_mle.rds")
  print(paste("Reading file", file_name))
  model_mle <- readRDS(file_name)
  
  # Apply model test set
  dt <- data.table(left_join(split_dt,
                             model_mle[, c("base", "follow", "mle")]))
  head(dt)
  tail(dt)
  
  # Return model perplexity
  print(paste(name, "model on testing set perplexity:"))
  print(sum(log(1/dt[, mle]), na.rm = TRUE)^1/voc_size)

}

# Test models
test_bi_PP <- test_model(test_tokens, "bigram", 2, test_V)
gc()
test_tri_PP <- test_model(test_tokens, "trigram", 3, test_V)
gc()
test_four_PP <- test_model(test_tokens, "fourgram", 4, test_V)
gc()
system.time(test_five_PP <- test_model(test_tokens, "fivegram", 5, test_V))
gc()

# Save model results
test_results <- data.frame(model = c("Bigram", "Trigram", "Fourgram", "Fivegram"), perplexity = c(test_bi_PP, test_tri_PP, test_four_PP, test_five_PP))

saveRDS(test_results, file = "WordPredictor/data/model_perplexities.rds")

### accuracy at the first word, second word, and third word

# Source the wordPredictor function that is shared between model evaluator and Shiny App
source("WordPredictor/wordPredictorFunction.R")

# lets create a datatable with all ngrams from the testing set with three columns: base, following and ngram type

test_bigrams <- readRDS("test_bigrams.rds")
colnames(test_bigrams)[2] <- "test"
test_trigrams <- readRDS("test_trigrams.rds")
colnames(test_trigrams)[2] <- "test"
test_fourgrams <- readRDS("test_fourgrams.rds")
colnames(test_fourgrams)[2] <- "test"
test_fivegrams <- readRDS("test_fivegrams.rds")
colnames(test_fivegrams)[2] <- "test"

# test_ngrams <- rbindlist(list(test_bigrams,
#                               test_trigrams,
#                               test_fourgrams,
#                               test_fivegrams), idcol = "model")
# 
# test_ngrams[, model := model + 1]
# str(test_ngrams)

# for each case apply the appropriate model and save three first three results

train_bigram_top <- readRDS("WordPredictor/data/bigram_lookup.rds")[order(-mle), .SD[1:3], by = base]
colnames(train_bigram_top)[2] <- "prediction"
train_trigram_top <- readRDS("WordPredictor/data/trigram_lookup.rds")[order(-mle), .SD[1:3], by = base]
colnames(train_trigram_top)[2] <- "prediction"
train_fourgram_top <- readRDS("WordPredictor/data/fourgram_lookup.rds")[order(-mle), .SD[1:3], by = base]
colnames(train_fourgram_top)[2] <- "prediction"
train_fivegram_top <- readRDS("WordPredictor/data/fivegram_lookup.rds")[order(-mle), .SD[1:3], by = base]
colnames(train_fivegram_top)[2] <- "prediction"



# count how many times the prediction results from the models match the actual following word in the test set



```

## Technologies used

* Model building
To improve processing time of the training code and responsiveness of the app
+ [Tidy Text Mining](https://www.tidytextmining.com) was used to explore simple processing
+ [QDAP](https://trinker.github.io/qdap/) was used for text cleaning
+ [Qanteda package](http://quanteda.io) was used for corpus creation, preprocessing and ngram extraction
+ [Tidyverse packages](https://www.tidyverse.org/) were used for simple ngram rearranging into base word(s) and final word
+ [data.table package](http://r-datatable.com) was used for fast counting of frequencies and calculating MLEs
+ [Parallel package](http://stat.ethz.ch/R-manual/R-devel/library/parallel/doc/parallel.pdf) was used to run several functions in parallel to speed up processing