Detecting Deceptive Hotel Reviews using Machine Learning

Initialize and load libraries

################################################################################
### Initialize environment
################################################################################
rm(list=ls())
library(tidyverse)
library(gridExtra) #viewing multiple plots together

 # Text Mining Packages
library(tidytext)
library(tokenizers)
library(wordcloud2) #creative visualizations
library(spacyr)
spacy_initialize()

# Graphics Packages
library(ggthemes)
library(moments)
library(ggplot2)
library(scales)
library(knitr) # for dynamic reporting
library(kableExtra) # create a nicely formated HTML table
library(formattable) # for the color_tile function

publication_theme <- function() {
    theme_economist() +
    theme(text=element_text(family="Rockwell"),
          plot.title = element_text(family="Rockwell", size=12)
    )
}
publication.color.background <- '#d6e4ea'
publication.color.orange <- '#f0716f'
publication.color.cyan <- '#3cbfc2'

Project_Dir <- "/Users/amkhosla/Desktop/Statistics/Projects/Hotel_Reviews/code"
setwd(Project_Dir)

Read and label the hotel reviews

Once all the programming libraries and environment have been loaded, we need to read in the reviews (one per file) and label them as truthful or deceptive. Here’s a look at some randomly sampled reviews from the dataset of 1600 reviews. I’ve hidden whether or not they are truthful or deceptive. You guess.

training_path = '../input/op_spam_train'
doc_id <- list.files(path=training_path, pattern="*.txt", full.names=TRUE, recursive=TRUE)
if (length(doc_id) != 1600) { 
   stop (paste("Couldn't locate input training files at:",  
                print(getwd()), print(training_path)))
}
training.df <- as.tibble(as.data.frame(doc_id, 
                                       col.names = c("Training_File"),
                                       stringsAsFactors = FALSE))

Check your guesses below. How did you do? Better than 50% accuracy?

kable(training.df[random_records,c(2,3,4)], format = "markdown")

Now comes the first analysis of the text. The first thing to examine in any textual analysis is the so called bag-of-words model. We break up the reviews into a set of words, and then we analyze those single words.

cleanup_review <- function(aReviewStr) {
    the_cleansed_string <- aReviewStr
    the_cleansed_string <- gsub("[^a-zA-Z0-9 ]", " ", the_cleansed_string)
    theTokens <- tokenize_words(the_cleansed_string, stopwords = stopwords::stopwords("en"))[[1]]
    theLongerTokens  <- theTokens[sapply(theTokens, function(aToken) (nchar(aToken) > 3))]
    the_cleansed_string <- paste(theLongerTokens, collapse = " ")
    return(the_cleansed_string)
}
training.df$Filtered_Reviews <- sapply(training.df$Hotel_Reviews, cleanup_review)

tokenized_unigram.df <- training.df %>% 
    unnest_tokens(word, Filtered_Reviews) %>%
    distinct() 

tokenized_bigram.df <- training.df %>% 
    unnest_tokens(ngram, Filtered_Reviews, token = "ngrams", n = 2, collapse=FALSE) # %>%

Preliminary distributions

Zipf’s law says that the more common a word is the shorter it is. It also says that the frequency of that word has a “Zipfian” distribution - common words (typically the top 2000-3000 words in any language) have a very high occurence/probability, and then the rest rapidly drop off. As a quick sanity check of the data, let’s see if the reviews have a “Zipfian” distribution.

word_frequency <- tokenized_unigram.df %>%
    dplyr::count(word, sort = TRUE) 
freq_range = 1:1000
barplot(word_frequency$n[freq_range])

Looks Zipfian!

Deceptive words vs truthful words

Let’s plot the probability that words show up in reviews, by whether they show up in truthful, or deceptive reviews, or both.

word_distribution <- as.tibble(count(tokenized_unigram.df, word, Truthfulness, sort = TRUE))
tidy_word_distribution <- spread(word_distribution, Truthfulness, n) 
tidy_word_distribution <- tidy_word_distribution %>% 
    replace_na(list(deceptive = 0, truthful = 0)) %>% 
    mutate(deceptive_proportion = deceptive / sum(deceptive))  %>%
    mutate(truth_proportion = truthful / sum(truthful))

deceptive_words_only <- tidy_word_distribution %>%
    filter(truth_proportion == 0) %>%
    filter(deceptive > 2) %>%
    mutate(word = reorder(word, deceptive))   #Reorders word into a factor, based on n....
deceptive.barplot <- ggplot(deceptive_words_only, aes(word, deceptive)) +
        geom_col() +
        xlab(NULL) +
        coord_flip() +
        labs(title = "Words that appear ONLY in deceptive reviews") +
        publication_theme()
deceptive.barplot

true_words_only <- tidy_word_distribution %>%
    filter(deceptive_proportion == 0) %>%
    filter(truthful > 2) %>%
    mutate(word = reorder(word, truthful)) #Reorders word into a factor, based on n....
true.barplot <- ggplot(true_words_only, aes(word, truthful)) +
        geom_col() +
        xlab(NULL) +
        coord_flip() +
        labs(title = "Words that appear ONLY in  truthful reviews") +
        publication_theme()
true.barplot

# Remove words that occur only on axes from the plot
plot_word_distribution <- tidy_word_distribution %>%
    filter((truth_proportion > 0) & (deceptive_proportion > 0))

word_distribution.plot <- ggplot(plot_word_distribution, 
       aes(x = deceptive_proportion, y = truth_proportion )) +
    geom_abline(color = "gray40", lty = 2) +
    geom_jitter(color = publication.color.orange, alpha = 0.3, size = 2., width = 0.2, height = 0.2) +
    geom_text(aes(label = word), check_overlap = TRUE, size = 3, fontface = "bold", vjust = 1.5) +
    scale_x_log10(labels = percent_format()) +
    scale_y_log10(labels = percent_format()) +
    theme(legend.position="none") +
    labs(x = "% Deceptive (log scale)", y = "% Truthful (log scale)") +
    publication_theme()
word_distribution.plot

Testing spacyr - an open-source Parts-of_Speech (POS) tagger

Several open-source parts-of-speech (POS) taggers are available. I’m using spacyr. Trained using a neural net, this POS tagger has a 92% accuracy, and is a (relatively) fast classifier - important considering the amount of data being mined. As an example of its use, let’s parse a joke:

A Texan, a Russian and a New Yorker go to a restaurant in London.
The waiter tells them, “Excuse me – if you were going to order the steak, I’m afraid there’s a shortage due to the mad cow disease.”

The Texan says, “What’s a shortage?”
The Russian says, “What’s a steak?”
The New Yorker says, “What’s ‘excuse me’?”

txt <- c(line1 = "A Texan, a Russian and a New Yorker go to a restaurant in London.",
         line2 = "The waiter tells them, Excuse me -- if you were going to order the steak, I'm afraid there's a shortage due to the mad cow disease.",
         line3 = "The Texan says, What's a shortage?",
         line4 = "The Russian says, What's a steak?",
         line4 = "The New Yorker says, What's 'excuse me?")

# process documents and obtain a data.table
parsedtxt <- spacy_parse(txt)
parsedtxt$sentence_id <- NULL
# Show label and review
kable(parsedtxt[1:20,], format = "markdown")

Tagging the hotel reviews

We’ll first tag the reviews And then clean them up by removing information-free words like I, me, the, etc.

# Create a list of docId, review (spacyr's input format for text)
text_data <- c()
text_data[training.df$doc_id] <- training.df$Hotel_Reviews
reviews.pos.raw <- spacy_parse(text_data)

# Standardize format
names(reviews.pos.raw)[names(reviews.pos.raw)=="token"] <- "word"
names(reviews.pos.raw)[names(reviews.pos.raw)=="doc_id"] <- "doc_id"
reviews.pos.raw$token_id <- NULL

# Remove all tokens less than 3 characters and remove stop words
reviews.pos <- reviews.pos.raw %>%
    filter(nchar(word) > 3) %>%
    filter(pos!="PART") %>%
    anti_join(stop_words)

reviews.df <- inner_join(training.df, reviews.pos, by="doc_id") %>%
    select(-Filtered_Reviews, -Hotel_Reviews, -sentence_id)

#Cache files for later...
write.csv(reviews.df, file = "./files/reviews_pos.csv")

Here’s a bit of the table after all the tagging is done

kable(head(reviews.df[,2:7]), format = "markdown")

Confirming our parts of speech hypothesis

Let’s see if some of my suspicions about parts of speech are true (hint: they’re not…, but others are)

Start by examining the parts of speech distribution for both truthful and deceptive reviews

reviews.pos.counted <- reviews.df %>%
                        group_by(Truthfulness) %>%
                        dplyr::count(pos,sort=TRUE)
# Cleanup table for presentation                        
names(reviews.pos.counted)[names(reviews.pos.counted)=="pos"] <- "Parts_of_Speech"
names(reviews.pos.counted)[names(reviews.pos.counted)=="n"] <- "Number_of_Occurences"
# I'd like to reorder POS but I can't get it to work :-(
# reorder_pos <- function(aTag) {
#     newOrder <- list(pos=c('NOUN', 'VERB', 'PROPN', 'ADJ', 'ADV', 'ADP', 'DET', 
#                          'NUM', 'PRON', 'PUNCT', 'INTJ', 'CCONJ', 'X'), value=1:13)
#     return(newOrder[aTag])
# }
reviews.pos.counted <- reviews.pos.counted[,c(2,1,3)]
kable(reviews.pos.counted[order(reviews.pos.counted$Parts_of_Speech, reviews.pos.counted$Truthfulness),], 
      format = "markdown")

Hmmn… Compared to deceptive reviews, truthful reviews have:

• Significantly more nouns (NOUN)
• Significantly less adverbial particles (ADP) such as nearby, while, after, before, etc.
• Significantly more numbers (NUM)
• Somewhat fewer proper names (PROPN)

pos.barplot <- ggplot(reviews.pos.counted, aes(Parts_of_Speech,Number_of_Occurences, fill=Truthfulness)) +
        geom_col(position="dodge") +
        coord_flip() +
        ylab("Number of times POS appears") +
        labs(title = "Truthful and Deceptive Reviews - Parts-of-speech Distribution") +
        theme_economist() +
        theme(text=element_text(family="Rockwell"), 
              plot.title = element_text(family="Rockwell", size=12))
pos.barplot