Susan Li | Data Ninja

Text Analysis with Term Frequency for Mark Twain's Novels

2017-09-13T00:00:00+00:00

Introduction

Samuel Langhorne Clemens, otherwise known as Mark Twain, is one of the most important American writers.”The Adventures of Tom Sawyer” is probably one of my most favorite books in all English literature. Happy to see that Twain’s river novels remain required reading for young students, he is read more widely now than ever!

Project Gutenberg offers over 53,000 free books. I will use four of Twain’s best novels for this analysis:

Roughing It
Life on the Mississippi
The Adventures of Tom Sawyer
Adventures of Huckleberry Finn

We will be using the following packages for the analysis:

library(tidyverse)
library(tidyr)
library(ggplot2) 
library(tidytext)
library(stringr)
library(dplyr)
library(tm)
library(topicmodels)
library(gutenbergr)
theme_set(theme_minimal())

Data preprocessing

We’ll retrieve these four books using the gutenbergr package:

books <- gutenberg_download(c(3177, 245, 74, 76), meta_fields = "title")

An important preprocessing step is tokenization. This is the process of splitting a text into individual words or sequences of words. The unnest_tokens function is a way to do just that. The result is converting the text column to be one-token-per-row like so:

tidy_books <- books %>%
  unnest_tokens(word, text)

tidy_books

### A tibble: 502,799 x 3
##   gutenberg_id                        title       word
##          <int>                        <chr>      <chr>
## 1           74 The Adventures of Tom Sawyer        the
## 2           74 The Adventures of Tom Sawyer adventures
## 3           74 The Adventures of Tom Sawyer         of
## 4           74 The Adventures of Tom Sawyer        tom
## 5           74 The Adventures of Tom Sawyer     sawyer
## 6           74 The Adventures of Tom Sawyer         by
## 7           74 The Adventures of Tom Sawyer       mark
## 8           74 The Adventures of Tom Sawyer      twain
## 9           74 The Adventures of Tom Sawyer     samuel
##10           74 The Adventures of Tom Sawyer  langhorne
# ... with 502,789 more rows

After removing stop words, we can find the most common words in all the four books as a whole.

data("stop_words")
cleaned_books <- tidy_books %>%
  anti_join(stop_words)

cleaned_books %>%
  count(word, sort = TRUE)

### A tibble: 21,630 x 2
##      word     n
##     <chr> <int>
## 1    time  1215
## 2     tom   982
## 3     day   701
## 4   river   684
## 5   night   562
## 6 hundred   490
## 7   water   483
## 8    head   471
## 9 chapter   465
##10  people   461
# ... with 21,620 more rows

Sentiment

Sentiment analysis is not the focus today, but since we are here already, why not have a quick look?

bing <- get_sentiments("bing")
bing_word_counts <- tidy_books %>%
  inner_join(bing) %>%
  count(word, sentiment, sort = TRUE) %>%
  ungroup()

bing_word_counts

### A tibble: 3,023 x 3
##     word sentiment     n
##    <chr>     <chr> <int>
## 1   well  positive   989
## 2   like  positive   856
## 3   good  positive   751
## 4  right  positive   566
## 5  great  positive   427
## 6 enough  positive   367
## 7   dead  negative   344
## 8   work  positive   311
## 9 pretty  positive   280
##10 better  positive   244
# ... with 3,013 more rows

bing_word_counts %>%
  filter(n > 100) %>%
  mutate(n = ifelse(sentiment == 'negative', -n, n)) %>%
  mutate(word = reorder(word, n)) %>%
  ggplot(aes(word, n, fill = sentiment)) +
  geom_bar(stat = 'identity') +
  theme(axis.text.x = element_text(angle = 90, hjust = 1)) +
  ylab('Contribution to sentiment') + ggtitle('Most common positive and negative words')

We did not spot anomaly in the sentiment analysis results except word “miss’ is identified as a negative word, actually, it is used as a title for the tough old spinster Miss Watson in “Adventures of Huckleberry Finn”.

tf-idf

To blatantly quote the Wikipedia article on tf-idf:

In text analysis, tf-idf, short for term frequency–inverse document frequency, is a numerical statistic that is intended to reflect how important a word is to a document in a collection or corpus. It is often used as a weighting factor in information retrieval and text mining.

For our purpose, we want to know the most important words(highest tf-idf) in Mark Twain’s four books overall, and most important words(highest tf-idf) in each of these four books. Let’s find out.

book_words <- cleaned_books %>%
  count(title, word, sort = TRUE) %>%
  ungroup()

total_words <- book_words %>% 
  group_by(title) %>% 
  summarize(total = sum(n))

book_words <- left_join(book_words, total_words)

book_words

### A tibble: 38,346 x 4
##                            title   word     n total
##                            <chr>  <chr> <int> <int>
## 1   The Adventures of Tom Sawyer    tom   722 24977
## 2        Life on the Mississippi  river   486 51875
## 3        Life on the Mississippi   time   355 51875
## 4 Adventures of Huckleberry Finn    jim   351 32959
## 5                    Roughing It   time   344 62611
## 6 Adventures of Huckleberry Finn   time   325 32959
## 7                    Roughing It    day   300 62611
## 8 Adventures of Huckleberry Finn warn't   290 32959
## 9 Adventures of Huckleberry Finn     de   252 32959
##10        Life on the Mississippi  water   245 51875
# ... with 38,336 more rows

Terms with the highest tf-idf across all the four novels

book_words <- book_words %>%
  bind_tf_idf(word, title, n)

book_words %>%
  select(-total) %>%
  arrange(desc(tf_idf))

### A tibble: 38,346 x 6
##                  title   word     n          tf       idf      tf_idf
##                            <chr>  <chr> <int>       <dbl>     <dbl>       ##<dbl>
## 1 The Adventures of Tom Sawyer becky 102 0.004083757 0.6931472 0.002830645
## 2 The Adventures of Tom Sawyer tom's 97  0.003883573 0.6931472 0.002691888
## 3 The Adventures of Tom Sawyer huck  232 0.009288545 0.2876821 0.002672148
## 4 AdventuresofHuckleberry Finn warn't290 0.008798811 0.2876821 0.002531260
## 5 Life on the Mississippi     pilots  93 0.001792771 1.3862944 0.002485308
## 6 AdventuresofHuckleberry Finn dey    59 0.001790103 1.3862944 0.002481609
## 7 The Adventures of Tom Sawyer potter 44 0.001761621 1.3862944 0.002442125
## 8 AdventuresofHuckleberry Finn de    252 0.007645863 0.2876821 0.002199578
## 9 Roughing It                don’t    98 0.001565220 1.3862944 0.00216985
##10 The Adventures of Tom Sawyer sid    77 0.003082836 0.6931472 0.002136859
### ... with 38,336 more rows

plot <- book_words %>%
  arrange(desc(tf_idf)) %>%
  mutate(word = factor(word, levels = rev(unique(word))))

plot %>% 
  top_n(20) %>%
  ggplot(aes(word, tf_idf, fill = title)) +
  geom_bar(stat = 'identity', position = position_dodge())+
  labs(x = NULL, y = "tf-idf") +
  coord_flip() + ggtitle("Top tf-idf words in Mark Twain's Four Novels")

plot %>% 
  group_by(title) %>% 
  top_n(10) %>% 
  ungroup %>%
  ggplot(aes(word, tf_idf, fill = title)) +
  geom_col(show.legend = FALSE) +
  labs(x = NULL, y = "tf-idf") +
  facet_wrap(~title, ncol = 2, scales = "free") +
  coord_flip() + ggtitle('Top tf-idf words in each novel')

Each novel has its own highest tf-idf words. However, the language he used across these four novels are pretty similar, such as term “city” has high tf-idf in “Roughing it” and “Life on the Mississippi”.

Term frequency

Just for the kicks, let’s compare Mark Twain’s works with those of Charles Dicken’s. Let’s get “A Tale of Two Cities”, “Great Expectations”, “A Christmas Carol in Prose; Being a Ghost Story of Christmas”, “Oliver Twist” and “Hard Times”.

What are the most common words in these novels of Charles Dickens?

dickens <- gutenberg_download(c(98, 1400, 46, 730, 786))
tidy_dickens <- dickens %>%
  unnest_tokens(word, text) %>%
  anti_join(stop_words)
tidy_dickens %>%
  count(word, sort = TRUE)

### A tibble: 19,634 x 2
##     word     n
##    <chr> <int>
## 1   time  1218
## 2   hand   918
## 3  night   835
## 4 looked   814
## 5   head   813
## 6 oliver   766
## 7   dear   751
## 8    joe   718
## 9   miss   702
##10    sir   697
### ... with 19,624 more rows

tidy_twains <- books %>%
  unnest_tokens(word, text) %>%
  anti_join(stop_words)

frequency <- bind_rows(mutate(tidy_twains, author = "Mark Twain"),
                       mutate(tidy_dickens, author = "Charles Dickens")) %>% 
  mutate(word = str_extract(word, "[a-z']+")) %>%
  count(author, word) %>%
  group_by(author) %>%
  mutate(proportion = n / sum(n)) %>% 
  select(-n) %>% 
  spread(author, proportion) %>% 
  gather(author, proportion, `Mark Twain`:`Charles Dickens`)

frequency$word <- factor(frequency$word, 
                     levels=unique(with(frequency, 
                                 word[order(proportion, word, 
                                            decreasing = TRUE)])))
frequency <- frequency[complete.cases(frequency), ]
ggplot(aes(x = reorder(word, proportion), y = proportion, fill = author), 
       data = subset(frequency, proportion>0.0025)) +
  geom_bar(stat = 'identity', position = position_dodge())+
  coord_flip() + ggtitle('Comparing the word frequencies of Mark Twain and Charles Dickens')

The top term for both author is the same - “time”. Other than that, their language are very different.

Text Analysis with Term Frequency for Mark Twain's Novels was originally published by Susan Li at Susan Li | Data Ninja on September 13, 2017.

Topic Modeling of New York Times Articles

2017-09-04T00:00:00+00:00

In machine learning and natural language processing, A “topic” consists of a cluster of words that frequently occur together. A topic model is a type of statistical model for discovering the abstract “topics” that occur in a collection of documents. Topic modeling is a frequently used text-mining tool for discovery of hidden semantic structures in a text body. Topic models can connect words with similar meanings and distinguish between uses of words with multiple meanings.

For this analysis, I downloaded 22 recent articles from business and technology sections at New York Times. I am using the collection of these 22 articles as my corpus for the topic modeling exercise. Therefore, each article is a document, with an unknown topic structure.

Load the library

library(tm)
library(topicmodels)
library(SnowballC)
library(tidytext)
library(ggplot2)
library(dplyr)

Set the working directory.

setwd('C:/Users/Susan/Documents/textmining')

Load the files into corpus.

filenames <- list.files(getwd(),pattern='*.txt')

Read the files into a character vector.

files <- lapply(filenames, readLines)

Create corpus from the vector and inspect the 5th document.

docs <- Corpus(VectorSource(files))
writeLines(as.character(docs[[5]]))

##c("The Food and Drug Administration on Wednesday approved the first-ever ##treatment that genetically alters a patient’s own cells to fight cancer, a ##milestone that is expected to transform treatment in the coming years.The ##new therapy turns a patient’s cells into a “living drug,” and trains them to ##recognize and attack the disease. It is part of the rapidly growing field ##of", "immunotherapy that bolster...

Data Preprocessing

Remove potential problematic symbols

toSpace <- content_transformer(function(x, pattern) {return (gsub(pattern, '', x))})
docs <- tm_map(docs, toSpace, '-')
docs <- tm_map(docs, toSpace, ':')
docs <- tm_map(docs, toSpace, '“')
docs <- tm_map(docs, toSpace, '”')
docs <- tm_map(docs, toSpace, "'")

Remove punctuation, digits, stop words and white space.

docs <- tm_map(docs, removePunctuation)
docs <- tm_map(docs, removeNumbers)
docs <- tm_map(docs, removeWords, stopwords('english'))
docs <- tm_map(docs, stripWhitespace)

Define and remove custom stop words.

myStopwords <- c('can','say','said','will','like','even','well','one', 'hour', 'also', 'take', 'well','now','new', 'use', 'the')
docs <- tm_map(docs, removeWords, myStopwords)

I decided to go further and remove everything that is not alpha or numerical symbol or space.

removeSpecialChars <- function(x) gsub("[^a-zA-Z0-9 ]","",x)
docs <- tm_map(docs, removeSpecialChars)

Transform to lowercase.

docs <- tm_map(docs, content_transformer(tolower))

Stem the document. It looks right after all the preprocessing.

docs <- tm_map(docs,stemDocument)
writeLines(as.character(docs[[5]]))

##cthe food drug administr wednesday approv firstev treatment genet alter ##patient cell fight cancer mileston expect transform treatment come yearsth ##therapi turn patient cell live drug train recogn attack diseas it part rapid ##grow field immunotherapi...

Right now this data frame is in a tidy form, with one-term-per-document-per-row. However, the topicmodels package requires a DocumentTermMatrix. We can create a DocumentTermMatrix like so:

dtm <- DocumentTermMatrix(docs)
dtm

##<<DocumentTermMatrix (documents: 22, terms: 3290)>>
##Non-/sparse entries: 7323/65057
##Sparsity           : 90%
##Maximal term length: 18
##Weighting          : term frequency (tf)

Topic Modeling

Latent Dirichlet allocation (LDA) is one of the most common algorithms for topic modeling. LDA assumes that each document in a corpus contains a mix of topics that are found throughout the entire corpus. The topic structure is unknown - we can only observe the documents and words, not the topics themselves. Because the structure is unknown (also known as latent), this method seeks to infer the topic structure given the known words and documents.

Now We are ready to use the LDA() function from the topicmodels package. Let’s estimate an LDA model for these New york Times articles, setting k = 4, to create a 4-topic LDA model.

nytimes_lda <- LDA(dtm, k = 4, control = list(seed = 1234))
nytimes_lda

##A LDA_VEM topic model with 4 topics.

Word-topic probabilities

nytimes_topics <- tidy(nytimes_lda, matrix = "beta")
nytimes_topics

### A tibble: 13,160 x 3
##   topic  term          beta
##   <int> <chr>         <dbl>
## 1     1 adapt  3.204101e-04
## 2     2 adapt 8.591570e-103
## 3     3 adapt 1.585924e-100
## 4     4 adapt 5.643274e-101
## 5     1   add  6.408202e-04
## 6     2   add 1.677995e-100
## 7     3   add  3.793627e-04
## 8     4   add  7.110579e-04
## 9     1 addit  3.204101e-04
##10     2 addit  5.634930e-04
### ... with 13,150 more rows

This has turned the model into a one-topic-per-term-per-row format. For each combination the model has beta - the probability of that term being generated from that topic. For example, the term “adapt” has a 3.204101e-04 probability of being generated from topic 1, but a 8.591570e-103 probability of being generated from topic 2.

Let’s visualize to understand the 4 topics that were extracted from these 22 documents.

nytimes_top_terms <- nytimes_topics %>%
  group_by(topic) %>%
  top_n(10, beta) %>%
  ungroup() %>%
  arrange(topic, -beta)

nytimes_top_terms %>%
  mutate(term = reorder(term, beta)) %>%
  ggplot(aes(term, beta, fill = factor(topic))) +
  geom_col(show.legend = FALSE) +
  facet_wrap(~ topic, scales = "free") +
  coord_flip() + ggtitle('Top terms in each LDA topic')

The 4 topics generally look to describe:

iPhone and car businesses
Tax, insurance coroporates in Houson
Restaurant reservation, Google, and Uber’s new CEO
New technology and banking

Let’s set k = 9, see how do our results change?

nytimes_lda <- LDA(dtm, k = 9, control = list(seed = 4321))
nytimes_topics <- tidy(nytimes_lda, matrix = "beta")

nytimes_top_terms <- nytimes_topics %>%
  group_by(topic) %>%
  top_n(10, beta) %>%
  ungroup() %>%
  arrange(topic, -beta)

nytimes_top_terms %>%
  mutate(term = reorder(term, beta)) %>%
  ggplot(aes(term, beta, fill = factor(topic))) +
  geom_col(show.legend = FALSE) +
  facet_wrap(~ topic, scales = "free") +
  coord_flip() + ggtitle('Top terms in each LDA topic')

From a quick view of the visualization it appears that the algorithm has done a decent job. The most common words in topic 9 include “uber” and “khosrowshahi”, which suggests it is about the new Uber CEO Dara Khosrowshahi. The most common words in topic 5 include “insurance”, “houston”, and “corporate”, suggesting that this topic represents insurance related matters after Houston’s Hurrican Harvey. One interesting observation is that the word “company” is common in 6 of the 9 topics.

For the interest of space, I fit a model with 9 topics to this dataset. I encourage you to try a range of different values of k (topic) to find the optimal number of topics, to see whether the model’s performance can be improved.

Document-topic probabilities

Besides estimating each topic as a mixture of words, topic modeling also models each document as a mixture of topics like so:

nytimes_lda_gamma <- tidy(nytimes_lda, matrix = "gamma")
nytimes_lda_gamma

### A tibble: 198 x 3
##   document topic        gamma
##      <chr> <int>        <dbl>
## 1        1     1 8.191867e-05
## 2        2     1 4.471408e-05
## 3        3     1 4.180694e-05
## 4        4     1 3.184344e-05
## 5        5     1 4.540474e-05
## 6        6     1 9.998000e-01
## 7        7     1 2.972724e-05
## 8        8     1 3.492409e-05
## 9        9     1 3.275588e-05
##10       10     1 3.918000e-05
### ... with 188 more rows

Each of these values (gamma) is an estimated proportion of words from that document that are generated from that topic. For example, the model estimates that about 0.008% of the words in document 1 were generated from topic 1. To confirm this result, we check what the most common words in document 1 were:

tidy(dtm) %>%
  filter(document == 1) %>%
  arrange(desc(count))

### A tibble: 177 x 3
##   document    term count
##      <chr>   <chr> <dbl>
## 1        1  driver    11
## 2        1     app     7
## 3        1     car     6
## 4        1  teenag     5
## 5        1   drive     4
## 6        1  parent     4
## 7        1   phone     4
## 8        1 compani     3
## 9        1  famili     3
##10        1  inform     3
### ... with 167 more rows

This appears to be an article about teenagers’ driving. Topic 1 does not have driving related topics, this means that the algorithm was right not to place this document in topic 1.

The End

Topic modeling can provide a way to get from raw text to a deeper understanding of unstructured data. However, we need to examine the results carefully to check that they make sense.

So, try yourself, have fun, and start practicing those topic modeling skills!

Topic Modeling of New York Times Articles was originally published by Susan Li at Susan Li | Data Ninja on September 04, 2017.

4 years of The Hacker News, in 5 Charts

2017-08-23T00:00:00+00:00

Introduction

Hacker News is one of my favorite sites to catch up on technology and startup news, but navigating the minimalistic website can be sometimes tedious. Therefore, my plan in this post is to introduce you that how this social news site can be analyzed, in as non-technical a fashion as I can, as well as presenting some initial results, along with some ideas about where we will take it next.

To avoid dealing with SQL, I downloaded Hacker News dataset from David Robinson’s website, it includes one million Hacker News article titles from September 2013 to June 2017.

To begin, let’s look at the visualization of the most common words in Hacker News titles.

library(tidyverse)
library(lubridate)
library(tidytext)
library(stringr)
library(ggplot2)
library(ggthemes)
library(reshape2)
library(wordcloud)
library(tidyr)
library(igraph)
library(ggraph)

hackernews <- read_csv("stories_1000000.csv.gz") %>%
  mutate(time = as.POSIXct(time, origin = "1970-01-01"),
         month = round_date(time, "month"))

Some initial simple exploration

Before we get into the statistical analysis, the first step is to look at the most frequent words that appeared on Hacker News titles from September 2013 to June 2017.

hackernews %>% 
  unnest_tokens(word, title) %>% 
  anti_join(stop_words) %>% 
  count(word, sort=TRUE) %>% 
  filter(n > 8000) %>% 
  mutate(word = reorder(word, n)) %>% 
  ggplot(aes(word, n)) +
  geom_col() +
  xlab(NULL) +
  coord_flip() + 
  labs(title = "The Most Common Words in Hacker News Titles") +
  theme_fivethirtyeight()

For the most part, we would expect it is a fairly standard list of common words in Hacker News titles. The top word is “hn”, because “ask hn”, “show hn” are part of the social news site’s structure. The second most frequent words such as “google”, “data”, “app”, “web”, “startup” and so on are all within our expectation for a social news site like Hacker News.

tidy_hacker <- hackernews %>%
  unnest_tokens(word, title) %>%
  anti_join(stop_words)
  
tidy_hacker %>%
  count(word, sort = TRUE)

### A tibble: 176,672 x 2
##      word     n
##     <chr> <int>
## 1      hn 76530
## 2  google 23574
## 3    data 22520
## 4     app 19452
## 5     web 16075
## 6 startup 15021
## 7    code 12854
## 8    time 12656
## 9   video 12370
##10   apple 11780
### ... with 176,662 more rows

Simple Sentiment Analysis

Let’s address the topic of sentiment analysis. Sentiment analysis detects the sentiment of a body of text in terms of polarity (positive or negative). When used, particularly at scale, it can show you how people feel towards the topics that are important to you.

We can analyze word counts that contribute to each sentiment. From the Hacker news articles, We fount out how much each word contributed to each sentiment

bing_word_counts <- tidy_hacker %>%
  inner_join(get_sentiments("bing")) %>%
  count(word, sentiment, sort = TRUE) %>%
  ungroup()
bing_word_counts

### A tibble: 4,821 x 3
##      word sentiment     n
##     <chr>     <chr> <int>
## 1    free  positive 11777
## 2   cloud  negative  7010
## 3     top  positive  5654
## 4 support  positive  4805
## 5    fast  positive  3604
## 6   smart  positive  3266
## 7   swift  positive  3247
## 8     bad  negative  3234
## 9    easy  positive  3216
##10    hack  negative  3020
### ... with 4,811 more rows

bing_word_counts %>%
  group_by(sentiment) %>%
  top_n(10) %>%
  ungroup() %>%
  mutate(word = reorder(word, n)) %>%
  ggplot(aes(word, n, fill = sentiment)) +
  geom_col(show.legend = FALSE) +
  facet_wrap(~sentiment, scales = "free_y") +
  labs(title = "The Most Common Positive and Negative Words in Hacker News Titles", y = "Words Contribute to sentiment", x = NULL) +
  coord_flip() + theme_fivethirtyeight()

Word cloud is always a good idea to identify trends and patterns that would otherwise be unclear or difficult to see in a tabular format. We can also compare most frequent positive and negative words in word cloud.

tidy_hacker %>%
  inner_join(get_sentiments("bing")) %>%
  count(word, sentiment, sort = TRUE) %>%
  acast(word ~ sentiment, value.var = "n", fill = 0) %>%
  comparison.cloud(colors = c("#F8766D", "#00BFC4"),
                   max.words = 100)

Relationship between words

we often want to understand the relationship between words in a document. What sequences of words are common across text? Given a sequence of words, what word is most likely to follow? What words have the strongest relationship with each other? Therefore, many interesting text analysis are based on the relationships. When we exam pairs of two consecutive words, it is often called “bigrams”

hacker_bigrams <- hackernews %>%
  unnest_tokens(bigram, title, token = "ngrams", n = 2)

bigrams_separated <- hacker_bigrams %>%
  separate(bigram, c("word1", "word2"), sep = " ")
bigrams_filtered <- bigrams_separated %>%
  filter(!word1 %in% stop_words$word) %>%
  filter(!word2 %in% stop_words$word)
bigram_counts <- bigrams_filtered %>% 
  count(word1, word2, sort = TRUE)
bigram_counts

### A tibble: 1,255,379 x 3
##         word1        word2     n
##         <chr>        <chr> <int>
## 1     machine     learning  3369
## 2     silicon       valley  3338
## 3        deep     learning  2226
## 4        real         time  2116
## 5      social        media  1810
## 6        data      science  1621
## 7 programming     language  1601
## 8   raspberry           pi  1584
## 9  artificial intelligence  1549
##10         san    francisco  1490
### ... with 1,255,369 more rows

bigrams_united <- bigrams_filtered %>%
  unite(bigram, word1, word2, sep = " ")

bigram_tf_idf <- bigrams_united %>%
  count(bigram)
bigram_tf_idf <- bigram_tf_idf %>% filter(n>1000)
ggplot(aes(x = reorder(bigram, n), y=n), data=bigram_tf_idf) + geom_bar(stat = 'identity') + labs(title = "The Most Common Bigrams in Hacker News") + coord_flip() + theme_fivethirtyeight()

Winner of most common bigram in Hacker news data goes to “machine learning” and the second is “silicon valley”.

The challenge in analyzing text data, as mentioned earlier, is in understanding what the words mean. The use of the word “deep” has different meaning if it is paired with the word “water” as opposed to the word “learning”. As a result, a simple summary of word counts in text data will likely be confusing unless the analysis relate it to the other words that also appear without assuming an independent process of word choice.

bigram_graph <- bigram_counts %>%
  filter(n > 600) %>%
  graph_from_data_frame()
bigram_graph

##IGRAPH DN-- 76 46 -- 
##+ attr: name (v/c), n (e/n)
##+ edges (vertex names):
## [1] machine ->learning     silicon   ->valley    deep     ->learning    
## [4] real     ->time         social   ->media     data       ->science     
## [7] programming->language  raspberry  ->pi       artificial ->intelligence
##[10] san    ->francisco     windows    ->10       hacker     ->news        
##[13] command  ->line        elon     ->musk       net        ->neutrality  
##[16] virtual  ->reality     app       ->store     mobile     ->app         
##[19] apple    ->watch       source    ->code      react      ->native      
##[22] computer ->science      wi       ->fi        chrome     ->extension   
##+ ... omitted several edges

Networks of words

Words networks analysis is one method for encoding the relationships between words in a text and constructing a network of the linked words. This technique is based on the assumption that language and knowledge can be modeled as networks of words and the relations between them.

For Hacker news data, we can visualize some details of the text structure. For example, we can see pairs or triplets that form common short phrases (“Social media network” or “neural networks”).

set.seed(2017)
ggraph(bigram_graph, layout = "fr") +
  geom_edge_link() +
  geom_node_point(color = "plum4", size = 5) +
  geom_node_text(aes(label = name), vjust = 1.8) + labs(title = "Word Network in Hacker News Dataset Titles") + 
  theme_fivethirtyeight()

This type of network analysis is mainly showing us the important nouns in a text, and how they are related. The resulting graph can be used to get a quick visual summary of the text, read the most relevant excerpts.

Once we have the capability to automatically derive insights from text analytics, they then can translate the insights into actions.

There is no structured survey data does a better job predicting customer behavior as well as actual voice of customer text comments and messages!

Code that created this post can be found here. I welcome your comments and questions!

4 years of The Hacker News, in 5 Charts was originally published by Susan Li at Susan Li | Data Ninja on August 23, 2017.

Modeling and prediction for movies

2017-06-28T00:00:00+00:00

Setup

This project details our analysis of the movie dataset that contains information from Rotten Tomatos and IMDB for a random sample of movies. The purpose of this project is to develop a multiple linear regression model to understand what attributes make a movie popular. In the meantime, learning something new about movies.

Load packages

library(ggplot2)
library(dplyr)
library(statsr)
library(gridExtra)
library(corrplot)

Load data

load("movies.Rdata")

Part 1: Data

The data set is comprised of 651 randomly sampled movies produced and released before 2016, each row in the dataset is a movie and each column is a characteristic of a movie. Therefore, the data should allow us to generalize to the population of interest. However, there is no causation can be established because random assignment is not used in this study. In addition, potential biases are associated with non-voting or non_rating because the voting and rating are voluntary on IMDB and Rotten Tomatos website.

From common sense, we realized that many of the variables are irrelevant to the purpose of identifying the popularity of a movie. As such, we select the following variables to start our analysis.

title_type: Type of movie (Documentary, Feature Film, TV Movie)
genre: Genre of movie (Action & Adventure, Comedy, Documentary, Drama, Horror, Mystery & Suspense, Other)
runtime: Runtime of movie (in minutes)
imdb_rating: Rating on IMDB
imdb_num_votes: Number of votes on IMDB
critics_rating: Categorical variable for critics rating on Rotten Tomatoes (Certified Fresh, Fresh, Rotten)
critics_score: Critics score on Rotten Tomatoes
audience_rating: Categorical variable for audience rating on Rotten Tomatoes (Spilled, Upright)
audience_score: Audience score on Rotten Tomatoes
best_pic_win: Whether or not the movie won a best picture Oscar (no, yes)
best_actor_win: Whether or not one of the main actors in the movie ever won an Oscar (no, yes) - note that this is not necessarily whether the actor won an Oscar for their role in the given movie
best_actress win: Whether or not one of the main actresses in the movie ever won an Oscar (no, yes) - not that this is not necessarily whether the actresses won an Oscar for their role in the given movie
best_dir_win: Whether or not the director of the movie ever won an Oscar (no, yes) - not that this is not necessarily whether the director won an Oscar for the given movie

Part 2: Research question

Is a movie’s popularity, as measured by audience score, related to the type of movie, genre, runtime, imdb rating, imdb number of votes, critics rating, critics score, audience rating, Oscar awards obtained (actor, actress, director and picture)? Being able to answer this question will help us to predict a movie’s popularity.

Part 3: Exploratory data analysis and feature selection

Abstracting the data of the above potential predictors for the model.

movies_new <- movies %>% select(title, title_type, genre, runtime, imdb_rating, imdb_num_votes, critics_rating, critics_score, audience_rating, audience_score, best_pic_win, best_actor_win, best_actress_win, best_dir_win)

Look at the structure of the data

str(movies_new)

##Classes 'tbl_df', 'tbl' and 'data.frame':	650 obs. of  14 variables:
## $ title           : chr  "Filly Brown" "The Dish" "Waiting for Guffman" ##"The Age of Innocence" ...
## $ title_type      : Factor w/ 3 levels "Documentary",..: 2 2 2 2 2 1 2 2 1 ##2 ...
## $ genre           : Factor w/ 11 levels "Action & Adventure",..: 6 6 4 6 7 ##5 6 6 5 6 ...
## $ runtime         : num  80 101 84 139 90 78 142 93 88 119 ...
## $ imdb_rating     : num  5.5 7.3 7.6 7.2 5.1 7.8 7.2 5.5 7.5 6.6 ...
## $ imdb_num_votes  : int  899 12285 22381 35096 2386 333 5016 2272 880 12496 ##...
## $ critics_rating  : Factor w/ 3 levels "Certified Fresh",..: 3 1 1 1 3 2 3 ##3 2 1 ...
## $ critics_score   : num  45 96 91 80 33 91 57 17 90 83 ...
## $ audience_rating : Factor w/ 2 levels "Spilled","Upright": 2 2 2 2 1 2 2 1 ##2 2 ...
## $ audience_score  : num  73 81 91 76 27 86 76 47 89 66 ...
## $ best_pic_win    : Factor w/ 2 levels "no","yes": 1 1 1 1 1 1 1 1 1 1 ...
## $ best_actor_win  : Factor w/ 2 levels "no","yes": 1 1 1 2 1 1 1 2 1 1 ...
## $ best_actress_win: Factor w/ 2 levels "no","yes": 1 1 1 1 1 1 1 1 1 1 ...
## $ best_dir_win    : Factor w/ 2 levels "no","yes": 1 1 1 2 1 1 1 1 1 1 ...
## - attr(*, "na.action")=Class 'omit'  Named int 334
##  .. ..- attr(*, "names")= chr "334"

Summary statistics

summary(movies_new)

##    title             title_type                 genre        runtime     
## Length:650     Documentary : 54   Drama          :305   Min.   : 39.0  
## Class :character Feature Film:591  Comedy        : 87   1st Qu.: 92.0  
## Mode  :character TV Movie    :5  Action & Adventure: 65 Median :103.0  
##                                  Mystery & Suspense: 59   Mean   :105.8  
##                                  Documentary       : 51   3rd Qu.:115.8  
##                                  Horror            : 23   Max.   :267.0  
##                                  (Other)           : 60                  
##  imdb_rating    imdb_num_votes           critics_rating critics_score   
## Min.   :1.900   Min.   :   180   Certified Fresh:135    Min.   :  1.00  
## 1st Qu.:5.900   1st Qu.:  4584   Fresh          :208    1st Qu.: 33.00  
## Median :6.600   Median : 15204   Rotten         :307    Median : 61.00  
## Mean   :6.492   Mean   : 57620                          Mean   : 57.65  
## 3rd Qu.:7.300   3rd Qu.: 58484                          3rd Qu.: 83.00  
## Max.   :9.000   Max.   :893008                          Max.   :100.00  
                                                                         
## audience_rating audience_score  best_pic_win best_actor_win ##best_actress_win
## Spilled:275     Min.   :11.00   no :643      no :557        no :578         
## Upright:375     1st Qu.:46.00   yes:  7      yes: 93        yes: 72         
##                 Median :65.00                                               
##                 Mean   :62.35                                               
##                 3rd Qu.:80.00                                               
##                 Max.   :97.00                                               
                                                                             
## best_dir_win
## no :607     
## yes: 43

I find there is one missing value, and decide to drop it.

movies_new <- na.omit(movies_new)

Part of this project is to use the model to predict a movie’s audience score and this movie should not be part of the data. Therefore, I split the data into traning and testing, and there is only one row in the test set.

set.seed(2017)
split <- sample(seq_len(nrow(movies_new)), size = floor(0.999 * nrow(movies_new)))
train <- movies_new[split, ]
test <- movies_new[-split, ]
dim(train)

##[1] 649  14

dim(test)

##[1]  1 14

Histogram of Numeric variables

hist(train$audience_score)
summary(train$audience_score)

## Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
## 11.0    46.0    65.0    62.3    80.0    97.0

The median of our response variable - audience score distribution is 65; 25% of the movie in the training set have an audience score higher than 80; 25% of the movie in the training set have an audience score lower than 46; very few movie have an audience score lower than 20 or higher than 90 (i.e.Audience in the data are unlikey to give very low or very high score).

p1 <- ggplot(aes(x=runtime), data=train) + 
  geom_histogram(aes(y=100*(..count..)/sum(..count..)), color='black', fill='white', binwidth = 5) + ylab('percentage') + ggtitle('Run Time')
p2 <- ggplot(aes(x=imdb_rating), data=train) +
  geom_histogram(aes(y=100*(..count..)/sum(..count..)), color='black', fill='white', binwidth = 0.2) + ylab('percentage') + ggtitle('IMDB rating')
p3 <- ggplot(aes(x=log10(imdb_num_votes)), data=train) +
  geom_histogram(aes(y=100*(..count..)/sum(..count..)), color='black', fill='white') + ylab('percentage') + ggtitle('log(IMDB number of votes)')
p4 <- ggplot(aes(x=critics_score), data=train) +
  geom_histogram(aes(y=100*(..count..)/sum(..count..)), color='black', fill='white', binwidth = 2) + ylab('percentage') + ggtitle('Critics Score')
grid.arrange(p1, p2, p3, p4, ncol=2)

Regression analysis: Run time, IMDB rating, log(IMDB number of votes) and Critics Scores all have reasonable broad distribution, therefore, they will be considered for the regression analysis.

Bar plot of categorical variables

p1 <- ggplot(aes(x=title_type), data=train) + geom_bar(aes(y=100*(..count..)/sum(..count..))) + ylab('percentage') +
  ggtitle('Title Type') + coord_flip()
p2 <- ggplot(aes(x=genre), data=train) + geom_bar(aes(y=100*(..count..)/sum(..count..))) + ylab('percentage') +
  ggtitle('Genre') + coord_flip()
p3 <- ggplot(aes(x=critics_rating), data=train) + geom_bar(aes(y=100*(..count..)/sum(..count..))) + ylab('percentage') +
  ggtitle('Critics Rating') + coord_flip()
p4 <- ggplot(aes(x=audience_rating), data=train) + geom_bar(aes(y=100*(..count..)/sum(..count..))) + ylab('percentage') +
  ggtitle('Audience Rating') + coord_flip()
grid.arrange(p1, p2, p3, p4, ncol=2)

Not all those categorical variables have reasonable spread of distribution. Most movies in the data are in the “Feature Film” title type and majority of the movies are drama. Therefore, we must be aware that the results could be biased toward drama movies.

Correlation between numerical variables

vars <- names(train) %in% c('runtime', 'imdb_rating', 'imdb_num_votes', 'critics_score')
selected_train <- train[vars]
corr.matrix <- cor(selected_train)
corrplot(corr.matrix, main="\n\nCorrelation Plot of numerical variables", method="number")

Two predictors - critics score and imdb rating are highly correlated at 0.76 (collinearity), therefore, One of them will be removed from the model, I decided to remove critics score.

Correlation between categorical variables and audience score

boxplot(audience_score~critics_rating, data=train, main='Audience score vs. Critics rating', xlab='Critics Rating', ylab='Audience Score')
by(train$audience_score, train$critics_rating, summary)
boxplot(audience_score~audience_rating, data=train, main='Audience Score vs. Audience Rating', xlab='Audience rating', ylab='Audience Score')
by(train$audience_score, train$audience_rating, summary)
boxplot(audience_score~title_type, data=train, main='Audience score vs. Title type', xlab='Title_type', ylab='Audience Score')
by(train$audience_score, train$title_type, summary)
boxplot(audience_score~genre, data=train, main='Audience score vs. Genre', xlab='Genre', ylab='Audience score')
by(train$audience_score, train$genre, summary)

##train$critics_rating: Certified Fresh
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  35.00   71.00   81.00   79.26   87.00   97.00 
##-------------------------------------------------------------- 
##train$critics_rating: Fresh
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  29.00   58.00   74.00   69.96   83.00   94.00 
##-------------------------------------------------------------- 
##train$critics_rating: Rotten
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   11.0    36.0    48.0    49.7    64.0    95.0

##train$audience_rating: Spilled
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  11.00   35.00   43.00   41.93   51.00   59.00 
##-------------------------------------------------------------- 
##train$audience_rating: Upright
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  60.00   70.00   78.00   77.27   85.00   97.00

##train$title_type: Documentary
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  68.00   78.00   86.00   83.46   89.00   96.00 
##-------------------------------------------------------------- 
##train$title_type: Feature Film
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  11.00   44.25   62.00   60.41   78.00   97.00 
##-------------------------------------------------------------- 
##train$title_type: TV Movie
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   19.0    21.0    75.0    56.8    83.0    86.0

##train$genre: Action & Adventure
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  11.00   36.50   51.50   53.16   65.00   92.00 
##-------------------------------------------------------------- 
##train$genre: Animation
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  18.00   59.00   65.00   62.44   70.00   88.00 
##-------------------------------------------------------------- 
##train$genre: Art House & International
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  29.00   51.25   65.50   64.00   80.25   86.00 
##-------------------------------------------------------------- 
##train$genre: Comedy
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  19.00   37.00   50.00   52.51   67.50   93.00 
##-------------------------------------------------------------- 
##train$genre: Documentary
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  57.00   77.50   86.00   82.96   89.00   96.00 
##-------------------------------------------------------------- 
##train$genre: Drama
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  13.00   52.00   70.00   65.35   80.00   95.00 
##-------------------------------------------------------------- 
##train$genre: Horror
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  24.00   36.00   43.00   45.83   53.50   84.00 
##-------------------------------------------------------------- 
##train$genre: Musical & Performing Arts
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  55.00   75.75   80.50   80.17   89.50   95.00 
##-------------------------------------------------------------- 
##train$genre: Mystery & Suspense
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  15.00   40.50   54.00   55.95   70.50   97.00 
##-------------------------------------------------------------- 
##train$genre: Other
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  21.00   53.00   73.50   66.69   82.50   91.00 
##-------------------------------------------------------------- 
##train$genre: Science Fiction & Fantasy
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  17.00   26.00   47.00   50.89   79.00   85.00

All the categorical variables seems to have reasonable significant correlation with audience score.

Part 4: Modeling

We will be using stepwise model forward selection method, we start with an empty model, then add variables one at a time until a parsimonious model is reached. From the following full model, we can see that imdb rating has the lowest p value and is the most correlated variable to our response variable. So we choose imdb rating as the first predictor.

full_model <- lm(audience_score~imdb_rating+title_type+genre+runtime+imdb_num_votes+critics_rating+audience_rating+best_pic_win+best_actor_win+best_actress_win+best_dir_win, data=train)
summary(full_model)

##Call:
##lm(formula = audience_score ~ imdb_rating + title_type + genre + 
##    runtime + imdb_num_votes + critics_rating + audience_rating + 
##    best_pic_win + best_actor_win + best_actress_win + best_dir_win, 
##    data = train)

##Residuals:
##     Min       1Q   Median       3Q      Max 
##-21.5617  -4.4946   0.5783   4.3575  24.5177 

##Coefficients:
##                                 Estimate Std. Error t value Pr(>|t|)    
##(Intercept)                    -9.973e+00  4.054e+00  -2.460   0.0142 *  
##imdb_rating                     9.549e+00  4.288e-01  22.271   <2e-16 ***
##title_typeFeature Film          2.223e+00  2.544e+00   0.874   0.3826    
##title_typeTV Movie              6.679e-01  4.031e+00   0.166   0.8685    
##genreAnimation                  3.267e+00  2.478e+00   1.318   0.1879    
##genreArt House & International -2.527e+00  2.063e+00  -1.225   0.2210    
##genreComedy                     1.563e+00  1.146e+00   1.364   0.1731    
##genreDocumentary                2.550e+00  2.725e+00   0.936   0.3498    
##genreDrama                     -5.613e-01  9.977e-01  -0.563   0.5739    
##genreHorror                    -1.842e+00  1.688e+00  -1.091   0.2757    
##genreMusical & Performing Arts  3.615e+00  2.361e+00   1.531   0.1263    
##genreMystery & Suspense        -3.108e+00  1.273e+00  -2.441   0.0149 *  
##genreOther                      3.295e-01  1.956e+00   0.168   0.8663    
##genreScience Fiction & Fantasy -1.720e-01  2.462e+00  -0.070   0.9443    
##runtime                        -2.532e-02  1.665e-02  -1.521   0.1288    
##imdb_num_votes                  2.719e-06  3.094e-06   0.879   0.3798    
##critics_ratingFresh             1.594e-02  8.429e-01   0.019   0.9849    
##critics_ratingRotten           -1.197e+00  9.307e-01  -1.286   0.1989    
##audience_ratingUpright          2.009e+01  7.905e-01  25.408   <2e-16 ***
##best_pic_winyes                 5.692e-01  2.931e+00   0.194   0.8461    
##best_actor_winyes               2.680e-01  8.128e-01   0.330   0.7417    
##best_actress_winyes            -1.031e+00  9.022e-01  -1.143   0.2534    
##best_dir_winyes                 5.604e-02  1.199e+00   0.047   0.9627    
##---
##Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

##Residual standard error: 6.87 on 626 degrees of freedom
##Multiple R-squared:  0.8884,	Adjusted R-squared:  0.8845 
##F-statistic: 226.5 on 22 and 626 DF,  p-value: < 2.2e-16

fit1 <- lm(audience_score ~ imdb_rating, data=train)
summary(fit1)

##Call:
##lm(formula = audience_score ~ imdb_rating, data = train)

##Residuals:
##    Min      1Q  Median      3Q     Max 
##-26.805  -6.548   0.647   5.678  52.907 

##Coefficients:
##            Estimate Std. Error t value Pr(>|t|)    
##(Intercept) -42.3620     2.4269  -17.45   <2e-16 ***
##imdb_rating  16.1300     0.3689   43.72   <2e-16 ***
##---
##Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

##Residual standard error: 10.17 on 647 degrees of freedom
##Multiple R-squared:  0.7471,	Adjusted R-squared:  0.7467 
##F-statistic:  1911 on 1 and 647 DF,  p-value: < 2.2e-16

The 0.75 R-squared and almost zero p value indicate that imdb rating is a statistically significant predictor of audience score.

In order to find out the second predictor, I look at the following model.

fit_model <- lm(audience_score~title_type+genre+runtime+imdb_num_votes+critics_rating+audience_rating+best_pic_win+best_actor_win+best_actress_win+best_dir_win, data=train)
summary(fit_model)

##Call:
##lm(formula = audience_score ~ title_type + genre + runtime + 
##    imdb_num_votes + critics_rating + audience_rating + best_pic_win + 
##    best_actor_win + best_actress_win + best_dir_win, data = train)

##Residuals:
##     Min       1Q   Median       3Q      Max 
##-30.4266  -6.0224   0.8273   6.6292  19.4100 

##Coefficients:
##                                 Estimate Std. Error t value Pr(>|t|)    
##(Intercept)                     4.478e+01  4.312e+00  10.384  < 2e-16 ***
##title_typeFeature Film         -8.169e-01  3.398e+00  -0.240  0.81009    
##title_typeTV Movie             -6.046e+00  5.377e+00  -1.124  0.26128    
##genreAnimation                  2.038e-01  3.310e+00   0.062  0.95091    
##genreArt House & International  6.481e-01  2.753e+00   0.235  0.81395    
##genreComedy                     4.431e-01  1.531e+00   0.289  0.77239    
##genreDocumentary                8.187e+00  3.630e+00   2.255  0.02445 *  
##genreDrama                      1.751e+00  1.327e+00   1.319  0.18756    
##genreHorror                    -6.791e-01  2.257e+00  -0.301  0.76362    
##genreMusical & Performing Arts  8.147e+00  3.147e+00   2.589  0.00985 ** 
##genreMystery & Suspense        -2.891e-01  1.695e+00  -0.171  0.86462    
##genreOther                      6.906e-01  2.616e+00   0.264  0.79190    
##genreScience Fiction & Fantasy -3.348e+00  3.288e+00  -1.018  0.30898    
##runtime                         2.253e-02  2.208e-02   1.020  0.30801    
##imdb_num_votes                  1.798e-05  4.037e-06   4.454 9.98e-06 ***
##critics_ratingFresh            -3.830e-01  1.127e+00  -0.340  0.73416    
##critics_ratingRotten           -7.227e+00  1.191e+00  -6.067 2.25e-09 ***
##audience_ratingUpright          2.897e+01  9.128e-01  31.740  < 2e-16 ***
##best_pic_winyes                -9.016e-01  3.920e+00  -0.230  0.81816    
##best_actor_winyes               8.810e-01  1.087e+00   0.811  0.41787    
##best_actress_winyes            -5.768e-01  1.207e+00  -0.478  0.63280    
##best_dir_winyes                 1.256e+00  1.603e+00   0.784  0.43345    
##---
##Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

##Residual standard error: 9.191 on 627 degrees of freedom
##Multiple R-squared:  0.7999,	Adjusted R-squared:  0.7932 
##F-statistic: 119.4 on 21 and 627 DF,  p-value: < 2.2e-16

We add audience rating as the second predictor because of the lowest p value.

fit2 <- lm(audience_score ~ imdb_rating + audience_rating, data=train)
summary(fit2)

##Call:
##lm(formula = audience_score ~ imdb_rating + audience_rating, 
##    data = train)

##Residuals:
##     Min       1Q   Median       3Q      Max 
##-22.1619  -4.7622   0.6187   4.3354  24.2864 

##Coefficients:
##                       Estimate Std. Error t value Pr(>|t|)    
##(Intercept)            -11.4476     2.0110  -5.693  1.9e-08 ***
##imdb_rating              9.5122     0.3505  27.142  < 2e-16 ***
##audience_ratingUpright  20.8687     0.7676  27.188  < 2e-16 ***
##---
##Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

##Residual standard error: 6.952 on 646 degrees of freedom
##Multiple R-squared:  0.8821,	Adjusted R-squared:  0.8817 
##F-statistic:  2416 on 2 and 646 DF,  p-value: < 2.2e-16

The models’ R-squared and Adjusted R-Squared both increased significantly, the almost zero p value indicate that audience rating is another statistically significant predictor of audience score.

After the above second fit, I did the following attempts:

Added critics rating to the model but the Adjust R-squared only increased from 0.8817 to 0.8819, the p value is insignificant at 0.61896 and 0.10116. Therefore, we will not include critics rating as a predictor.
Added imdb_num_votes to the model but the Adjust R-squared decreased from 0.8817 to 0.8815 and the p value is not significant at 0.734. So, we will not include imdb_num_votes to the model.
Added genre to the model and the Adjust R-squared increased from 0.8817 to 0.8847, the amount varaince it explains at 0.8868 versus 0.8812 without. From the anova analysis we can see that the p value is significant at 0.0033.
It is obvious that title type, runtime, best_pic_win, best_actor_win, best_actress_win, best_dir_win are not significant predictors, therefore, they will not be included in the model.

fit3 <- lm(audience_score ~ imdb_rating + audience_rating + genre, data=train)
anova(fit3)

##Analysis of Variance Table

##Response: audience_score
##                 Df Sum Sq Mean Sq   F value    Pr(>F)    
##imdb_rating       1 197779  197779 4198.2813 < 2.2e-16 ***
##audience_rating   1  35724   35724  758.3151 < 2.2e-16 ***
##genre            10   1259     126    2.6722  0.003309 ** 
##Residuals       636  29962      47                        
##---
##Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Therefore, I decide to add genre as one of the prdictors. So, I arrived at our final model - Parsimonious Model, with three predictors: imdb rating, audience rating and genre.

summary(fit3)

##Call:
##lm(formula = audience_score ~ imdb_rating + audience_rating + 
##    genre, data = train)

##Residuals:
##     Min       1Q   Median       3Q      Max 
##-21.6679  -4.4091   0.6113   4.3309  25.0302 

##Coefficients:
##                               Estimate Std. Error t value Pr(>|t|)    
##(Intercept)                    -12.5142     2.1981  -5.693 1.91e-08 ***
##imdb_rating                      9.7844     0.3705  26.407  < 2e-16 ***
##audience_ratingUpright          20.3246     0.7751  26.222  < 2e-16 ***
##genreAnimation                   3.6812     2.4546   1.500   0.1342    
##genreArt House & International  -2.7199     2.0368  -1.335   0.1822    
##genreComedy                      1.5684     1.1320   1.386   0.1664    
##genreDocumentary                 0.6890     1.3789   0.500   0.6175    
##genreDrama                      -0.7612     0.9677  -0.787   0.4318    
##genreHorror                     -1.5608     1.6733  -0.933   0.3513    
##genreMusical & Performing Arts   2.6242     2.1958   1.195   0.2325    
##genreMystery & Suspense         -3.2036     1.2529  -2.557   0.0108 *  
##genreOther                       0.3460     1.9302   0.179   0.8578    
##genreScience Fiction & Fantasy   0.3138     2.4440   0.128   0.8979    
##---
##Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

##Residual standard error: 6.864 on 636 degrees of freedom
##Multiple R-squared:  0.8868,	Adjusted R-squared:  0.8847 
##F-statistic: 415.3 on 12 and 636 DF,  p-value: < 2.2e-16

Interpretation of the model:

Intercept(-12.5142) is the estimated audience score for a movie with imdb_rating, audience_rating and genre at zero. It does not provide any meaningful interpretation here.
imdb_rating coefficient(9.7844): All else hold constant, for every one unit increase in imdb_rating, the model predicts a 9.7844 increase in audience_score on average.
audience_ratingUpright coefficient(20.3246): All else hold constant, the model predicts rating Upright movie is 20.3246 higher in audience score on average than rating Spilled movie.
genreAnimation coefficient(3.6812): The model predicts that Animation films get an audience score that is 3.6812 higher than Action & Adventure(reference category) films on average after controlling for imdb_rating and audience rating.
genreArt House & International coefficient(-2.7199): The model predicts that Art House & International films get an audience score that is 2.7199 lower than Action & Adventure films on average after controlling for imdb_rating and audience rating.
There are total 11 genre categories in the dataset, the audience score can higher or lower than Action & Adventure films depends on what genre is selected.
R-Squared(0.8847): 88.47% of the variablity in audience score can be explained by the model.

Model diagnostics

ggplot(data = fit3, aes(x = .fitted, y = .resid)) +
  geom_point() +
  geom_hline(yintercept = 0, linetype = "dashed") +
  xlab("Fitted values") +
  ylab("Residuals")

There is clear a linear relationship between imdb rating and audience score. The linearity condition is met by our model.

Constant variance of residuals condition met, No fan shape in residuals plot.

ggplot(data = fit3, aes(x = .resid)) +
  geom_histogram(binwidth = 1, fill='white', color='black') +
  xlab("Residuals")

ggplot(data = fit3, aes(sample = .resid)) +
  stat_qq()

The residuals are nearly symmetric, hence it would be appropriate to deem the the normal distribution of residuals condition met.

Part 5: Prediction

We are going to use the final model(fit3) to predict the audience score for the movie in the test set - Aliens. First we create a new dataframe for this movie.

newmovie <- test %>% select(genre, imdb_rating, audience_rating)
predict(fit3, newmovie)

##89.99899

The model predicts movie Aliens in the test set will have an audience score at approximate 90.

predict(fit3, newmovie, interval = "prediction", level = 0.95)

##       fit      lwr     upr
##1 89.99899 76.34498 103.653

Our model predicts, with 95% confidence, that the movie Aliens is expected to have an audience score between 76.34 and 103.65.

test$audience_score

##[1] 94

The actual audience score for this movie is 94. Our prediction interval contains this value.

Part 6: Conclusion

Our model demonstrates that it is possible to predict a movie’s popularity, as measured by audience score with only three predictors - imdb score, audience rating and genre. Movie industries can use the similar methods when producing movies that are more likely to be liked by the target audience.

However, the potential shortcoming is that our model’s predictive power is limited because the sample data is not representative. Therefore, a larger number of observations to capture more variability in the population data in our testing data set is required to have a better measure of the model’s accuracy.

Modeling and prediction for movies was originally published by Susan Li at Susan Li | Data Ninja on June 28, 2017.

United Nations General Assembly Voting Data Analysis

2017-06-20T00:00:00+00:00

I recently came across a R package called “unvote” that consists the voting history of countries in the United Nations General Assembly from 1946 to 2015. The packaged was developed by David Robinson.

Explore the data

library(ggplot2)
library(unvotes)
library(dplyr)
library(lubridate)
library(ggthemes)
library(tidyr)

The package contains three data set. The first is the history of each country’s vote, with more than 700,000 rows.

un_votes

### A tibble: 738,764 × 4
##    rcid                  country country_code   vote
##   <int>                    <chr>        <chr> <fctr>
##1      3 United States of America           US    yes
##2      3                   Canada           CA     no
##3      3                     Cuba           CU    yes
##4      3                    Haiti           HT    yes
##5      3       Dominican Republic           DO    yes
##6      3                   Mexico           MX    yes
##7      3                Guatemala           GT    yes
##8      3                 Honduras           HN    yes
##9      3              El Salvador           SV    yes
##10     3                Nicaragua           NI    yes
### ... with 738,754 more rows

The second dataset contains information about each roll call vote, including the date, description, and relevant resolution that was voted on.

un_roll_calls

### A tibble: 5,429 × 9
##    rcid session importantvote       date   unres amend  para
##   <int>   <dbl>         <dbl>     <date>   <chr> <dbl> <dbl>
##1      3       1             0 1946-01-01  R/1/66     1     0
##2      4       1             0 1946-01-02  R/1/79     0     0
##3      5       1             0 1946-01-04  R/1/98     0     0
##4      6       1             0 1946-01-04 R/1/107     0     0
##5      7       1             0 1946-01-02 R/1/295     1     0
##6      8       1             0 1946-01-05 R/1/297     1     0
##7      9       1             0 1946-02-05 R/1/329     0     0
##8     10       1             0 1946-02-05 R/1/361     1     1
##9     11       1             0 1946-02-05 R/1/376     0     0
##10    12       1             0 1946-02-06 R/1/394     1     1
### ... with 5,419 more rows, and 2 more variables: short <chr>, descr <chr>

The last data set contains relationships between each vote and six issues, they are “Palestinian conflict”, “Nuclear weapons and nuclear material”, “Arms control and disarmament”, “Human rights”, “Colonialism” and “Economic development”.

un_roll_call_issues

### A tibble: 5,281 × 3
##    rcid short_name                issue
##   <int>      <chr>                <chr>
##1   3372         me Palestinian conflict
##2   3658         me Palestinian conflict
##3   3692         me Palestinian conflict
##4   2901         me Palestinian conflict
##5   3020         me Palestinian conflict
##6   3217         me Palestinian conflict
##7   3298         me Palestinian conflict
##8   3429         me Palestinian conflict
##9   3558         me Palestinian conflict
##10  3625         me Palestinian conflict
### ... with 5,271 more rows

First, which issue(issues) have been voted the most?

un_roll_call_issues %>% count(issue, sort=TRUE)

### A tibble: 6 × 2
##                                 issue     n
##                                 <chr> <int>
##1                 Palestinian conflict  1104
##2                          Colonialism   991
##3                         Human rights   986
##4         Arms control and disarmament   956
##5 Nuclear weapons and nuclear material   762
##6                 Economic development   482

How often a country voted “yes” from 1946 to 2015?

by_country <- un_votes %>% group_by(country) %>% summarize(votes = n(),
pct_yes = mean(vote == 'yes'))
by_country

### A tibble: 200 × 3
##               country votes   pct_yes
##                 <chr> <int>     <dbl>
##1          Afghanistan  4972 0.8417136
##2              Albania  3514 0.7157086
##3              Algeria  4527 0.8981666
##4              Andorra  1564 0.6445013
##5               Angola  3075 0.9219512
##6  Antigua and Barbuda  2658 0.9194883
##7            Argentina  5361 0.7789591
##8              Armenia  1629 0.7587477
##9            Australia  5399 0.5523245
##10             Austria  4939 0.6329216
### ... with 190 more rows

Percentage yes vote high countries from 1946 to 2015

arrange(by_country, desc(pct_yes))

### A tibble: 200 × 3
##                 country votes   pct_yes
##                   <chr> <int>     <dbl>
##1             Seychelles  1790 0.9782123
##2            Timor-Leste   837 0.9701314
##3  Sao Tome and Principe  2389 0.9673504
##4             Cabo Verde  3292 0.9599028
##5               Djibouti  3345 0.9563528
##6          Guinea Bissau  3070 0.9560261
##7                Comoros  2530 0.9450593
##8             Mozambique  3456 0.9427083
##9   United Arab Emirates  4031 0.9414537
##10              Suriname  3410 0.9410557
# ... with 190 more rows

Percentage yes vote low countries from 1946 to 2015

by_country[order(by_country$pct_yes),]

### A tibble: 200 × 3
##                                                country votes   pct_yes
##                                                  <chr> <int>     <dbl>
##1                                              Zanzibar     2 0.0000000
##2                              United States of America  5390 0.2836735
##3                                                 Palau   896 0.3225446
##4                                                Israel  4944 0.3460761
##5                           Federal Republic of Germany  2067 0.3962264
##6                      Micronesia (Federated States of)  1462 0.4138167
##7  United Kingdom of Great Britain and Northern Ireland  5372 0.4285182
##8                                                France  5325 0.4336150
##9                                      Marshall Islands  1600 0.4893750
##10                                              Belgium  5391 0.4952699
### ... with 190 more rows

Percentage yes vote high countries and years

join1 <- un_votes %>% inner_join(un_roll_calls, by = 'rcid')
by_country_year <- join1 %>% group_by(country, year=year(date)) %>% summarise(votes=n(), pct_yes = mean(vote=='yes'))
arrange(by_country_year, desc(pct_yes))

##Source: local data frame [9,689 x 4]
##Groups: country [200]

##       country  year votes pct_yes
##         <chr> <dbl> <int>   <dbl>
##1  Afghanistan  2002    40       1
##2  Afghanistan  2004    58       1
##3      Albania  1990    83       1
##4       Angola  1976     4       1
##5       Angola  1977    50       1
##6   Azerbaijan  2013    56       1
##7      Bahrain  1990    86       1
##8      Bahrain  1991    73       1
##9      Bahrain  1992    70       1
##10     Bahrain  1993    60       1
# ... with 9,679 more rows

Percentage yes vote low countries and years

by_country_year[order(by_country_year$pct_yes),]

##Source: local data frame [9,689 x 4]
##Groups: country [200]

##                            country  year votes    pct_yes
##                              <chr> <dbl> <int>      <dbl>
##1  Democratic Republic of the Congo  1998     1 0.00000000
##2                            Jordan  1955     6 0.00000000
##3                           Liberia  1998     1 0.00000000
##4                      South Africa  1974     2 0.00000000
##5                             Spain  1955     5 0.00000000
##6                         Sri Lanka  1955     5 0.00000000
##7                        Yugoslavia  1992     2 0.00000000
##8                          Zanzibar  1963     2 0.00000000
##9          United States of America  1989   115 0.08695652
##10         United States of America  1988   134 0.09701493
### ... with 9,679 more rows

Let’s look at three countries - Canada, US and UK’s “Yes” vote trend in percent over year.

countries <- c('Canada', 'United States of America', 'United Kingdom of Great Britain and Northern Ireland')
by_country_year %>% filter(country %in% countries) %>% 
  ggplot(aes(x=year, y=pct_yes, color=country)) + geom_line() + 
  ylab("% of votes are 'Yes'") + ggtitle("Trend in percentage Yes Votes of Canada, US and UK 1946-2015") + theme_bw()

Let’s look at those six issues, how were they voted overtime by the above three countries?

join1 %>% filter(country %in% countries) %>% 
  inner_join(un_roll_call_issues, by='rcid') %>% 
  group_by(year=year(date), country, issue) %>% 
  summarise(votes=n(), pct_yes=mean(vote=='yes')) %>% 
  ggplot(aes(x=year, y=pct_yes, color=country)) + 
  geom_point() + 
  geom_smooth(se=FALSE) + facet_wrap(~issue) + ylab("% of votes are 'Yes'") +
  ggtitle('Trend in Percentage Yes Votes by Issues for Canada, US and UK')

Among these three countries, which countries voted “yes” the most and the least for what issues?

join2 <- join1 %>% filter(country %in% countries) %>% 
  inner_join(un_roll_call_issues, by='rcid') %>% 
  group_by(country, issue) %>% 
  summarise(votes=n(), pct_yes=mean(vote=='yes'))

ggplot(aes(x=country, y=pct_yes, fill = issue), data = join2) + geom_bar(stat = 'identity', position = position_dodge()) + ggtitle('Canada, US, UK and the UN Issues')

Let’s try to estimate the probability of these three countries’ changes in voting yes to the UN issues(i.e.whether there is a correlation between trend in year and percentage yes vote’)

us_by_year <- by_country_year %>% filter(country=='United States of America')
ca_by_year <- by_country_year %>% filter(country=='Canada')
uk_by_year <- by_country_year %>% filter(country=='United Kingdom of Great Britain and Northern Ireland')
us_model <- lm(pct_yes ~ year, data=us_by_year)
ca_model <- lm(pct_yes ~ year, data=ca_by_year)
uk_model <- lm(pct_yes ~ year, data = uk_by_year)
us_prob <- tidy(us_model) %>% filter(term=='year')
ca_prob <- tidy(ca_model) %>% filter(term=='year')
uk_prob <- tidy(uk_model) %>% filter(term=='year')
us_prob
ca_prob
uk_prob

##us_prob
##  term     estimate    std.error statistic      p.value
##1 year -0.007103352 0.0006991439 -10.16007 3.357004e-15
##  ca_prob
##  term      estimate    std.error  statistic   p.value
##1 year -0.0001975947 0.0006603795 -0.2992139 0.7657031
##  uk_prob
##  term   estimate    std.error statistic  p.value
##1 year 0.00103754 0.0007739133  1.340641 0.184565

Interpretation of the results

For the USA, the probablity of voting yes to UN issues will decrease 0.0071 percent in the coming years; trend in year and percentage yes vote are highly correlated.
For Canada, the probability of voting yes to UN issues will decrease 0.0002 percent in the coming years, and there is no correlation between trend in year and percentage yes vote.
For the UK, the probability of voting yes to UN issues will decrease 0.001 percent in the coming years, and there is no correlation between trend in year and percentage yes vote.

The End

I realized that this package allows me to perform several statistical analysises including linear regression, logistic regression and I will save it to the next time.

United Nations General Assembly Voting Data Analysis was originally published by Susan Li at Susan Li | Data Ninja on June 20, 2017.

Statistical inference with the General Social Survey Data

2017-06-07T00:00:00+00:00

Setup

Load packages

library(ggplot2)
library(dplyr)
library(statsr)

Load data

load("gss.rdata")

Part 1: Data

Background

The General Social Survey (GSS) is a sociological survey used to collect information and keep a historical record of the concerns, experiences, attitudes, and practices of residents of the United States. GSS questions cover a diverse range of issues including national spending priorities, marijuana use, crime and punishment, race relations, quality of life, confidence in institutions, and sexual behavior. The dataset used for this project is an extract of the General Social Survey (GSS) Cumulative File 1972-2012. It consists of 57061 observations with 114 variables. Each variable corresponds to a specific question asked to the respondent.

Methodology

According to Wikipedia, The GSS survey is conducted face-to-face with an in-person interview by NORC at the University of Chicago. The target population is adults (18+) living in households in the United States. Respondents are random sampled from a mix of urban, suburban, and rural geographic areas. Participation in the study is strictly voluntary.

The scope of inference

The sample data should allow us to generalize to the population of interest. It is a survey of 57061 U.S adults aged 18 years or older. The survey is based on random sampling. However, there is no causation can be established as GSS is an observation study that can only establish correlation/association between variables. In addition, potential biases are associated with non-response because this is a voluntary in-person survey that takes approximately 90 minutes. Some potential respondents may choose not to participate.

Part 2: Research questions

Research Question 1: Do Americans distrust the media? That is, correlation between reading news and confidence in press.

According to Financial Times, Public trust in traditional media has fallen to an all-time low as people increasingly favour their friends and contacts on the internet as sources of news. This has prompted me to learn how frequency of reading news may impact a person’s confidence in press. Based on above question, the analysis will be based on the following variables:

news - How often does respondent read newspaper.
conpress - Confidence in press.

To reflect the most recent trends, I will only keep the data from year 2010 and removing all “NA”s.

gss_con <- gss[ which(gss$year >= 2010 & !is.na(gss$news) & !is.na(gss$conpress)), ]
gss_con <- gss_con %>% select(news, conpress)
dim(gss_con)

##[1] 1398    2

Exploratory data analysis for Research Question 1

The data I will be using for this analysis has 1398 observations. Here is the summary and two-way table.

summary(gss_con)

##               news             conpress  
## Everyday         :452   A Great Deal:129  
## Few Times A Week :241   Only Some   :612  
## Once A Week      :192   Hardly Any  :657  
## Less Than Once Wk:224                     
## Never            :289

table(gss_con$news, gss_con$conpress)

##                 A Great Deal Only Some Hardly Any
##  Everyday                    50       206        196
##  Few Times A Week            18       111        112
##  Once A Week                 19        85         88
##  Less Than Once Wk           18        97        109
##  Never                       24       113        152

plot(table(gss_con$news, gss_con$conpress))

Mosaic plots provide a way to visualize contingency tables. If we compare the mosaic plot to the table of counts, the size of the boxes are related to the counts in the table. We can see that the number of respondents who read every day and only have some confidence in press are the highest, and the number of respondents who read few times a week and have great confidence in press are the lowest.

ggplot(aes(x=news), data=gss_con) + geom_bar(aes(fill=conpress), position = position_dodge()) + ggtitle('Frequency of Reading News vs. Confidence in Press')

Observations:

The number of respondents who have a great deal of confidence in press are consistently lowest across all groups of news readers.
The number of respondents who hardly have any confidence in press are highest in three group of news readers - “Never”, “Less than Once Wk” and “Once A Week”.

Inference for Research Question 1

State hypothesis

Null Hypothesis: Frequency of reading news and confidence in press are independent. Frequency of reading news does not vary by confidence in press.
Alternative Hypothesis: Frequency of reading news and confidence in press are dependent. Frequency of reading news does vary by confidence in press.

Check conditions

The survey respondents were random sampled, we can assume the independence.
If sampling without replacement, n < 10% of population. The 1398 observations met this requirement.
Each case only contribute to one cell in the table. Because the independence requirement has been met, we can check this as well.
Each cell must have at least 5 expected cases. From below table, it is clear that it meets the requirement.

gss_con_table <- table(gss_con$news, gss_con$conpress)
Xsq <- chisq.test(gss_con_table)
Xsq$expected

##             A Great Deal Only Some Hardly Any
##  Everyday              41.70815 197.87124  212.42060
##  Few Times A Week      22.23820 105.50215  113.25966
##  Once A Week           17.71674  84.05150   90.23176
##  Less Than Once Wk     20.66953  98.06009  105.27039
##  Never                 26.66738 126.51502  135.81760

State method to be used and why and how

The method used here is Chi-Square Independence Test since we are quantifying how different the observed counts are from the expected counts and we are evaluating relationship between two categorical variables.

Perform inference

(Xsq <- chisq.test(gss_con_table))

##Pearson's Chi-squared test

##data:  gss_con_table
##X-squared = 8.6459, df = 8, p-value = 0.373

The Chi-Squre statistic is 8.6459, degree of freedom is 8 and the associated P value is larger than the significance level of 0.05.

Interpret results

We failed to reject null hypothesis, the data does not provide convincing evidence that the frequency of reading news and confidence in press are associated.

Research Question 2: Does marital status have impact on financial satisfaction?

According to a report from The National Center for Biotechnology Information (NCBI), people who are financially satisfied tend to be more stable in their marriages. I am interested to find out whether satisfaction in financial situation is associated with marital status, by analyzing GSS data. I will be using the following variables for this analysis:

marital - Marital status
satfin - Satifaction with financial situation

I will remove “NA”s and keep all years data.

Exploratory data analysis for Research Question 2

gss_ma <- gss[ which(!is.na(gss$marital) & !is.na(gss$satfin)), ]
gss_ma <- gss_ma %>% select(marital, satfin)
dim(gss_ma)

##[1] 52441     2

The data I will be using for this analysis have 52441 observations. Here is the summary and two-way table.

summary(gss_ma)
table(gss_ma$marital, gss_ma$satfin)

## marital                 satfin     
## Married      :28417   Satisfied     :15341  
## Widowed      : 5171   More Or Less  :23172  
## Divorced     : 6362   Not At All Sat:13928  
## Separated    : 1833                         
## Never Married:10658

##              Satisfied More Or Less Not At All Sat
##  Married            9281        13002           6134
##  Widowed            1925         2150           1096
##  Divorced           1256         2660           2446
##  Separated           253          736            844
##  Never Married      2626         4624           3408

plot(table(gss_ma$marital, gss_ma$satfin))

Interesting to see that the number of respondents who are “married” and “satisfied” are not the highest across all the groups. Seems people are hard to please.

ggplot(aes(x=marital), data=gss_ma) + geom_bar(aes(fill=satfin), position = position_dodge()) + ggtitle('Marital Status vs. Financial Satisfaction')

Observations:

The number of respondents who are more or less satisfied with financial situation are the highest across all groups of marital status except “Separated” group.
The number of respondents who are not at all satisfied with financial situation are lowest in “Married” and “Widowed” groups.
The number of respondents who are satisfied with financial situation are lowest in “Never Married”, “Separated” and “Divorced” groups.

Inference for Research Question 2

State hypothesis

Null Hypothesis: Marital status and satisfaction with financial situation are independent. Satisfaction with financial situation does not vary by marital status.
Alternative Hypothesis: Marital status and satisfaction with financial situation are dependent. Satisfaction with financial situation does vary by marital status.

Check conditions

The independence and sampling population (n < 10%) have been discussed earlier.
Each cell must have at least 5 expected cases. From below table, it is clear that it meets the requirement

gss_ma_table <- table(gss_ma$marital, gss_ma$satfin)
Xsq1 <- chisq.test(gss_ma_table)
Xsq1$expected

##              Satisfied More Or Less Not At All Sat
##  Married       8313.0603   12556.5631      7547.3766
##  Widowed       1512.7155    2284.8994      1373.3851
##  Divorced      1861.1285    2811.1642      1689.7072
##  Separated      536.2227     809.9441       486.8333
##  Never Married 3117.8730    4709.4292      2830.6978

State method to be used and why and how

Again, the method used here is Chi-Square Independence Test since we are quantifying how different the observed counts are from the expected counts and we are evaluating relationship between two categorical variables.

Perform inference

(Xsq1 <- chisq.test(gss_ma_table))

##Pearson's Chi-squared test

##data:  gss_ma_table
##X-squared = 1728.2, df = 8, p-value < 2.2e-16

The Chi-Squre statistic is 1728.2, degree of freedom is 8 and the associated P value is almost 0.

Interpret results

With such a small P value, We reject null hypothesis in favor of alternative hypothesis and conclude that satisfaction with financial situation and marital status are dependent. The study is observational, so we can only establish association but not causation between these two variables.

Research Question 3: Income disparity among races

The existence of racial wage gap in America has been documented by many scholars and written about in many journals. Some research finds that the racial wage gap is focused in the private sector. How about U.S citizen in general? I am interested in drawing statistical inference using GSS data to compare family income between difference races. I will be using the following variables for this analysis:

race: Race of respondent
coninc: Total family income in constant dollars

Again, remove all “NA”s and keep data for all the years.

Exploratory data analysis for Research Question 3

gss_in <- gss[ which(!is.na(gss$race) & !is.na(gss$coninc)), ]
gss_in <- gss_in %>% select(race, coninc)
dim(gss_in)

##[1] 51232     2

The data I will be using for this analysis has 51232 observations and 2 variables.

ggplot(aes(x=race, y=coninc), data=gss_in) + geom_boxplot() + ggtitle('Race vs. Family Income Boxplot')
by(gss_in$coninc, gss_in$race, summary)

##gss_in$race: White
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##    383   20129   38414   47007   62946  180386 
##-------------------------------------------------------------- 
##gss_in$race: Black
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##    383    9953   21959   30185   41523  180386 
##-------------------------------------------------------------- 
##gss_in$race: Other
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##    383   15572   30861   42415   56059  180386

Observations:

The distribution of total family incomce for all race groups are right skewed.
The White group has the highest total family income in first quartile, median, mean and 3rd quartile.
The Black group has the least variability in total family income.

Inference for Research Question 3

State hypothesis

Null Hypothesis: The average total family income is the same across all the race groups.
Alternative Hypothesis: The average total family income differ between at least one pair of the race groups.

Check conditions

The survey respondents were random sampled and the samples are less than 10% of population. So the condition of independence within group is met.
We have three race groups and they are independent of each other.
Distribution of response variable in each race group should be approximately normal. Unfortunatley, from below QQ plot, we can see all three groups have quite a bit divergence from normality in the upper tail.

qqnorm(gss_in$coninc[gss_in$race=='White'], main="White")
qqline(gss_in$coninc[gss_in$race=='White'])

qqnorm(gss_in$coninc[gss_in$race=='Black'], main="Black")
qqline(gss_in$coninc[gss_in$race=='Black'])

qqnorm(gss_in$coninc[gss_in$race=='Other'], main="Other")
qqline(gss_in$coninc[gss_in$race=='Other'])

Variability should be consistent across groups. From above boxplot, it seems that the variability is consistent across “White” and “Other” groups, but it is much lower for the “Black” group.

Although the assumptions of ANOVA did not meet, I will still go ahead to perform ANOVA but I have to be very careful in interpreting the results.

State method to be used and why and how

We compare average family income from more than two groups, - “White”, “Black” and “Other”. We want to know whether those three means are so far apart that the observed differences cannot all reasonably be attributed to sampling variability. So we use ANOVA.

mod <- lm(coninc ~ race, data = gss_in)
anova(mod)

##Analysis of Variance Table

##Response: coninc
##             Df     Sum Sq    Mean Sq F value    Pr(>F)    
##race          2 1.6989e+12 8.4944e+11  675.08 < 2.2e-16 ***
##Residuals 51229 6.4461e+13 1.2583e+09                      
##---
##Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Interpret results

With such a small P value (almost 0), we reject the null hypothesis, we have sufficient evidence that at least one pair of race groups’ population average family income are different from each other. But we don’t know which pair of groups.

Since the results of ANOVA was significant, we are safe to continue with our pairwise comparisons to find out which pair of groups have difference income.

pairwise.t.test(gss_in$coninc, gss_in$race, p.adj ='bonferroni')

##Pairwise comparisons using t tests with pooled SD 

##data:  gss_in$coninc and gss_in$race 

##      White   Black  
##Black < 2e-16 -      
##Other 1.4e-09 < 2e-16

##P value adjustment method: bonferroni

Using the Bonferroni adjustment, all group pairs, White-Black, White-Other, Black-Other comparisons are statistically significant. We are using a more stringent and conservative correction (Bonferroni adjustment) and we still got very small P values, therefore, we can reject the null hypothesis again.

Confidence Interval

As a last step, calculate confidence interval for one pairwise group difference - “White” and “Other”.

gss_in_w_o <- subset(gss_in, race== 'White' | race=='Other', select=c(race, coninc))
gss_in_w_o <- droplevels(gss_in_w_o)
inference(y = coninc, x = race, data = gss_in_w_o, statistic = "mean", type = "ci", conf_level = 0.95, method = "theoretical")

##Response variable: numerical, Explanatory variable: categorical (2 levels)
##n_White = 41824, y_bar_White = 47006.7433, s_White = 36405.4758
##n_Other = 2452, y_bar_Other = 42415.4274, s_Other = 38105.4353
##95% CI (White - Other): (3042.4667 , 6140.165)

Conclusion

We are 95% confident that the average total family income of the “White” group was $3042 to $6140 higher than the “Other” group per year.

Here we performed ANOVA to assess whether a significant difference exists at all amongst the groups, whereas the pairwise comparisons were used to determine which group differences are statistically significant. Although our data have significant divergence from normality for all three race groups, ANOVA is considered a robust test against the normality assumption.

References:

Wikipedia

GSS General Social Survey

Pearson’s Chi-squared test for count data

Stackoverflow

R-bloggers

Statistical inference

Statistical inference with the General Social Survey Data was originally published by Susan Li at Susan Li | Data Ninja on June 07, 2017.

Text Mining 40 Years of Warren Buffett's Letters to Shareholders

2017-05-31T00:00:00+00:00

Warren Buffett released the most recent version of his annual letter to Berkshire Hathaway shareholders a couple of months ago. After reading a post regarding a sentiment analysis of Mr Warren Buffett’s annual shareholder letters, and I am also learning text mining with R. I thought it is a great opportunity to apply my latest skills into practice, - text mining 40 years of Warren Buffett’s letters to shareholders.

library(dplyr)
library(ggplot2)
library(tidyr)
library(tidytext)
library(pdftools)
library(rvest)
library(XML)
library(stringr)
library(ggthemes)

The code I used here to download all the letters were borrowed from Michael Toth.

urls_77_97 <- paste('http://www.berkshirehathaway.com/letters/', seq(1977, 1997), '.html', sep='')
html_urls <- c(urls_77_97,
               'http://www.berkshirehathaway.com/letters/1998htm.html',
               'http://www.berkshirehathaway.com/letters/1999htm.html',
               'http://www.berkshirehathaway.com/2000ar/2000letter.html',
               'http://www.berkshirehathaway.com/2001ar/2001letter.html')

letters_html <- lapply(html_urls, function(x) read_html(x) %>% html_text())

# Getting & Reading in PDF Letters
urls_03_16 <- paste('http://www.berkshirehathaway.com/letters/', seq(2003, 2016), 'ltr.pdf', sep = '')
pdf_urls <- data.frame('year' = seq(2002, 2016),
                       'link' = c('http://www.berkshirehathaway.com/letters/2002pdf.pdf', urls_03_16))

download_pdfs <- function(x) {
  myfile = paste0(x['year'], '.pdf')
  download.file(url = x['link'], destfile = myfile, mode = 'wb')
  return(myfile)
}

pdfs <- apply(pdf_urls, 1, download_pdfs)
letters_pdf <- lapply(pdfs, function(x) pdf_text(x) %>% paste(collapse=" "))
tmp <- lapply(pdfs, function(x) if(file.exists(x)) file.remove(x)) # Clean up directory

# Combine all letters in a data frame
letters <- do.call(rbind, Map(data.frame, year=seq(1977, 2016), text=c(letters_html, letters_pdf)))
letters$text <- as.character(letters$text)

Now I am ready to use “unnest_tokens” to split the dataset(all the letters) into tokens and remove stop words.

letter_words <- letters %>%
  unnest_tokens(word, text) %>%
  filter(str_detect(word, "[a-z']$"),
         !word %in% stop_words$word)

The most common words throughout 40 years of letters

letter_words %>% 
  count(word, sort=TRUE)

### A tibble: 14,788 × 2
##         word     n
##        <chr> <int>
##1    business  2143
##2   berkshire  1992
##3    earnings  1863
##4     company  1241
##5     million  1224
##6   insurance  1171
##7  businesses   982
##8   companies   823
##9      market   771
##10    billion   760
### ... with 14,778 more rows

letter_words %>%
  count(word, sort = TRUE) %>%
  filter(n > 600) %>%
  mutate(word = reorder(word, n)) %>%
  ggplot(aes(word, n)) +
  geom_col() +
  xlab(NULL) +
  coord_flip() + ggtitle("The Most Common Words in Buffett's Letters") + theme_minimal()

The most common words each year

words_by_year <- letter_words %>%
  count(year, word, sort = TRUE) %>%
  ungroup()
words_by_year

### A tibble: 83,537 × 3
##    year      word     n
##   <int>     <chr> <int>
##1   2014 berkshire   203
##2   1985  business   112
##3   1983  business    97
##4   1984  business    96
##5   2014  business    92
##6   1990  business    90
##7   2015 berkshire    90
##8   1980  earnings    87
##9   2016 berkshire    86
##10  1989  business    85
### ... with 83,527 more rows

Sentiment by Year

Examine how often positive and negative words occurred in these letters. Which years were the most positive or negative overall?

AFINN lexion provides a positivity score for each word, from -5 (most negative) to 5 (most positive). What I am doing here is to calculate the average sentiment score for each year.

letters_sentiments <- words_by_year %>%
  inner_join(get_sentiments("afinn"), by = "word") %>%
  group_by(year) %>%
  summarize(score = sum(score * n) / sum(n))

letters_sentiments %>%
  mutate(year = reorder(year, score)) %>%
  ggplot(aes(year, score, fill = score > 0)) +
  geom_col(show.legend = FALSE) +
  coord_flip() +
  ylab("Average sentiment score") + 
  ggtitle("Sentiment Score of Buffett's Letters to Shareholders 1977-2016") + theme_minimal()

Warren Buffett is known for his long-term, optimistic economic outlook. Only 1 out of 40 letters appeared negative. Berkshire’s loss in net worth during 2001 was $3.77 billion, in addition, 911 terrorist attack contributed to the negative sentiment score in that year’s letter.

Sentiment Analysis by Words

Examine the total positive and negative contributions of each word.

contributions <- letter_words %>%
  inner_join(get_sentiments("afinn"), by = "word") %>%
  group_by(word) %>%
  summarize(occurences = n(),
            contribution = sum(score))
contributions

### A tibble: 1,225 × 3
##        word occurences contribution
##       <chr>      <int>        <int>
##1    abandon          4           -8
##2  abandoned          4           -8
##3      abhor          2           -6
##4  abilities         12           24
##5    ability         96          192
##6     aboard          3            3
##7   absentee          6           -6
##8   absorbed          3            3
##9      abuse          2           -6
##10    abuses          1           -3
### ... with 1,215 more rows

For example, word “abandon” appeared 4 times and contributed total -8 scores.

contributions %>%
  top_n(25, abs(contribution)) %>%
  mutate(word = reorder(word, contribution)) %>%
  ggplot(aes(word, contribution, fill = contribution > 0)) +
  geom_col(show.legend = FALSE) +
  coord_flip() + ggtitle('Words with the Most Contributions to Positive/Negative Sentiment Scores') + theme_minimal()

Word “outstanding” made the most positive contribution and word “loss” made the most negative contribution.

sentiment_messages <- letter_words %>%
  inner_join(get_sentiments("afinn"), by = "word") %>%
  group_by(year, word) %>%
  summarize(sentiment = mean(score),
            words = n()) %>%
  ungroup() %>%
  filter(words >= 5)
sentiment_messages %>%
  arrange(desc(sentiment))

### A tibble: 763 × 4
##    year        word sentiment words
##   <int>       <chr>     <dbl> <int>
##1   1979 outstanding         5     6
##2   1984 outstanding         5     7
##3   1986 outstanding         5     7
##4   1988      superb         5     5
##5   1989 outstanding         5     5
##6   1989      superb         5     6
##7   1992 outstanding         5     7
##8   1995 outstanding         5     9
##9   1996 outstanding         5     9
##10  1997 outstanding         5     5

Now we look for the words with the highest positive scores in each letter, here it is, “outstanding” appeared eight out of ten letters.

sentiment_messages %>% 
  arrange(sentiment)

### A tibble: 763 × 4
##    year    word sentiment words
##   <int>   <chr>     <dbl> <int>
##1   1979    loss        -3     5
##2   1980    loss        -3     6
##3   1981     bad        -3     7
##4   1982    loss        -3     6
##5   1983    loss        -3     8
##6   1984     bad        -3     5
##7   1984 charged        -3     6
##8   1984    loss        -3    23
##9   1985    loss        -3    18
##10  1986    loss        -3    15
### ... with 753 more rows

Unsurprisingly, seven out of ten letters, word “loss” secured the highest negative score.

From doing text mining Google finance articles a few days ago, I have learned another sentiment lexicon - “loughran”, which was developed based on analyses of financial reports. The Loughran dictionary divides words into six sentiments: “positive”, “negative”, “litigious”, “uncertainty”, “constraining”, and “superfluous”. I can’t wait to apply this dictionary to Buffett’s letters.

letter_words %>%
  count(word) %>%
  inner_join(get_sentiments("loughran"), by = "word") %>%
  group_by(sentiment) %>%
  top_n(5, n) %>%
  ungroup() %>%
  mutate(word = reorder(word, n)) %>%
  ggplot(aes(word, n)) +
  geom_col() +
  coord_flip() +
  facet_wrap(~ sentiment, scales = "free") +
  ggtitle("Frequency of This Word in Buffett's Letters") + theme_minimal()

The assignments of words to sentments look reasonable. However, it removed “outstanding” and “superb” from the positive sentiment.

Relationship Between Words

Now it is the most interesting part. By tokenizing text into consecutive sequences of words, we can examine how often one word is followed by another. We can then study the relationship between words.

In this case, defining a list of six words that are used in negative situation, such as “don’t”, “not”, “no”, “can’t”, “won’t” and “without”, and visualize the sentiment-associated words that most often followed them.

letters_bigrams <- letters %>%
  unnest_tokens(bigram, text, token = "ngrams", n = 2)
letters_bigram_counts <- letters_bigrams %>%
  count(year, bigram, sort = TRUE) %>%
  ungroup() %>%
  separate(bigram, c("word1", "word2"), sep = " ")
  
negate_words <- c("not", "without", "no", "can't", "don't", "won't")

letters_bigram_counts %>%
  filter(word1 %in% negate_words) %>%
  count(word1, word2, wt = n, sort = TRUE) %>%
  inner_join(get_sentiments("afinn"), by = c(word2 = "word")) %>%
  mutate(contribution = score * nn) %>%
  group_by(word1) %>%
  top_n(10, abs(contribution)) %>%
  ungroup() %>%
  mutate(word2 = reorder(paste(word2, word1, sep = "__"), contribution)) %>%
  ggplot(aes(word2, contribution, fill = contribution > 0)) +
  geom_col(show.legend = FALSE) +
  facet_wrap(~ word1, scales = "free", nrow = 3) +
  scale_x_discrete(labels = function(x) gsub("__.+$", "", x)) +
  xlab("Words followed by a negation") +
  ylab("Sentiment score * # of occurrences") +
  theme(axis.text.x = element_text(angle = 90, hjust = 1)) +
  coord_flip() + ggtitle("Words that contributed the most to sentiment when they followed a ‘negation'") + theme_minimal()

It looks like the largest sources of misidentifying a word as positive come from “no matter”, “no better”, “not worth”, “not good”, and the largest source of incorrectly classified negative sentiment is “no debt”, “no problem” and “not charged”.

Source code that created this post can be found here. I am happy to hear any feedback or questions.

Reference:

Text Mining with R

Text Mining 40 Years of Warren Buffett's Letters to Shareholders was originally published by Susan Li at Susan Li | Data Ninja on May 31, 2017.

Text Mining Finance News of Four Big American Companies

2017-05-24T00:00:00+00:00

There’s rightly been a lot of attention paid to text mining. Text mining is the data analysis of natural language works (articles, books, etc.), using text as a form of data, joined with the numeric analysis.

Two years ago, TheStreet claimed that Traders Are Using Text and Data Mining to Beat the Market. All this, and the sense of major things going on in the world, prompted me to see what I could find myself in the world of text mining.

library(tm.plugin.webmining)
library(purrr)
library(dplyr)
library(ggplot2)
library(ggthemes)
library(stringr)
library(tidyr)
library(tidytext)

Thus, I decided to analyze Google finance articles for the following American companies: Starbucks, Kraft, Wal-Mart and Mondelez.

company <- c("Starbucks", "Kraft", "Walmart", "Mondelez")
symbol <- c("SBUX", "KHC", "WMT", "MDLZ")
download_articles <- function(symbol) {
  WebCorpus(GoogleFinanceSource(paste0("NASDAQ:", symbol)))
}
stock_articles <- data_frame(company = company,
                             symbol = symbol) %>%
  mutate(corpus = map(symbol, download_articles))

Google Finance Articles

This allows me to retrieve the 20 most recent articles related to each stock.

stock_articles

### A tibble: 4 × 3
##    company symbol          corpus
##      <chr>  <chr>          <list>
##1 Starbucks   SBUX <S3: WebCorpus>
##2     Kraft    KHC <S3: WebCorpus>
##3   Walmart    WMT <S3: WebCorpus>
##4  Mondelez   MDLZ <S3: WebCorpus>

Tokens

A token is a meaningful unit of text, most often a word, that we are interested in using for further analysis, and tokenization is the process of splitting text into tokens. I need to use “unnest_tokens” to break text into individual tokens and transform it to a tidy data, that is one-row-per-term-per-document:

tokens <- stock_articles %>%
  unnest(map(corpus, tidy)) %>%
  unnest_tokens(word, text) %>%
  select(company, datetimestamp, word, id, heading)
tokens

### A tibble: 59,572 × 5
##     company       datetimestamp      word
##       <chr>              <dttm>     <chr>
##1  Starbucks 2017-05-23 04:37:30     tesla
##2  Starbucks 2017-05-23 04:37:30     forum
##3  Starbucks 2017-05-23 04:37:30   summary
##4  Starbucks 2017-05-23 04:37:30    mobile
##5  Starbucks 2017-05-23 04:37:30     order
##6  Starbucks 2017-05-23 04:37:30       app
##7  Starbucks 2017-05-23 04:37:30        is
##8  Starbucks 2017-05-23 04:37:30        an
##9  Starbucks 2017-05-23 04:37:30 important
##10 Starbucks 2017-05-23 04:37:30      long
### ... with 59,562 more rows, and 2 more variables: id <chr>, heading <chr>

tf_idf

article_tf_idf <- tokens %>%
  count(company, word) %>%
  filter(!str_detect(word, "\\d+")) %>%
  bind_tf_idf(word, company, n) %>%
  arrange(-tf_idf)
article_tf_idf

##Source: local data frame [9,966 x 6]
##Groups: company [4]

##     company          word     n          tf       idf      tf_idf
##       <chr>         <chr> <int>       <dbl>     <dbl>       <dbl>
##1      Kraft         heinz   128 0.014134276 1.3862944 0.019594267
##2  Starbucks     starbucks   284 0.016820659 0.6931472 0.011659192
##3      Kraft           khc    74 0.008171378 1.3862944 0.011327935
##4      Kraft         kraft   139 0.015348940 0.6931472 0.010639074
##5    Walmart          west    81 0.005955882 1.3862944 0.008256606
##6    Walmart environmental    78 0.005735294 1.3862944 0.007950806
##7    Walmart      mountain    87 0.006397059 0.6931472 0.004434103
##8  Starbucks          sbux   105 0.006218905 0.6931472 0.004310617
##9    Walmart      virginia    36 0.002647059 1.3862944 0.003669603
##10   Walmart        clarke    35 0.002573529 1.3862944 0.003567669
### ... with 9,956 more rows

Here we see all nouns, names that are important in these companies(articles). None of them occurred in all of the articles.

tf_idf, short for term frequency–inverse document frequency, is a numerical statistic that is intended to reflect how important a word is to a document in a collection or corpus.

Visualize these high tf-idf words.

plot_article <- article_tf_idf %>%
  arrange(desc(tf_idf)) %>%
  mutate(word = factor(word, levels = rev(unique(word))))
plot_article %>% 
  top_n(10) %>%
  ggplot(aes(word, tf_idf, fill = company)) +
  geom_col() +
  labs(x = NULL, y = "tf-idf") +
  coord_flip() + theme_minimal() + ggtitle('Highest tf_idf Words for Each Company')

Visualize the top terms for each company individually.

plot_article %>% 
  group_by(company) %>% 
  top_n(10) %>% 
  ungroup %>%
  ggplot(aes(word, tf_idf, fill = company)) +
  geom_col(show.legend = FALSE) +
  labs(x = NULL, y = "tf-idf") +
  facet_wrap(~company, ncol = 2, scales = "free") +
  coord_flip() + theme_minimal()

As we have expected, the company names, stock symbols, some of companies’ products and executives are usually included, as well as companies’ latest movements such as Wal-Mart’s climate pledges.

Sentiment

To see whether the finance news coverage is positive or negative for these four companies, I opted to use AFINN lexicons which provides a positivity score for each word, from -5 (most negative) to 5 (most positive) to do a simple sentiment analysis.

tokens %>%
  anti_join(stop_words, by = "word") %>%
  count(word, id, sort = TRUE) %>%
  inner_join(get_sentiments("afinn"), by = "word") %>%
  group_by(word) %>%
  summarize(contribution = sum(n * score)) %>%
  top_n(15, abs(contribution)) %>%
  mutate(word = reorder(word, contribution)) %>%
  ggplot(aes(word, contribution)) +
  geom_col() +
  coord_flip() +
  ggtitle('Frequency of Words AFINN Score') + theme_minimal()

If I am right then I can use the sentiment analysis to help make decision on my investment. But am I right?

The word “gross” is considered negative by AFINN lexicons, but it means “gross margin” in the context of finance articles. The word “share” and “shares” are neither positive nor negative in finance articles, but here AFINN lexicons count them as positive.

“tidytext” includes another sentiment lexicon - “loughran”, which was developed based on analyses of financial reports, and intentionally avoids words like “share” and “gross” that may not have a positive or negative meaning in a financial context.

The Loughran dictionary divides words into six sentiments: “positive”, “negative”, “litigious”, “uncertainty”, “constraining”, and “superfluous”.

library(tidytext)
tokens %>%
  count(word) %>%
  inner_join(get_sentiments("loughran"), by = "word") %>%
  group_by(sentiment) %>%
  top_n(5, n) %>%
  ungroup() %>%
  mutate(word = reorder(word, n)) %>%
  ggplot(aes(word, n)) +
  geom_col() +
  coord_flip() +
  facet_wrap(~ sentiment, scales = "free") +
  ggtitle("Frequency of This Word in Google Finance Articles") + theme_minimal()

This gives the most common words in the financial news articles associated with each of the six sentiments in the Loughran lexicon. Here I only get five sentiments, this indicates that there is no word can be associated with “superfluous” in recent Google finance news articles related to these four companies.

Now it makes much better sense and I can trust the results to count how frequently each sentiment was associated with each company in these articles.

sentiment_fre <- tokens %>%
  inner_join(get_sentiments("loughran"), by = "word") %>%
  count(sentiment, company) %>%
  spread(sentiment, n, fill = 0)
sentiment_fre

### A tibble: 4 × 6
##    company constraining litigious negative positive uncertainty
##*     <chr>        <dbl>     <dbl>    <dbl>    <dbl>       <dbl>
##1     Kraft           10        60      122       97          69
##2  Mondelez           17         3      187      300         155
##3 Starbucks           10        15      246      277         175
##4   Walmart           47       151      230       76         124

sentiment_fre %>%
  mutate(score = (positive - negative) / (positive + negative)) %>%
  mutate(company = reorder(company, score)) %>%
  ggplot(aes(company, score, fill = score > 0)) +
  geom_col(show.legend = FALSE) +
  coord_flip() + theme_minimal() + ggtitle('Positive or Negative Scores Among Recent Google Finance Articles')

Based the results, I’d say that in May 2017 most of the recent coverage on Walmart was strong negative and most of the recent coverage on Mondelez was positive. A quick search on the recent finance headlines suggests that I am on the right track.

The End

The code to produce all this in R depends heavily on Julia Silge and David Robinson’s Text Mining with R book.

Text Mining Finance News of Four Big American Companies was originally published by Susan Li at Susan Li | Data Ninja on May 24, 2017.

Exploring and Clustering Happy Planet Index

2017-05-19T00:00:00+00:00

The Happy Planet Index (HPI) is an index of human well-being and environmental impact that was introduced by NEF, a UK-based economic think tank promoting social, economic and environmental justice. The index is weighted to give progressively higher scores to nations with lower ecological footprints. I downloaded the 2016 dataset from HPI website. My goal is to find correlations between several variables, then use clustering technic to seprarate these 140 countries into different clusters, according to happiness, wealth, life expectancy and carbon emissions.

library(xlsx)
hpi <- read.xlsx('hpi-data-2016.xlsx',sheetIndex = 5, header = TRUE)

Load the packages

library(dplyr)
library(plotly)
library(stringr)
library(cluster)
library(FactoMineR)
library(factoextra)
library(ggplot2)
library(reshape2)
library(ggthemes)
library(NbClust)

Data Pre-processing

# Remove the unnecessary columns
hpi <- hpi[c(3:14)]
# remove footer
hpi <- hpi[-c(141:158), ]
# rename columns
hpi <- hpi[,c(grep('Country', colnames(hpi)), grep('Region', colnames(hpi)), grep('Happy.Planet.Index', colnames(hpi)), grep('Average.Life..Expectancy', colnames(hpi)), grep('Happy.Life.Years', colnames(hpi)), grep('Footprint..gha.capita.', colnames(hpi)), grep('GDP.capita...PPP.', colnames(hpi)), grep('Inequality.of.Outcomes', colnames(hpi)), grep('Average.Wellbeing..0.10.', colnames(hpi)), grep('Inequality.adjusted.Life.Expectancy', colnames(hpi)), grep('Inequality.adjusted.Wellbeing', colnames(hpi)), grep('Population', colnames(hpi)))]
names(hpi) <- c('country', 'region','hpi_index', 'life_expectancy', 'happy_years', 'footprint', 'gdp', 'inequality_outcomes', 'wellbeing', 'adj_life_expectancy', 'adj_wellbeing', 'population')
# change data type
hpi$country <- as.character(hpi$country)
hpi$region <- as.character(hpi$region)

The structure of the data

str(hpi)

##'data.frame':	140 obs. of  12 variables:
## $ country            : chr  "Afghanistan" "Albania" "Algeria" "Argentina" ##...
## $ region             : chr  "Middle East and North Africa" "Post-communist" ##"Middle East and North Africa" "Americas" ...
## $ hpi_index          : num  20.2 36.8 33.3 35.2 25.7 ...
## $ life_expectancy    : num  59.7 77.3 74.3 75.9 74.4 ...
## $ happy_years        : num  12.4 34.4 30.5 40.2 24 ...
## $ footprint          : num  0.79 2.21 2.12 3.14 2.23 9.31 6.06 0.72 5.09 ##7.44 ...
## $ gdp                : num  691 4247 5584 14357 3566 ...
## $ inequality_outcomes: num  0.427 0.165 0.245 0.164 0.217 ...
## $ wellbeing          : num  3.8 5.5 5.6 6.5 4.3 7.2 7.4 4.7 5.7 6.9 ...
## $ adj_life_expectancy: num  38.3 69.7 60.5 68.3 66.9 ...
## $ adj_wellbeing      : num  3.39 5.1 5.2 6.03 3.75 ...
## $ population         : num  29726803 2900489 37439427 42095224 2978339 ...

The summary of the data

summary(hpi[, 3:12])

##   hpi_index     life_expectancy  happy_years      footprint     
## Min.   :12.78   Min.   :48.91   Min.   : 8.97   Min.   : 0.610  
## 1st Qu.:21.21   1st Qu.:65.04   1st Qu.:18.69   1st Qu.: 1.425  
## Median :26.29   Median :73.50   Median :29.40   Median : 2.680  
## Mean   :26.41   Mean   :70.93   Mean   :30.25   Mean   : 3.258  
## 3rd Qu.:31.54   3rd Qu.:77.02   3rd Qu.:39.71   3rd Qu.: 4.482  
## Max.   :44.71   Max.   :83.57   Max.   :59.32   Max.   :15.820  
##      gdp           inequality_outcomes   wellbeing     adj_life_expectancy
## Min.   :   244.2   Min.   :0.04322     Min.   :2.867   Min.   :27.32      
## 1st Qu.:  1628.1   1st Qu.:0.13353     1st Qu.:4.575   1st Qu.:48.21      
## Median :  5691.1   Median :0.21174     Median :5.250   Median :63.41      
## Mean   : 13911.1   Mean   :0.23291     Mean   :5.408   Mean   :60.34      
## 3rd Qu.: 15159.1   3rd Qu.:0.32932     3rd Qu.:6.225   3rd Qu.:72.57      
## Max.   :105447.1   Max.   :0.50734     Max.   :7.800   Max.   :81.26      
## adj_wellbeing     population       
## Min.   :2.421   Min.   :2.475e+05  
## 1st Qu.:4.047   1st Qu.:4.248e+06  
## Median :4.816   Median :1.065e+07  
## Mean   :4.973   Mean   :4.801e+07  
## 3rd Qu.:5.704   3rd Qu.:3.343e+07  
## Max.   :7.625   Max.   :1.351e+09

ggplot(hpi, aes(x=gdp, y=life_expectancy)) + 
  geom_point(aes(size=population, color=region)) + coord_trans(x = 'log10') +
  geom_smooth(method = 'loess') + ggtitle('Life Expectancy and GDP per Capita in USD log10') + theme_classic()

After log transformation, the relationship between GDP per capita and life expectancy is more clear and looks relatively strong. These two variables are concordant. The Pearson correlation between this two variable is reasonably high, at approximate 0.62.

cor.test(hpi$gdp, hpi$life_expectancy)

##	Pearson's product-moment correlation

##data:  hpi$gdp and hpi$life_expectancy
##t = 9.3042, df = 138, p-value = 2.766e-16
##alternative hypothesis: true correlation is not equal to 0
##95 percent confidence interval:
## 0.5072215 0.7133067
##sample estimates:
##      cor 
##0.6208781

ggplot(hpi, aes(x=life_expectancy, y=hpi_index)) + 
  geom_point(aes(size=population, color=region)) + geom_smooth(method = 'loess') + ggtitle('Life Expectancy and Happy Planet Index Score') + theme_classic()

Many countries in Europe and Americas end up with middle-to-low HPI index probably because of their big carbon footprints, despite long life expectancy.

ggplot(hpi, aes(x=gdp, y=hpi_index)) + geom_point(aes(size=population, color=region)) + geom_smooth(method = 'loess') + ggtitle('GDP per Capita(log10) and Happy Planet Index Score') + coord_trans(x = 'log10')

GDP can’t buy happiness. The correlation between GDP and Happy Planet Index score is indeed very low, at about 0.11.

cor.test(hpi$gdp, hpi$hpi_index)

##	Pearson's product-moment correlation

##data:  hpi$gdp and hpi$hpi_index
##t = 1.3507, df = 138, p-value = 0.179
##alternative hypothesis: true correlation is not equal to 0
##95 percent confidence interval:
## -0.05267424  0.27492060
##sample estimates:
##      cor 
##0.1142272

Always(almost) scale the data.

An important step of meaningful clustering consists of transforming the variables such that they have mean zero and standard deviation one.

hpi[, 3:12] <- scale(hpi[, 3:12])
summary(hpi[, 3:12])

##  hpi_index        life_expectancy    happy_years         footprint      
## Min.   :-1.86308   Min.   :-2.5153   Min.   :-1.60493   Min.   :-1.1493  
## 1st Qu.:-0.71120   1st Qu.:-0.6729   1st Qu.:-0.87191   1st Qu.:-0.7955  
## Median :-0.01653   Median : 0.2939   Median :-0.06378   Median :-0.2507  
## Mean   : 0.00000   Mean   : 0.0000   Mean   : 0.00000   Mean   : 0.0000  
## 3rd Qu.: 0.70106   3rd Qu.: 0.6968   3rd Qu.: 0.71388   3rd Qu.: 0.5317  
## Max.   : 2.50110   Max.   : 1.4449   Max.   : 2.19247   Max.   : 5.4532  
##      gdp          inequality_outcomes   wellbeing       adj_life_expectancy
## Min.   :-0.6921   Min.   :-1.5692     Min.   :-2.2128   Min.   :-2.2192    
## 1st Qu.:-0.6220   1st Qu.:-0.8222     1st Qu.:-0.7252   1st Qu.:-0.8152    
## Median :-0.4163   Median :-0.1751     Median :-0.1374   Median : 0.2060    
## Mean   : 0.0000   Mean   : 0.0000     Mean   : 0.0000   Mean   : 0.0000    
## 3rd Qu.: 0.0632   3rd Qu.: 0.7976     3rd Qu.: 0.7116   3rd Qu.: 0.8221    
## Max.   : 4.6356   Max.   : 2.2702     Max.   : 2.0831   Max.   : 1.4059    
## adj_wellbeing       population     
## Min.   :-2.1491   Min.   :-0.2990  
## 1st Qu.:-0.7795   1st Qu.:-0.2740  
## Median :-0.1317   Median :-0.2339  
## Mean   : 0.0000   Mean   : 0.0000  
## 3rd Qu.: 0.6162   3rd Qu.:-0.0913  
## Max.   : 2.2339   Max.   : 8.1562

A simple correlation heatmap

qplot(x=Var1, y=Var2, data=melt(cor(hpi[, 3:12], use="p")), fill=value, geom="tile") +
  scale_fill_gradient2(limits=c(-1, 1)) + 
  theme(axis.text.x = element_text(angle = 90, hjust = 1)) + 
             labs(title="Heatmap of Correlation Matrix", 
                  x=NULL, y=NULL)

Principal Component Analysis (PCA)

PCA is a procedure for identifying a smaller number of uncorrelated variables, called “principal components”, from a large set of data. The goal of principal components analysis is to explain the maximum amount of variance with the minimum number of principal components.

hpi.pca <- PCA(hpi[, 3:12], graph=FALSE)
print(hpi.pca)

##**Results for the Principal Component Analysis (PCA)**
##The analysis was performed on 140 individuals, described by 10 variables
##*The results are available in the following objects:

##   name               description                          
##1  "$eig"             "eigenvalues"                        
##2  "$var"             "results for the variables"          
##3  "$var$coord"       "coord. for the variables"           
##4  "$var$cor"         "correlations variables - dimensions"
##5  "$var$cos2"        "cos2 for the variables"             
##6  "$var$contrib"     "contributions of the variables"     
##7  "$ind"             "results for the individuals"        
##8  "$ind$coord"       "coord. for the individuals"         
##9  "$ind$cos2"        "cos2 for the individuals"           
##10 "$ind$contrib"     "contributions of the individuals"   
##11 "$call"            "summary statistics"                 
##12 "$call$centre"     "mean of the variables"              
##13 "$call$ecart.type" "standard error of the variables"    
##14 "$call$row.w"      "weights for the individuals"        
##15 "$call$col.w"      "weights for the variables"

eigenvalues <- hpi.pca$eig
head(eigenvalues)

##      eigenvalue percentage of variance cumulative percentage of variance
##comp 1 6.66741533             66.6741533                          66.67415
##comp 2 1.31161290             13.1161290                          79.79028
##comp 3 0.97036077              9.7036077                          89.49389
##comp 4 0.70128270              7.0128270                          96.50672
##comp 5 0.24150648              2.4150648                          98.92178
##comp 6 0.05229306              0.5229306                          99.44471

Interpretation:

The proportion of variation retained by the principal components was extracted above.
eigenvalues is the amount of variation retained by each PC. The first PC corresponds to the maximum amount of variation in the data set. In this case, the first two principal components are worthy of consideration because A commonly used criterion for the number of factors to rotate is the eigenvalues-greater-than-one rule proposed by Kaiser (1960).

fviz_screeplot(hpi.pca, addlabels = TRUE, ylim = c(0, 65))

The scree plot shows us which components explain most of the variability in the data. In this case, almost 80% of the variances contained in the data are retained by the first two principal components.

head(hpi.pca$var$contrib)

##                      Dim.1       Dim.2       Dim.3      Dim.4       Dim.5
##hpi_index            3.571216 50.96354921 5.368971166  2.1864830  5.28431372
##life_expectancy     12.275001  2.29815687 0.002516184 18.4965447  0.31797242
##happy_years         14.793710  0.01288175 0.027105103  0.7180341  0.03254368
##footprint            9.021277 24.71161977 2.982449522  0.4891428  7.62967135
##gdp                  9.688265 11.57381062 1.003632002  2.3980025 72.49799232
##inequality_outcomes 13.363651  0.30494623 0.010038818  9.7957329  2.97699333

Variables that are correlated with PC1 and PC2 are the most important in explaining the variability in the data set.
The contribution of variables was extracted above: The larger the value of the contribution, the more the variable contributes to the component.

fviz_pca_var(hpi.pca, col.var="contrib",
             gradient.cols = c("#00AFBB", "#E7B800", "#FC4E07"),
             repel = TRUE 
             )

This highlights the most important variables in explaining the variations retained by the principal components.

Using Pam Clustering Analysis to group countries by wealth, development, carbon emissions, and happiness.

When using clustering algorithms, k must be specified by the analyst. I use the following method to help finding the best k.

number <- NbClust(hpi[, 3:12], distance="euclidean",
               min.nc=2, max.nc=15, method='ward.D', index='all', alphaBeale = 0.1)

##*** : The Hubert index is a graphical method of determining the number of ##clusters.
##                In the plot of Hubert index, we seek a significant knee that ##corresponds to a 
##                significant increase of the value of the measure i.e the ##significant peak in Hubert
##                index second differences plot. 
 
##*** : The D index is a graphical method of determining the number of ##clusters. 
##                In the plot of D index, we seek a significant knee (the ##significant peak in Dindex
##                second differences plot) that corresponds to a significant ##increase of the value of
##                the measure. 
 
##******************************************************************* 
##* Among all indices:                                                
##* 4 proposed 2 as the best number of clusters 
##* 7 proposed 3 as the best number of clusters 
##* 1 proposed 5 as the best number of clusters 
##* 5 proposed 6 as the best number of clusters 
##* 3 proposed 10 as the best number of clusters 
##* 3 proposed 15 as the best number of clusters 

##                   ***** Conclusion *****                            
 
##* According to the majority rule, the best number of clusters is  3

I will apply K=3 in the following steps.

set.seed(2017)
pam <- pam(hpi[, 3:12], diss=FALSE, 3, keep.data=TRUE)
fviz_silhouette(pam)

## cluster size ave.sil.width
##1       1   43          0.46
##2       2   66          0.32
##3       3   31          0.37

Number of countries assigned in each cluster.

hpi$country[pam$id.med]

##[1] "Liberia" "Romania" "Ireland"

This prints out one typical country represents each cluster.

fviz_cluster(pam, stand = FALSE, geom = "point",
             ellipse.type = "norm")

It is always a good idea to look at the cluster results, see how these three clusters were assigned.

A World map of three clusters

hpi['cluster'] <- as.factor(pam$clustering)
map <- map_data("world")
map <- left_join(map, hpi, by = c('region' = 'country'))
ggplot() + geom_polygon(data = map, aes(x = long, y = lat, group = group, fill=cluster, color=cluster)) +
  labs(title = "Clustering Happy Planet Index", subtitle = "Based on data from:http://happyplanetindex.org/", x=NULL, y=NULL) + theme_minimal()

Source code that created this post can be found here. I am happy to hear any feedback or questions.

References:

Exploring and Clustering Happy Planet Index was originally published by Susan Li at Susan Li | Data Ninja on May 19, 2017.

Predict House Sale Prices in Ames, Iowa

2017-05-16T00:00:00+00:00

The Ames Housing dataset was downloaded from kaggle. It is a playground competition’s dataset and my taske is to predict house prices based on house-level features using multiple linear regression model in R.

Prepare the data

library(Hmisc)
library(psych)
library(car)

Split the data into a training set and a testing set.

house <- read.csv('house.csv')
set.seed(2017)
split <- sample(seq_len(nrow(house)), size = floor(0.75 * nrow(house)))
train <- house[split, ]
test <- house[-split, ]
dim(train)

##[1] 1095   81

The training set contains 1095 observations and 81 variables. To start, I will hypothesize the following subset of the variables as potential predicators.

salePrice - the property’s sale price in dollars. This is the target variable that I am trying to predict.
OverallCond - Overall condition rating
YearBuilt - Original construction date
YearRemodAdd - Remodel data
BedroomAbvGr - Number of bedrooms above basement level
GrLivArea - Above grade (ground) living area square feet
KitchenAbvGr - Number of kitchens above grade
TotRmsAbvGrd - Total rooms above grade (does not include bathrooms)
GarageCars - Size of garage in car capacity
PoolArea - Pool area in square feet
LotArea - Lot size in square feet

Construct a new data fram consisting solely of these variables.

train <- subset(train, select=c(SalePrice, LotArea, PoolArea, GarageCars, TotRmsAbvGrd, KitchenAbvGr, GrLivArea, BedroomAbvGr, YearRemodAdd, YearBuilt, OverallCond))
head(train)

## SalePrice LotArea PoolArea GarageCars TotRmsAbvGrd KitchenAbvGr GrLivArea
##1350 122000    5250     0         0            8          1       2358
##784  165500    9101     0         2            4          1       1110
##685  221000   16770     0         2            7          1       1839
##421  206300    7060     0         4            8          2       1344
##1122 212900   10084     0         3            7          1       1552
##1125 163900    9125     0         2            7          1       1482
##     BedroomAbvGr YearRemodAdd YearBuilt OverallCond
##1350            4         1987      1872           5
##784             1         1978      1978           6
##685             4         1998      1998           5
##421             2         1998      1997           5
##1122            3         2006      2005           5
##1125            3         1992      1992           5

Report variables with missing values.

sapply(train, function(x) sum(is.na(x)))

##SalePrice      LotArea     PoolArea   GarageCars TotRmsAbvGrd KitchenAbvGr 
##    0            0            0            0            0            0 
##   GrLivArea BedroomAbvGr YearRemodAdd    YearBuilt  OverallCond 
##           0            0            0            0            0

Summary statistics

summary(train)

##   SalePrice         LotArea          PoolArea         GarageCars   
## Min.   : 34900   Min.   :  1300   Min.   :  0.000   Min.   :0.000  
## 1st Qu.:129000   1st Qu.:  7500   1st Qu.:  0.000   1st Qu.:1.000  
## Median :164000   Median :  9452   Median :  0.000   Median :2.000  
## Mean   :181598   Mean   : 10467   Mean   :  3.679   Mean   :1.764  
## 3rd Qu.:215600   3rd Qu.: 11500   3rd Qu.:  0.000   3rd Qu.:2.000  
## Max.   :745000   Max.   :215245   Max.   :738.000   Max.   :4.000  
##  TotRmsAbvGrd    KitchenAbvGr    GrLivArea   BedroomAbvGr  YearRemodAdd 
## Min. : 2.000   Min. :0.000   Min.  : 334   Min.  :0.000   Min. :1950  
## 1st Qu.:5.000  1st Qu.:1.000 1st Qu.:1124  1st Qu.:2.000  1st Qu.:1967  
## Median :6.000  Median :1.000 Median :1458  Median :3.000  Median :1994  
## Mean   :6.493  Mean   :1.045   Mean :1510   Mean  :2.848   Mean  :1985  
## 3rd Qu.:7.000  3rd Qu.:1.000 3rd Qu.:1779  3rd Qu.:3.000  3rd Qu.:2004  
## Max. :12.000   Max.   :3.000   Max. :5642   Max.  :6.000   Max.  :2010  
##   YearBuilt     OverallCond   
## Min.   :1872   Min.   :1.000  
## 1st Qu.:1954   1st Qu.:5.000  
## Median :1974   Median :5.000  
## Mean   :1972   Mean   :5.555  
## 3rd Qu.:2001   3rd Qu.:6.000  
## Max.   :2009   Max.   :9.000

Before fitting my regression model I want to investigate how the variables are related to one another.

pairs.panels(train, col='red')

We can see some of the variables are very skewed. If we want to have a good regression model, the varaibles should be normal distributed. The variables should be independent and not correlated. “GrLivArea” and “TotRmsAbvGrd” clearly have a high correlation, I will have to deal with these.

Fit the linear model

fit <-  lm(SalePrice ~ LotArea + PoolArea + GarageCars + TotRmsAbvGrd + KitchenAbvGr + GrLivArea + BedroomAbvGr + YearRemodAdd + YearBuilt + OverallCond, data=train)
summary(fit)

##Call:
##lm(formula = SalePrice ~ LotArea + PoolArea + GarageCars + TotRmsAbvGrd + 
##    KitchenAbvGr + GrLivArea + BedroomAbvGr + YearRemodAdd + 
##    YearBuilt + OverallCond, data = train)

##Residuals:
##    Min      1Q  Median      3Q     Max 
##-434633  -21648   -3194   16980  294504 

##Coefficients:
##               Estimate Std. Error t value Pr(>|t|)    
##(Intercept)  -1.823e+06  1.451e+05 -12.569  < 2e-16 ***
##LotArea       7.174e-01  1.317e-01   5.449 6.28e-08 ***
##PoolArea     -1.522e+01  2.777e+01  -0.548   0.5838    
##GarageCars    2.107e+04  2.288e+03   9.207  < 2e-16 ***
##TotRmsAbvGrd  6.789e+03  1.672e+03   4.060 5.26e-05 ***
##KitchenAbvGr -4.215e+04  6.195e+03  -6.805 1.67e-11 ***
##GrLivArea     7.598e+01  4.700e+00  16.165  < 2e-16 ***
##BedroomAbvGr -1.605e+04  2.198e+03  -7.303 5.44e-13 ***
##YearRemodAdd  2.115e+02  8.779e+01   2.410   0.0161 *  
##YearBuilt     7.235e+02  6.875e+01  10.523  < 2e-16 ***
##OverallCond   7.940e+03  1.356e+03   5.853 6.39e-09 ***
##---
##Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

##Residual standard error: 41240 on 1084 degrees of freedom
##Multiple R-squared:  0.737,	Adjusted R-squared:  0.7346 
##F-statistic: 303.7 on 10 and 1084 DF,  p-value: < 2.2e-16

Interprete the output:

R-squred of 0.737 tells us that approximately 74% of variation in sale price can be explained by my model.
F-statistics and p-value show the overall significance test of my model.
Residual standard error gives an idea on how far observed sale price are from the predicted or fitted sales price.
Intercept is the estimated sale price for a house with all the other variables at zero. It does not provide any meaningful interpretation.
The slope for “GrlivArea”(7.598e+01) is the effect of Above grade living area square feet on sale price adjusting or controling for the other variables, i.e we associate an increase of 1 square foot in “GrlivArea” with an increase of $75.98 in sale price adjusting or controlling for the other variables.

Stepwise Procedure

Using backward elimination to remove the predictor with the largest p-value over 0.05. In this case, I will remove “PoolArea” first, then fit the model again.

fit <-  lm(SalePrice ~ LotArea + GarageCars + TotRmsAbvGrd + KitchenAbvGr + GrLivArea + BedroomAbvGr + YearRemodAdd + YearBuilt + OverallCond, data=train)
summary(fit)

##Call:
##lm(formula = SalePrice ~ LotArea + GarageCars + TotRmsAbvGrd + 
##    KitchenAbvGr + GrLivArea + BedroomAbvGr + YearRemodAdd + 
##    YearBuilt + OverallCond, data = train)

##Residuals:
##    Min      1Q  Median      3Q     Max 
##-440086  -21728   -3086   16994  287342 

##Coefficients:
##               Estimate Std. Error t value Pr(>|t|)    
##(Intercept)  -1.826e+06  1.449e+05 -12.601  < 2e-16 ***
##LotArea       7.153e-01  1.316e-01   5.437 6.69e-08 ***
##GarageCars    2.114e+04  2.284e+03   9.255  < 2e-16 ***
##TotRmsAbvGrd  6.888e+03  1.662e+03   4.144 3.67e-05 ***
##KitchenAbvGr -4.212e+04  6.192e+03  -6.802 1.70e-11 ***
##GrLivArea     7.543e+01  4.590e+00  16.433  < 2e-16 ***
##BedroomAbvGr -1.608e+04  2.196e+03  -7.321 4.80e-13 ***
##YearRemodAdd  2.135e+02  8.769e+01   2.434   0.0151 *  
##YearBuilt     7.231e+02  6.873e+01  10.521  < 2e-16 ***
##OverallCond   7.930e+03  1.356e+03   5.849 6.56e-09 ***
##---
##Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

##Residual standard error: 41230 on 1085 degrees of freedom
##Multiple R-squared:  0.7369,	Adjusted R-squared:  0.7347 
##F-statistic: 337.7 on 9 and 1085 DF,  p-value: < 2.2e-16

After eliminating “PoolArea”, R-Squared almost identical, Adjusted R-squared slightly improved. At this point, I think I can start building the model.

However, as we have seen earlier, two variables - “GrLivArea” and “TotRmsAbvGrd” are highly correlated, the multicollinearity between “GrLivArea” and “TotRmsAbvGrd” means that we should not directly interpret “GrLivArea” as the effect of “GrLivArea” on sale price adjusting for “TotRmsAbvGrd”. These two effects are somewhat bounded together.

attach(train)
cor(GrLivArea, TotRmsAbvGrd, method='pearson')

##[1] 0.826969

Create a confidence interval for the model coefficients

confint(fit, conf.level=0.95)

##                     2.5 %        97.5 %
##(Intercept)  -2.110407e+06 -1.541712e+06
##LotArea       4.571854e-01  9.734940e-01
##GarageCars    1.665678e+04  2.561958e+04
##TotRmsAbvGrd  3.626750e+03  1.014894e+04
##KitchenAbvGr -5.426898e+04 -2.996842e+04
##GrLivArea     6.642123e+01  8.443367e+01
##BedroomAbvGr -2.038677e+04 -1.176829e+04
##YearRemodAdd  4.141973e+01  3.855420e+02
##YearBuilt     5.882452e+02  8.579526e+02
##OverallCond   5.269715e+03  1.059089e+04

For example, from the 2nd model, I have estimated the slope for “GrLivArea” is 75.43. I am 95% confident that the true slope for “GrLivArea” is between 66.42 and 84.43.

Check the diagnostic plots for the model

plot(fit)

The relationship between predictor variables and an outcome variable is approximate linear. There are three extreme cases (outliers).

It looks like I don’t have to be concerned too much, although two observations numbered as 524 and 1299 look a little off.

The distribution of residuals around the linear model in relation to the sale price. Most of the houses in the data in the lower and median price range, the higher price, the less observations.

This plot helps us to find influential cases if any. Not all outliers are influential in linear regression analysis. It looks like none of the outliers in my model are influential.

Testing the prediction model

test <- subset(test, select=c(SalePrice, LotArea, GarageCars, TotRmsAbvGrd, KitchenAbvGr, GrLivArea, BedroomAbvGr, YearRemodAdd, YearBuilt, OverallCond))
prediction <- predict(fit, newdata = test)

Look at the first few values of prediction, and compare it to the values of salePrice in the test data set.

head(prediction)

##        4        10        16        20        22        34 
##176501.95  65626.55 130650.30 135358.79 102336.97 161300.96

head(test$SalePrice)

##[1] 140000 118000 132000 139000 139400 165500

At last, calculate the value of R-squared for the prediction model on the test data set. In general, R-squared is the metric for evaluating the goodness of fit of my model. Higher is better with 1 being the best.

SSE <- sum((test$SalePrice - prediction) ^ 2)
SST <- sum((test$SalePrice - mean(test$SalePrice)) ^ 2)
1 - SSE/SST

##[1] 0.7421962

Source code that created this post can be found here. I am happy to hear any feedback or questions.

Predict House Sale Prices in Ames, Iowa was originally published by Susan Li at Susan Li | Data Ninja on May 16, 2017.

Clustering Wholesale Customers

2017-05-12T00:00:00+00:00

I downloaded this wholesale customer dataset from UCI Machine Learning Repository. The data set refers to clients of a wholesale distributor. It includes the annual spending in monetary units on diverse product categories.

My goal today is to use various clustering techniques to segment customers. Clustering is an unsupervised learning algorithm that tries to cluster data based on their similarity. Thus, there is no outcome to be predicted, and the algorithm just tries to find patterns in the data.

This is the head and structure of the original data

customer <- read.csv('Wholesale.csv')
head(customer)
str(customer)

##  Channel Region Fresh Milk Grocery Frozen Detergents_Paper Delicassen
##1       2      3 12669 9656    7561    214             2674       1338
##2       2      3  7057 9810    9568   1762             3293       1776
##3       2      3  6353 8808    7684   2405             3516       7844
##4       1      3 13265 1196    4221   6404              507       1788
##5       2      3 22615 5410    7198   3915             1777       5185
##6       2      3  9413 8259    5126    666             1795       1451

##'data.frame':	440 obs. of  8 variables:
## $ Channel         : int  2 2 2 1 2 2 2 2 1 2 ...
## $ Region          : int  3 3 3 3 3 3 3 3 3 3 ...
## $ Fresh           : int  12669 7057 6353 13265 22615 9413 12126 7579 5963 ##6006 ...
## $ Milk            : int  9656 9810 8808 1196 5410 8259 3199 4956 3648 11093 ##...
## $ Grocery         : int  7561 9568 7684 4221 7198 5126 6975 9426 6192 18881 ##...
## $ Frozen          : int  214 1762 2405 6404 3915 666 480 1669 425 1159 ...
## $ Detergents_Paper: int  2674 3293 3516 507 1777 1795 3140 3321 1716 7425 ##...
## $ Delicassen      : int  1338 1776 7844 1788 5185 1451 545 2566 750 2098

K-Means Clustering

Prepare the data for analysis. Remove the missing value and remove “Channel” and “Region” columns because they are not useful for clustering.

customer1<- customer
customer1<- na.omit(customer1)
customer1$Channel <- NULL
customer1$Region <- NULL

Standardize the variables.

customer1 <- scale(customer1)

Determine the number of clusters.

wss <- (nrow(customer1)-1)*sum(apply(customer1,2,var))
for (i in 2:15) wss[i] <- sum(kmeans(customer1, 
  	centers=i)$withinss)
plot(1:15, wss, type="b", xlab="Number of Clusters",
  ylab="Within groups sum of squares")

The correct choice of k is often ambiguous, but from the above plot, I am going to try my cluster analysis with 6 clusters .

Fit the model and print out the cluster means.

fit <- kmeans(customer1, 6) # fit the model
aggregate(customer1,by=list(fit$cluster),FUN=mean) # get cluster means
customer1 <- data.frame(customer1, fit$cluster) #append cluster assignment

##Group.1      Fresh       Milk    Grocery       Frozen Detergents_Paper
##1       1  1.9645810  5.1696185  1.2857533  6.892753825       -0.5542311
##2       2 -0.2739609 -0.3783644 -0.4305494 -0.211588391       -0.3831918
##3       3  1.9690056 -0.1118770 -0.1634420  0.135957112       -0.3442663
##4       4  0.5169977 -0.1920274 -0.3383244  2.208659048       -0.4918734
##5       5 -0.5243579  0.7090376  0.9394834 -0.327668397        0.9397185
##6       6  0.3134735  3.9174467  4.2707490 -0.003570131        4.6129149
##   Delicassen
##1 16.45971129
##2 -0.19795557
##3  0.35480899
##4  0.09906704
##5  0.09704564
##6  0.50279301

Plotting the results.

library(cluster)
clusplot(customer1, fit$cluster, color=TRUE, shade=TRUE, labels=2, lines=0)

Interpretation of the results: With my analysis, more than 70% of information about the multivariate data is captured by this plot of component 1 and 2.

Outlier detection with K-Means

First, the data are partitioned into k groups by assigning them to the closest cluster centers, as follows:

customer2 <- customer[, 3:8]
kmeans.result <- kmeans(customer2, centers=6)
kmeans.result$centers

##     Fresh      Milk   Grocery    Frozen Detergents_Paper Delicassen
##1 50512.095  6987.524  6478.095 10215.381        1030.5238  4904.7619
##2  6683.067 17468.033 26658.933  1986.300       11872.9000  2531.2000
##3 25603.000 43460.600 61472.200  2636.000       29974.2000  2708.8000
##4 22157.050  4045.180  5318.720  3961.420        1148.1700  1726.3700
##5  6664.869  2434.450  3049.880  2824.906         724.4817   886.4503
##6  4324.462  8524.484 12268.753  1383.430        5236.1828  1467.8925

Then calculate the distance between each object and its cluster center, then pick those with largest distances as outliers and print out outliers’ IDs.

kmeans.result$cluster # print out cluster IDs 
centers <- kmeans.result$centers[kmeans.result$cluster, ]
distances <- sqrt(rowSums((customer2 - centers)^2)) # calculate distances
outliers <- order(distances, decreasing=T)[1:5] # pick up top 5 distances
print(outliers)

##[1] 182 184 326 334  87

These are the outliers. Let me make it more meaningful.

print(customer2[outliers,])

##    Fresh  Milk Grocery Frozen Detergents_Paper Delicassen
##182 112151 29627   18148  16745             4948       8550
##184  36847 43950   20170  36534              239      47943
##326  32717 16784   13626  60869             1272       5609
##334   8565  4980   67298    131            38102       1215
##87   22925 73498   32114    987            20070        903

Much better!

Hierarchical Clustering

First draw a sample of 40 records from the customer data, so that the clustering plot will not be over crowded. Same as before, variables “Region” and “Channel” are removed from the data. After that, I apply hierarchical clustering to the data.

idx <- sample(1:dim(customer)[1], 40)
customerSample <- customer[idx,]
customerSample$Region <- NULL
customerSample$Channel <- NULL

There are a wide range of hierarchical clustering methods, I heard Ward’s method is a good appraoch, so try it out.

d <- dist(customerSample, method = "euclidean") # distance matrix
fit <- hclust(d, method="ward") 
plot(fit) # display dendogram
groups <- cutree(fit, k=6) # cut tree into 6 clusters
rect.hclust(fit, k=6, border="red") # draw dendogram with red borders around the 6 clusters

Let me try to interpret: At the bottom, I start with 40 data points, each assigned to separate clusters, two closest clusters are then merged till I have just one cluster at the top. The height in the dendrogram at which two clusters are merged represents the distance between two clusters in the data space. The decision of the number of clusters that can best depict different groups can be chosen by observing the dendrogram.

The End

I reviewed K Means clustering and Hierarchical Clustering. As we have seen, from using clusters we can understand the portfolio in a better way. We can then build targeted strategy using the profiles of each cluster.

The source code can be found here. I am happy to hear any feedback and questions.

Reference:

R and Data Mining

Clustering Wholesale Customers was originally published by Susan Li at Susan Li | Data Ninja on May 12, 2017.

Exploring the BRFSS Data and Predict Stroke

2017-05-08T00:00:00+00:00

Load packages

library(ggplot2)
library(dplyr)
library(Hmisc)
library(corrplot)

Load data

load("brfss2013.RData")

Part 1: About the Data

The Behavioral Risk Factor Surveillance System (BRFSS) is an annual telephone survey in the United States. The BRFSS is designed to identify risk factors in the adult population and report emerging trends. For example, respondents are asked about their diet and weekly physical activity, their HIV/AIDS status, possible tobacco use, immunization, health status, healthy days - health-related quality of life, health care access, inadequate sleep, hypertension awareness, cholesterol awareness, chronic health conditions, alcohol consumption, fruits and vegetables consumption, arthritis burden, and seatbelt use.

Data Collection:

Data collection procedure is explained in brfss_codebook. The data were collected from United States’ all 50 states, the District of Columbia, Puerto Rico, Guam and American Samoa, Federated States of Micronesia, and Palau, by conducting both landline telephone and cellular telephone-based surveys. Disproportionate stratified sampling (DSS) has been used for the landline sample and the cellular telephone respondents are randomly selected with each having equal probability of selection. The dataset we are working on contains 330 variables for a total of 491, 775 observations in 2013. The missing values denoted by “NA”.

Generalizability:

The sample data should allow us to generalize to the population of interest. It is a survey of 491,775 U.S. adults aged 18 years or older. It is based on a large stratified random sample. Potential biases are associated with non-response, incomplete interviews, missing values and convenience bias (some potential respondents may not have been included because they do not have a landline and cell phone).

Causality:

There is no causation can be established as BRFSS is an observation study that can only establish correlation/association between variables.

Part 2: Research Questions

Research quesion 1:

Does the distribution of the number of days in which physical and mental health was not good during the past 30 days differ by gender?

Research quesion 2:

Is there an association between the month in which a respondent was interviewed and the respondent’s self-reported health perception?

Research quesion 3:

Is there any association between income and health care coverage?

Research quesion 4:

Is there any relation between smoking, drinking alcohol, cholesterol level, blood pressure, weight and having a stroke? Eventually, I would like to see whether stroke can be predicted from the above mentioned variables.

Part 3: Exploratory data analysis

Research quesion 1:

ggplot(aes(x=physhlth, fill=sex), data = brfss2013[!is.na(brfss2013$sex), ]) +
  geom_histogram(bins=30, position = position_dodge()) + ggtitle('Number of Days Physical Health not Good in the Past 30 Days')

ggplot(aes(x=menthlth, fill=sex), data=brfss2013[!is.na(brfss2013$sex), ]) +
  geom_histogram(bins=30, position = position_dodge()) + ggtitle('Number of Days Mental Health not Good in the Past 30 Days')

ggplot(aes(x=poorhlth, fill=sex), data=brfss2013[!is.na(brfss2013$sex), ]) +
  geom_histogram(bins=30, position = position_dodge()) + ggtitle('Number of Days with Poor Physical Or Mental Health in the Past 30 Days')

summary(brfss2013$sex)

##  Male  Female   NA's 
##201313 290455      7

The above three figures show the data distribution of how male and female responded to the number of days physical, mental and both health not good during the past 30 days. We can see that there were far more female respondents than male respondents.

Research quesion 2:

by_month <- brfss2013 %>% filter(iyear=='2013') %>% group_by(imonth, genhlth) %>% summarise(n=n())
ggplot(aes(x=imonth, y=n, fill = genhlth), data = by_month[!is.na(by_month$genhlth), ]) + geom_bar(stat = 'identity', position = position_dodge()) + ggtitle('Health Perception By Month')

by_month1 <- brfss2013 %>% filter(iyear=='2013') %>% group_by(imonth) %>% summarise(n=n())
ggplot(aes(x=imonth, y=n), data=by_month1) + geom_bar(stat = 'identity') + ggtitle('Number of Respondents by Month')

I was trying to find out whether people respond their health condition differently in the different month. For example, are people more likely to say they are in good health in the spring or summer? It appears that there was no obvious pattern.

Research quesion 3:

plot(brfss2013$income2, brfss2013$hlthpln1, xlab = 'Income Level', ylab = 'Health Care Coverage', main =
'Income Level versus Health Care Coverage')

In general, higher income respondents are more likely to have health care coverage then those of lower income respondents.

Research quesion 4:

To answer this question, I willl be using the following varibles:

smoke100: Smoked At Least 100 Cigarettes
avedrnk2: Avg Alcoholic Drinks Per Day In Past 30
bphigh4: Ever Told Blood Pressure High
toldhi2: Ever Told Blood Cholesterol High
weight2: Reported Weight In Pounds
cvdstrk3: Ever Diagnosed With A Stroke

First, convert the above variables to numeric, and see any correlation between these numerica variables.

vars <- names(brfss2013) %in% c('smoke100', 'avedrnk2', 'bphigh4', 'toldhi2', 'weight2')
selected_brfss <- brfss2013[vars]
selected_brfss$toldhi2 <- ifelse(selected_brfss$toldhi2=="Yes", 1, 0)
selected_brfss$smoke100 <- ifelse(selected_brfss$smoke100=="Yes", 1, 0)
selected_brfss$weight2 <- as.numeric(selected_brfss$weight2)
selected_brfss$bphigh4 <- as.factor(ifelse(selected_brfss$bphigh4=="Yes", "Yes", (ifelse(selected_brfss$bphigh4=="Yes, but female told only during pregnancy", "Yes", (ifelse(selected_brfss$bphigh4=="Told borderline or pre-hypertensive", "Yes", "No"))))))
selected_brfss$bphigh4 <- ifelse(selected_brfss$bphigh4=="Yes", 1, 0)
selected_brfss <- na.delete(selected_brfss)
corr.matrix <- cor(selected_brfss)
corrplot(corr.matrix, main="\n\nCorrelation Plot of Smoke, Alcohol, Blood pressure, Cholesterol, and Weight", method="number")

No any two numeric variables seem to have strong correlations.

Logistic Regression to Predict Stroke

Replace the answer “Yes, but female told only during pregnancy” and “Told borderline or pre-hypertensive” with “Yes”.

vars1 <- names(brfss2013) %in% c('smoke100', 'avedrnk2', 'bphigh4', 'toldhi2', 'weight2', 'cvdstrk3')
stroke <- brfss2013[vars1]
stroke$bphigh4 <- as.factor(ifelse(stroke$bphigh4=="Yes", "Yes", (ifelse(stroke$bphigh4=="Yes, but female told only during pregnancy", "Yes", (ifelse(stroke$bphigh4=="Told borderline or pre-hypertensive", "Yes", "No"))))))
stroke$weight2<-as.numeric(stroke$weight2)

Replace ‘NA’ values with ‘No’.

stroke$bphigh4 <- replace(stroke$bphigh4, which(is.na(stroke$bphigh4)), "No")
stroke$toldhi2 <- replace(stroke$toldhi2, which(is.na(stroke$toldhi2)), "No")
stroke$cvdstrk3 <- replace(stroke$cvdstrk3, which(is.na(stroke$cvdstrk3)), "No")
stroke$smoke100 <- replace(stroke$smoke100, which(is.na(stroke$smoke100)), 'No')

Replace ‘NA’ value by average.

mean(stroke$avedrnk2,na.rm = T)

##[1] 2.209905

stroke$avedrnk2 <- replace(stroke$avedrnk2, which(is.na(stroke$avedrnk2)), 2)

Have a look the data that will be used for modeling.

head(stroke)
summary(stroke)

##   bphigh4 toldhi2 cvdstrk3 weight2 smoke100 avedrnk2
##1     Yes     Yes       No     154      Yes        2
##2      No      No       No      30       No        2
##3      No      No       No      63      Yes        4
##4      No     Yes       No      31       No        2
##5     Yes      No       No     169      Yes        2
##6     Yes     Yes       No     128       No        2

##  bphigh4      toldhi2      cvdstrk3        weight2       smoke100    
## No :284107   Yes:183501   Yes: 20391   Min.   :  1.00   Yes:215201  
## Yes:207668   No :308274   No :471384   1st Qu.: 43.00   No :276574  
##                                        Median : 73.00               
##                                        Mean   : 80.22               
##                                        3rd Qu.:103.00               
##                                        Max.   :570.00               
##    avedrnk2     
## Min.   : 1.000  
## 1st Qu.: 2.000  
## Median : 2.000  
## Mean   : 2.099  
## 3rd Qu.: 2.000  
## Max.   :76.000

Covert to binary outcome.

stroke$cvdstrk3 <- ifelse(stroke$cvdstrk3=="Yes", 1, 0)

After wrangling and cleaning the data, now we can fit the model.

Logistic Regression Model Fitting

train <- stroke[1:390000,]
test <- stroke[390001:491775,]
model <- glm(cvdstrk3 ~.,family=binomial(link = 'logit'),data=train)
summary(model)

##Call:
##glm(formula = cvdstrk3 ~ ., family = binomial(link = "logit"), 
##    data = train)

##Deviance Residuals: 
##    Min       1Q   Median       3Q      Max  
##-0.5057  -0.3672  -0.2109  -0.1630   3.2363  

##Coefficients:
##              Estimate Std. Error  z value Pr(>|z|)    
##(Intercept) -3.2690106  0.0268240 -121.869  < 2e-16 ***
##bphigh4Yes   1.3051850  0.0193447   67.470  < 2e-16 ***
##toldhi2No   -0.5678048  0.0171500  -33.108  < 2e-16 ***
##weight2     -0.0009628  0.0001487   -6.476 9.41e-11 ***
##smoke100No  -0.3990598  0.0163896  -24.348  < 2e-16 ***
##avedrnk2    -0.0274511  0.0065099   -4.217 2.48e-05 ***
##---
##Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

##(Dispersion parameter for binomial family taken to be 1)

##    Null deviance: 136364  on 389999  degrees of freedom
##Residual deviance: 126648  on 389994  degrees of freedom
##AIC: 126660

##Number of Fisher Scoring iterations: 6

Interpreting the results of my logistic regression model:

All the variables are statistically significant.

All other variables being equal, being told blood pressure high is more likely to have a stroke.
The negative coefficient for the predictor - toldhi2No suggests that all other variables being equal, not being told blood cholesterol high is less likely to have a stroke.
For every one unit change in weight, the log odds of having a stroke (versus no-stroke) decreases by 0.00096.
Not Smoked At Least 100 Cigarettes, less likely to have a stroke.
For a one unit increase in Avg alcoholic drinks per day in past 30 days, the log odds of having a stroke decreases by 0.027.

anova(model, test="Chisq")

##Analysis of Deviance Table

##Model: binomial, link: logit

##Response: cvdstrk3

##Terms added sequentially (first to last)


##         Df Deviance Resid. Df Resid. Dev  Pr(>Chi)    
##NULL                    389999     136364              
##bphigh4   1   7848.6    389998     128516 < 2.2e-16 ***
##toldhi2   1   1230.1    389997     127285 < 2.2e-16 ***
##weight2   1     33.2    389996     127252 8.453e-09 ***
##smoke100  1    584.5    389995     126668 < 2.2e-16 ***
##avedrnk2  1     19.9    389994     126648 7.958e-06 ***
##---
##Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Analyzing the deviance table we can see the drop in deviance when adding each variable one at a time. Adding bphigh4, toldhi2, smoke100 significantly reduces the residual deviance. The other variables weight2 and avedrnk2 seem to imrove the model less even though they all have low p-values.

Assessing the predictive ability of the model

 
fitted.results <- predict(model,newdata=test,type='response')
fitted.results <- ifelse(fitted.results > 0.5,1,0)

misClasificError <- mean(fitted.results != test$cvdstrk3)
print(paste('Accuracy',1-misClasificError))

##[1] "Accuracy 0.961296978629329

The 0.96 accuracy on the test set is a very good result.

Plot the ROC curve and calculate the AUC (area under the curve).

library(ROCR)
p <- predict(model, newdata=test, type="response")
pr <- prediction(p, test$cvdstrk3)
prf <- performance(pr, measure = "tpr", x.measure = "fpr")
plot(prf)
auc <- performance(pr, measure = "auc")
auc <- auc@y.values[[1]]
auc

##[1] 0.7226642

One last note, when we analyze health survery data, we must be aware that self-reported prevalence may be biased because respondents may not be aware of their risk status. Therefore, to achieve more precise estimates, researchers are using laboratory tests as well as self-reported data.

Source code that created this post can be found here. I am happy to hear any feedback and questions.

Exploring the BRFSS Data and Predict Stroke was originally published by Susan Li at Susan Li | Data Ninja on May 08, 2017.

Explore Global Terrorist Attacks

2017-05-06T00:00:00+00:00

The Gloabl Terrorism database (GDS) is an open-source database including information on terrorist attacks around the world from 1970 through 2015. The dataset I am using contains more than 150,000 terrorism attacks worldwide from 1970 to 2015 except 1993.

terrorism <- read.csv('terrorism.csv', stringsAsFactors = F)

There are 137 columns in the dataset, to make it neat, I will have to do some subsetting, only keep the columns I need.

terrorism <- terrorism[,c("iyear","imonth", "iday", "country_txt", "region_txt", "provstate", "city", "latitude", "longitude", "attacktype1_txt", "targtype1_txt", "corp1", "target1", "natlty1_txt", "gname", "weaptype1_txt", "weapsubtype1_txt")]

Terrorist Attack Trends

library(ggplot2)
library(dplyr)
library(ggthemes)
by_year <- terrorism %>% group_by(iyear) %>% 
  summarise(n=n())
ggplot(aes(x = iyear, y = n), data = by_year) +
        geom_line(size = 2.5, alpha = 0.7, color = "mediumseagreen") +
        geom_point(size = 0.5) + xlab("Year") + ylab("Number of terrorist Attacks") +
        ggtitle("Terrorist Attacks Worldwide by Year 1970-2015") + theme_fivethirtyeight()

Globally, terrorist attacks have increased dramatically since 2010,

by_region <- terrorism %>% group_by(region_txt, iyear) %>% 
  summarise(n=n())
ggplot(by_region, aes(x = iyear, y = n, colour = region_txt)) + 
  geom_line() +
  geom_point() +
  facet_wrap(~region_txt) + xlab('Year') +
  ggtitle('Terrorist Attacks by Region and Year 1970-2015') + 
  theme(legend.position="none")

Central America was very unstable starting from the late 1970’s, it got better with time, and it has been stablized since around 1995.

Western Europe had a rough past, experienced many attacks until early 2000s.

South America had the similar pattern, was very dangerous since early 1980 until just before 2000.

Middle East, North Africa and South Asia had a relative quiet past unitl around 1980, the terrorist attacks in those regions had a steady increase from 1980s to around 2005, and had surged dramatically since then.

by_region_no_year <- terrorism %>% group_by(region_txt) %>% 
  summarise(n=n())
ggplot(aes(x=reorder(region_txt, n), y=n), data=by_region_no_year) +
  geom_bar(stat = 'identity') +
  ggtitle('Terrorist Attacks by Region 1970-2015') + coord_flip() + theme_fivethirtyeight()

A small fraction of the terrorist attacks happened in the Western countries. Most attacks were heavily concentrated geographically in Middle East, North Africa and South Asia.

Let’s look at the countries.

by_country <- terrorism %>% group_by(country_txt) %>% 
  summarise(n=n())
by_country <- arrange(by_country, desc(n))
top10 <- head(by_country, 10)
top10
ggplot(aes(x=reorder(country_txt, n), y=n), data=top10) + 
  geom_bar(stat = 'identity') + xlab('Country') + ylab('Number of Terrorist Attacks') + ggtitle('Countries with the most terrorist attacks, 1970-2015') +
  coord_flip() + theme_fivethirtyeight()

Iraq, Afghanistan and pakistan, India have suffered the most from terrorism. Surprisingly, United Kingdom tops the list in Europe, with almost 5000 attackes from 1970 to 2015.

Tactics and Weapons

by_attacktype <- terrorism %>% group_by(attacktype1_txt) %>% 
  summarise(n=n())
ggplot(aes(x=reorder(attacktype1_txt, n), y=n), data=by_attacktype) + 
  geom_bar(stat = 'identity') + xlab('Attack Type') + ylab('Number of Attacks') + ggtitle('Terrorist Attack Tactics Wordwide, 1970-2015') + coord_flip() +
  theme_fivethirtyeight()

by_weapon <- terrorism %>% group_by(weaptype1_txt) %>% 
  summarise(n=n())
ggplot(aes(x=reorder(weaptype1_txt, n), y=n), data=by_weapon) + 
  geom_bar(stat = 'identity') + xlab('Weapon') + ylab('Number of Attacks') + ggtitle('Terrorist Attack By Weapon Wordwide, 1970-2015') + coord_flip() +
  theme_fivethirtyeight()

The most commonly used attack tactic from 1970 to 2015 involved bomb and explosives, followed by armed assault.

Let’s look at the most recent year - 2015.

Casualties

To obtain more detailed death information, I went to US Department of State Website download a small dateset with casualty information.

library(xlsx)
library(reshape2)
casualties <- read.xlsx('casualties.xlsx', sheetIndex = 1, header = TRUE, stringsAsFactors = F)
casualties <- melt(casualties, id="month")
casualties<-casualties[!casualties$month=="Total",]
casualties$month <- ordered(casualties$month, levels=c('January', 'February', 'March', 'April', 'May', 'June', 'July', 'August', 'September', 'October', 'November', 'December'))
ggplot(aes(x=month, y=value, fill=variable), data=casualties) +
  geom_bar(stat = 'identity', position = position_dodge()) +
  ggtitle('Terrorist attacks and casualties worldwide by month, 2015') +
  theme_fivethirtyeight()

The total number of people killed in terrorist attacks peaked in April and July 2015, and the months with the most combined deaths and injuries were June, July, August, and September, January and May had the most kidnaps.

Perpetrators

Because there were so many unknown values in the original dataset, I have to fetch data again from US Department of State Website about terrorist group information.

group <- read.xlsx('group.xlsx', sheetIndex = 1, header=T, stringsAsFactors=F)
group <- melt(group, id = 'group_name')
group[5, 1] = "Kurdistan Workers' Party"
group[10, 1] = "Kurdistan Workers' Party"
group[15, 1] = "Kurdistan Workers' Party"
group[20, 1] = "Kurdistan Workers' Party"
ggplot(aes(x=group_name, y=value, fill=variable), data=group) +
  geom_bar(stat = 'identity', position = position_dodge()) + ggtitle('Terrorist Groups with the most Attacks Wordwide, 2015') +
  theme(axis.text.x = element_text(angle = 45, hjust = 1))

Along with the number of terrorist attacks they carried out, these five terrorist groups were responsible for the most terrorist attacks in 2015. Among those five groups, Islamic State of Iraq and the Levant (ISIL) is world’s deadliest terrorist organization and responsible for more than 6000 deaths in 2015.

Who are they targeting?

attack2015 <- terrorism[terrorism$iyear==2015, ]
by_target <- attack2015 %>% group_by(targtype1_txt) %>% 
  summarise(n=n())
by_target <- arrange(by_target, desc(n))
by_target
ggplot(aes(x=reorder(targtype1_txt, n), y=n), data=by_target) +
  geom_bar(stat = 'identity') + ggtitle('Terrorist Attack Targets/Victims, 2015') +
  coord_flip() + theme_fivethirtyeight()

Which countries/cities were the most dangerous in 2015?

attack2015_by_city <- attack2015 %>% group_by(country_txt, city) %>% 
  summarise(n=n())
attack2015_by_city <- arrange(attack2015_by_city, desc(n))
top10_city_2015 <- head(attack2015_by_city, 20)
top10_city_2015

## country_txt          city     n
##         <chr>         <chr> <int>
##1         Iraq       Baghdad   999
##2   Bangladesh         Dhaka   210
##3  Afghanistan       Unknown   160
##4        Libya      Benghazi   150
##5     Pakistan       Karachi   143
##6        Yemen          Aden   101
##7        Egypt         Arish    97
##8        Yemen         Sanaa    93
##9      Somalia     Mogadishu    92
##10       Yemen         Taizz    91
##11       Yemen       Unknown    91
##12        Iraq        Ramadi    87
##13       Syria      Damascus    86
##14    Pakistan        Quetta    84
##15       Syria        Aleppo    83
##16 Afghanistan         Kabul    80
##17       Egypt Sheikh Zuweid    74
##18     Burundi     Bujumbura    73
##19       Libya         Sirte    69
##20        Iraq        Madain    65

Baghdad was the most dangerous city in 2015, with approximately 1000 terrorist attacks in one year, but since when it became dangerous?

baghdad <- terrorism[terrorism$city=='Baghdad', ]
baghdad_year <- baghdad %>% group_by(iyear) %>% 
  summarise(n=n())
ggplot(aes(x = iyear, y = n), data = baghdad_year) +
        geom_line(size = 2.5, alpha = 0.7, color = "mediumseagreen") +
        geom_point(size = 0.5) + xlab("Year") + ylab("Number of terrorist Attacks") +
        ggtitle("Terrorist Attacks in Baghdad by Year 1970-2015") + theme_fivethirtyeight()

baghdad_type <- baghdad %>% group_by(attacktype1_txt, iyear) %>% 
  summarise(n=n())
ggplot(aes(x=iyear, y=n, fill=attacktype1_txt), data=baghdad_type) + 
  geom_bar(stat = 'identity') +
  ggtitle('Attack Type in Baghdad') + theme_fivethirtyeight()

Baghdad once was a prestigious learning and cultural center. Since the coalition invasion in 2003, it has become one of the most dangerous cities on Earth.

A heatmap of terrorist attack deaths worldwide 2015

gtd <- read.csv("terrorism.csv")
gtd2015 <- gtd[gtd$iyear==2015, ]
gtd2015 <- aggregate(nkill~country_txt,gtd2015,sum)
library(rworldmap)
gtdMap <- joinCountryData2Map( gtd2015, 
                               nameJoinColumn="country_txt", 
                               joinCode="NAME" )

mapDevice('x11')
mapCountryData( gtdMap, 
                nameColumnToPlot='nkill', 
                catMethod='fixedWidth', 
                numCats=100 )

Source code that created this post can be found here. I am happy to hear any feedback or questions.

Explore Global Terrorist Attacks was originally published by Susan Li at Susan Li | Data Ninja on May 06, 2017.

Data Mining with R: Predict Diabetes

2017-05-01T00:00:00+00:00

The dataset is originally from the National Institute of Diabetes and Digestive and Kidney Diseases. I downloaded from UCI Machine Learning Repository. The objective is to predict based on diagnostic measurements whether a patient has diabetes.

library(ggplot2)
library(dplyr)
library(gridExtra)
library(corrplot)

Look at the structure and the first few rows.

diabetes <- read.csv('diabetes.csv')
dim(diabetes)
str(diabetes)
head(diabetes)

##[1] 768   9
##'data.frame':	768 obs. of  9 variables:
## $ Pregnancies        : int  6 1 8 1 0 5 3 10 2 8 ...
## $ Glucose            : int  148 85 183 89 137 116 78 115 197 125 ...
## $ BloodPressure      : int  72 66 64 66 40 74 50 0 70 96 ...
## $ SkinThickness      : int  35 29 0 23 35 0 32 0 45 0 ...
## $ Insulin            : int  0 0 0 94 168 0 88 0 543 0 ...
## $ BMI                : num  33.6 26.6 23.3 28.1 43.1 25.6 31 35.3 30.5 0 ##...
## $ DiabetesPedigreeFunction: num  0.627 0.351 0.672 0.167 2.288 ...
## $ Age                     : int  50 31 32 21 33 30 26 29 53 54 ...
## $ Outcome                 : int  1 0 1 0 1 0 1 0 1 1 ...
##   Pregnancies Glucose BloodPressure SkinThickness Insulin  BMI
##1           6     148            72            35       0 33.6
##2           1      85            66            29       0 26.6
##3           8     183            64             0       0 23.3
##4           1      89            66            23      94 28.1
##5           0     137            40            35     168 43.1
##6           5     116            74             0       0 25.6
##  DiabetesPedigreeFunction Age Outcome
##1                    0.627  50       1
##2                    0.351  31       0
##3                    0.672  32       1
##4                    0.167  21       0
##5                    2.288  33       1
##6                    0.201  30       0

Exploratory Data Analysis and Feature Selection

Check missing values

cat("Number of missing value:", sum(is.na(diabetes)), "\n")

##Number of missing value: 0

Staitstical summary

summary(diabetes)

## Pregnancies    Glucose   BloodPressure    SkinThickness      Insulin    
## Min.: 0.000   Min.   :  0.0   Min.   :  0.00   Min.   : 0.00   Min.   : 0.0
## 1st Qu.:1.000  1st Qu.: 99.0  1st Qu.: 62.00   1st Qu.: 0.00   1st Qu.: 0.0 ##Median : 3.000  Median :117.0  Median : 72.00   Median :23.00   Median :30.5 ## Mean : 3.845   Mean   :120.9  Mean   : 69.11   Mean   :20.54   Mean   :79.8 ##3rd Qu.: 6.000  3rd Qu.:140.2  3rd Qu.: 80.00   3rd Qu.:32.00  3rd Qu.:127.2 ##Max.   :17.000  Max.   :199.0  Max.   :122.00   Max.   :99.00   Max.  :846.0  
##      BMI        DiabetesPedigreeFunction      Age           Outcome     
## Min.   : 0.00   Min.   :0.0780           Min.   :21.00   Min.   :0.000  
## 1st Qu.:27.30   1st Qu.:0.2437           1st Qu.:24.00   1st Qu.:0.000  
## Median :32.00   Median :0.3725           Median :29.00   Median :0.000  
## Mean   :31.99   Mean   :0.4719           Mean   :33.24   Mean   :0.349  
## 3rd Qu.:36.60   3rd Qu.:0.6262           3rd Qu.:41.00   3rd Qu.:1.000  
## Max.   :67.10   Max.   :2.4200           Max.   :81.00   Max.   :1.000

Histogram of numeric variables

p1 <- ggplot(diabetes, aes(x=Pregnancies)) + ggtitle("Number of times pregnant") +
  geom_histogram(aes(y = 100*(..count..)/sum(..count..)), binwidth = 1, colour="black", fill="white") + ylab("Percentage")
p2 <- ggplot(diabetes, aes(x=Glucose)) + ggtitle("Glucose") +
  geom_histogram(aes(y = 100*(..count..)/sum(..count..)), binwidth = 5, colour="black", fill="white") + ylab("Percentage")
p3 <- ggplot(diabetes, aes(x=BloodPressure)) + ggtitle("Blood Pressure") +
  geom_histogram(aes(y = 100*(..count..)/sum(..count..)), binwidth = 2, colour="black", fill="white") + ylab("Percentage")
p4 <- ggplot(diabetes, aes(x=SkinThickness)) + ggtitle("Skin Thickness") +
  geom_histogram(aes(y = 100*(..count..)/sum(..count..)), binwidth = 2, colour="black", fill="white") + ylab("Percentage")
p5 <- ggplot(diabetes, aes(x=Insulin)) + ggtitle("Insulin") +
  geom_histogram(aes(y = 100*(..count..)/sum(..count..)), binwidth = 20, colour="black", fill="white") + ylab("Percentage")
p6 <- ggplot(diabetes, aes(x=BMI)) + ggtitle("Body Mass Index") +
  geom_histogram(aes(y = 100*(..count..)/sum(..count..)), binwidth = 1, colour="black", fill="white") + ylab("Percentage")
p7 <- ggplot(diabetes, aes(x=DiabetesPedigreeFunction)) + ggtitle("Diabetes Pedigree Function") +
  geom_histogram(aes(y = 100*(..count..)/sum(..count..)), colour="black", fill="white") + ylab("Percentage")
p8 <- ggplot(diabetes, aes(x=Age)) + ggtitle("Age") +
  geom_histogram(aes(y = 100*(..count..)/sum(..count..)), binwidth=1, colour="black", fill="white") + ylab("Percentage")
grid.arrange(p1, p2, p3, p4, p5, p6, p7, p8, ncol=2)

All the variables seem to have reasonable broad distribution, therefore, will be kept for the regression analysis.

Correlation Between Numeric Varibales

numeric.var <- sapply(diabetes, is.numeric)
corr.matrix <- cor(diabetes[,numeric.var])
corrplot(corr.matrix, main="\n\nCorrelation Plot for Numerical Variables", order = "hclust", tl.col = "black", tl.srt=45, tl.cex=0.5, cl.cex=0.5)

The numeric variabls are almost not correlated.

Correlation bewteen numeric variables and outcome.

attach(diabetes)
par(mfrow=c(2,4))
boxplot(Pregnancies~Outcome, main="No. of Pregnancies vs. Diabetes", 
        xlab="Outcome", ylab="Pregnancies")
boxplot(Glucose~Outcome, main="Glucose vs. Diabetes", 
        xlab="Outcome", ylab="Glucose")
boxplot(BloodPressure~Outcome, main="Blood Pressure vs. Diabetes", 
        xlab="Outcome", ylab="Blood Pressure")
boxplot(SkinThickness~Outcome, main="Skin Thickness vs. Diabetes", 
        xlab="Outcome", ylab="Skin Thickness")
boxplot(Insulin~Outcome, main="Insulin vs. Diabetes", 
        xlab="Outcome", ylab="Insulin")
boxplot(BMI~Outcome, main="BMI vs. Diabetes", 
        xlab="Outcome", ylab="BMI")
boxplot(DiabetesPedigreeFunction~Outcome, main="Diabetes Pedigree Function vs. Diabetes", xlab="Outcome", ylab="DiabetesPedigreeFunction")
boxplot(Age~Outcome, main="Age vs. Diabetes", 
        xlab="Outcome", ylab="Age")

Blood pressure and skin thickness show little variation with diabetes, they will be excluded from the model. Other variables show more or less correlation with diabetes, so will be kept.

Logistic Regression

diabetes$BloodPressure <- NULL
diabetes$SkinThickness <- NULL
train <- diabetes[1:540,]
test <- diabetes[541:768,]
model <-glm(Outcome ~.,family=binomial(link='logit'),data=train)
summary(model)

##Call:
##glm(formula = Outcome ~ ., family = binomial(link = "logit"), 
##    data = train)

##Deviance Residuals: 
##    Min       1Q   Median       3Q      Max  
##-2.4366  -0.7741  -0.4312   0.8021   2.7310  

##Coefficients:
##                           Estimate Std. Error z value Pr(>|z|)    
##(Intercept)              -8.3461752  0.8157916 -10.231  < 2e-16 ***
##Pregnancies               0.1246856  0.0373214   3.341 0.000835 ***
##Glucose                   0.0315778  0.0042497   7.431 1.08e-13 ***
##Insulin                  -0.0013400  0.0009441  -1.419 0.155781    
##BMI                       0.0881521  0.0164090   5.372 7.78e-08 ***
##DiabetesPedigreeFunction  0.9642132  0.3430094   2.811 0.004938 ** 
##Age                       0.0018904  0.0107225   0.176 0.860053    
##---
##Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

##(Dispersion parameter for binomial family taken to be 1)

##    Null deviance: 700.47  on 539  degrees of freedom
##Residual deviance: 526.56  on 533  degrees of freedom
##AIC: 540.56

##Number of Fisher Scoring iterations: 5

The top three most relevant features are “Glucose”, “BMI” and “Number of times pregnant” because of the low p-values.

“Insulin” and “Age” appear not statistically significant.

anova(model, test="Chisq")

##Analysis of Deviance Table

##Model: binomial, link: logit

##Response: Outcome

##Terms added sequentially (first to last)


##                         Df Deviance Resid. Df Resid. Dev  Pr(>Chi)    
##NULL                                       539     700.47              
##Pregnancies               1   26.314       538     674.16 2.901e-07 ***
##Glucose                   1  102.960       537     571.20 < 2.2e-16 ***
##Insulin                   1    0.062       536     571.14  0.803341    
##BMI                       1   36.135       535     535.00 1.841e-09 ***
##DiabetesPedigreeFunction  1    8.414       534     526.59  0.003723 ** 
##Age                       1    0.031       533     526.56  0.860201    
##---
##Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

From the table of deviance, we can see that adding insulin and age have little effect on the residual deviance.

Cross Validation

fitted.results <- predict(model,newdata=test,type='response')
fitted.results <- ifelse(fitted.results > 0.5,1,0)
misClasificError <- mean(fitted.results != test$Outcome)
print(paste('Accuracy',1-misClasificError))

##[1] "Accuracy 0.789473684210526"

Decision Tree

library(rpart)
model2 <- rpart(Outcome ~ Pregnancies + Glucose + BMI + DiabetesPedigreeFunction, data=train,method="class")
plot(model2, uniform=TRUE, 
  	main="Classification Tree for Diabetes")
text(model2, use.n=TRUE, all=TRUE, cex=.8)

This means if a person’s BMI less than 45.4 and her diabetes digree function less than 0.8745, then she is more likely to have diabetes.

Confusion table and accuracy

treePred <- predict(model2, test, type = 'class')
table(treePred, test$Outcome)
mean(treePred==test$Outcome)

##treePred   0   1
##       0 121  29
##       1  29  49

##[1] 0.745614

In this project, I compared the performance of Logistic Regression and Decision Tree algorithms and found that Logistic Regression performed better on this standard, unaltered dataset. However, there are things we can do to improve the generalization performance in decision tree induction such as pruning. I will perform that in the future posts.

Source code that created this post can be found here. I am happy to hear any feedback or questions.

Data Mining with R: Predict Diabetes was originally published by Susan Li at Susan Li | Data Ninja on May 01, 2017.

Text Mining Charles Dicken’s Novels

2017-04-25T00:00:00+00:00

via GIPHY

Dickens wrote fourteen and a half novels. I will start from analyzing five of them - “A Tale of Two Cities”, “Great Expectations”, “A Christmas Carol in Prose; Being a Ghost Story of Christmas”, “Oliver Twist” and “Hard Times”.

Project Gutenberg offers over 53,000 free books. I will download Dickens’ novels in UTF-8 encoded texts from there using gutenbergr package developed by David Robinson. Besides, I will be using the following packages for this project.

library(dplyr)
library(tm.plugin.webmining)
library(purrr)
library(tidytext)
library(gutenbergr)
library(ggplot2)

dickens <- gutenberg_download(c(98, 1400, 46, 730, 786))

Download Dickens’ five novels by Project Gutenberg ID numbers.

tidy_dickens <- dickens %>%
  unnest_tokens(word, text) %>%
  anti_join(stop_words)

The unnest_tokens package is used to split each row so that there is one token (word) in each row of the new data frame (tidy_dickens). Then remove stop words with an anti_join function.

tidy_dickens %>%
  count(word, sort = TRUE)

### A tibble: 19,634 × 2
##     word     n
##    <chr> <int>
##1    time  1218
##2    hand   918
##3   night   835
##4  looked   814
##5    head   813
##6  oliver   766
##7    dear   751
##8     joe   718
##9    miss   702
##10    sir   697
### ... with 19,624 more rows

After removing the stop words, here is a list of words starts from the most frequent.

tidy_dickens %>%
  count(word, sort = TRUE) %>%
  filter(n > 600) %>%
  mutate(word = reorder(word, n)) %>%
  ggplot(aes(word, n)) +
  geom_col() +
  xlab(NULL) +
  coord_flip() + ggtitle("The Most Common Words in Charles Dickens' Novels")

Sentiment in Dickens’ Five Novels

tidytext package contains several sentiment lexicons, I am using “bing” for the following tasks.

bing_word_counts <- tidy_dickens %>%
  inner_join(get_sentiments("bing")) %>%
  count(word, sentiment, sort = TRUE) %>%
  ungroup()
bing_word_counts

### A tibble: 3,145 × 3
##     word sentiment     n
##    <chr>     <chr> <int>
##1    miss  negative   702
##2    poor  negative   350
##3    dark  negative   299
##4    hard  negative   223
##5    dead  negative   218
##6  strong  positive   203
##7    love  positive   202
##8    fell  negative   198
##9   death  negative   194
##10   cold  negative   192
### ... with 3,135 more rows

Here I got the sentiment categories of Dickens’ words.

bing_word_counts %>%
  group_by(sentiment) %>%
  top_n(10) %>%
  ungroup() %>%
  mutate(word = reorder(word, n)) %>%
  ggplot(aes(word, n, fill = sentiment)) +
  geom_col(show.legend = FALSE) +
  facet_wrap(~sentiment, scales = "free_y") +
  labs(y = "Words Contribute to sentiment",
       x = NULL) +
  coord_flip()

The word “miss” is the most frequent negative word here, but it is used to describe unmarried women in Dickens’ works. In particualr, Miss Havisham is a significant character in the Charles Dickens novel “Great Expectations”. Dickens describes her as looking like “the witch of the place”. In this case, probably “miss”” should be a negative word.

via GIPHY

Oh poor Pip!

library(wordcloud)
tidy_dickens %>%
  anti_join(stop_words) %>%
  count(word) %>%
  with(wordcloud(word, n, max.words = 100))

Word cloud is a good idea to identify trends and patterns that would otherwise be unclear or difficult to see in a tabular format.

library(reshape2)
tidy_dickens %>%
  inner_join(get_sentiments("bing")) %>%
  count(word, sentiment, sort = TRUE) %>%
  acast(word ~ sentiment, value.var = "n", fill = 0) %>%
  comparison.cloud(colors = c("#F8766D", "#00BFC4"),
                   max.words = 100)

And compare most frequent positive and negative words in word cloud.

Relationships between words

dickens_bigrams <- dickens %>%
  unnest_tokens(bigram, text, token = "ngrams", n = 2)
dickens_bigrams

### A tibble: 616,994 × 2
##   gutenberg_id          bigram
##          <int>           <chr>
##1            46     a christmas
##2            46 christmas carol
##3            46        carol in
##4            46        in prose
##5            46     prose being
##6            46         being a
##7            46         a ghost
##8            46     ghost story
##9            46        story of
##10           46    of christmas
### ... with 616,984 more rows

Each token now represents a bigram (two words paired). if one of the words in the bigram is a stop word, this word will be removed. After filtering out stop words, what are the most frequent bigrams?

library(tidyr)
bigrams_separated <- dickens_bigrams %>%
  separate(bigram, c("word1", "word2"), sep = " ")
bigrams_filtered <- bigrams_separated %>%
  filter(!word1 %in% stop_words$word) %>%
  filter(!word2 %in% stop_words$word)
bigram_counts <- bigrams_filtered %>% 
  count(word1, word2, sort = TRUE)
bigram_counts

##Source: local data frame [41,584 x 3]
##Groups: word1 [10,206]

##    word1      word2     n
##    <chr>      <chr> <int>
##1    miss   havisham   236
##2    miss      pross   144
##3  madame    defarge   113
##4    dear        boy    77
##5      ha         ha    77
##6  doctor    manette    75
##7    miss havisham's    74
##8  oliver      twist    55
##9     sir    replied    54
##10   wine       shop    52
### ... with 41,574 more rows

Names are the most common paired words in Dickens’ novels.

bigrams_united <- bigrams_filtered %>%
  unite(bigram, word1, word2, sep = " ")
bigrams_united

### A tibble: 51,379 × 2
##   gutenberg_id            bigram
##*         <int>             <chr>
##1            46   christmas carol
##2            46       ghost story
##3            46   charles dickens
##4            46   dickens preface
##5            46 houses pleasantly
##6            46   faithful friend
##7            46     december 1843
##8            46     1843 contents
##9            46    contents stave
##10           46    marley's ghost
### ... with 51,369 more rows

Before visualizing it, I have to make these bigrams back to be united.

bigram_tf_idf <- bigrams_united %>%
  count(bigram)
bigram_tf_idf <- bigram_tf_idf %>% filter(n>30)
ggplot(aes(x = reorder(bigram, n), y=n), data=bigram_tf_idf) + geom_bar(stat = 'identity') + ggtitle("The Most Common Bigrams in Dickens' novels") + coord_flip()

Yes, the most frequent bigrams in Dickens’ works are names. I also notice some pairings of a common verb such as “wine shop” from “A Tale of Two Cities” and “oliver twist”.

At last, visualizing a network of bigrams of Dickens’ five novels.

library(igraph)
bigram_graph <- bigram_counts %>%
  filter(n > 20) %>%
  graph_from_data_frame()
bigram_graph

##IGRAPH DN-- 61 37 -- 
##+ attr: name (v/c), n (e/n)
##+ edges (vertex names):
## [1] miss    ->havisham   miss    ->pross      madame  ->defarge   
## [4] dear    ->boy        ha      ->ha         doctor  ->manette   
## [7] miss    ->havisham's oliver  ->twist      sir     ->replied   
##[10] wine    ->shop       charles ->darnay     replied ->oliver    
##[13] master  ->bates      miss    ->manette    saint   ->antoine   
##[16] james   ->harthouse  sir     ->returned   charley ->bates     
##[19] low     ->voice      stephen ->blackpool  sydney  ->carton    
##[22] god     ->bless      monsieur->defarge    public  ->house     
##+ ... omitted several edges

library(ggraph)
set.seed(2017)
ggraph(bigram_graph, layout = "fr") +
  geom_edge_link() +
  geom_node_point(color = "darkslategray4", size = 3) +
  geom_node_text(aes(label = name), vjust = 1.8) + ggtitle("Common Bigrams in Dickens' five Novels")

Wow, that was so much fun! I don’t want to finish as yet. I want to look into one of these five novels - “A Tale of Two Cities”.

This time I will download the plain text file for “A Tale of Two Cities” only, leave out the Project Gutenberg header and footer information, then concatenate these lines into paragraphs as following:

library(readr)
library(stringr)
raw_tale <- read_lines("ta98-0.txt", skip = 30, n_max = 15500)
tale <- character()
for (i in seq_along(raw_tale)) {
        if (i%%10 == 1) tale[ceiling(i/10)] <- str_c(raw_tale[i], 
                                                     raw_tale[i+1],
                                                     raw_tale[i+2],
                                                     raw_tale[i+3],
                                                     raw_tale[i+4],
                                                     raw_tale[i+5],
                                                     raw_tale[i+6],
                                                     raw_tale[i+7],
                                                     raw_tale[i+8],
                                                     raw_tale[i+9], sep = " ")
}

tale[9:10]

##[1] "I. The Period   It was the best of times, it was the worst of times, it ##was the age of wisdom, it was the age of foolishness, it was the epoch of ##belief, it was the epoch of incredulity, it was the season of Light,"                                                                                    ##[2] "it was the season of Darkness, it was the spring of hope, it was the ##winter of despair, we had everything before us, we had nothing before us, we ##were all going direct to Heaven, we were all going direct the other way-- in ##short, the period was so far like the present period, that some of its ##noisiest authorities insisted on its being received, for good or for evil, ##in the superlative degree of comparison only."

Sentiment in “A Tale of Two Cities”

Apply NRC sentiment dictionary to this novel.

library(syuzhet)
tale_nrc <- cbind(linenumber = seq_along(tale), get_nrc_sentiment(tale))

Create a data frame combine the line number of the book with the sentiment score, then extract positive and negative scores for visualization.

tale_nrc$negative <- -tale_nrc$negative
pos_neg <- tale_nrc %>% select(linenumber, positive, negative) %>% 
        melt(id = "linenumber")
names(pos_neg) <- c("linenumber", "sentiment", "value")

library(ggthemes)
ggplot(data = pos_neg, aes(x = linenumber, y = value, fill = sentiment)) +
        geom_bar(stat = 'identity', position = position_dodge()) + theme_minimal() +
        ylab("Sentiment") + 
        ggtitle("Positive and Negative Sentiment in A Tale of Two Cities") +
  scale_color_manual(values = c("orange", "blue")) +
  scale_fill_manual(values = c("orange", "blue"))

Seems the positive scores and the negative scores are almost equal overall, it does make sense given the content of the novel.

emotions <- tale_nrc %>% select(linenumber, anger, anticipation, 
                                      disgust, fear, joy, sadness, surprise, 
                                      trust) %>% 
        melt(id = "linenumber")
names(emotions) <- c("linenumber", "sentiment", "value")
emotions_group <- group_by(emotions, sentiment)
by_emotions <- summarise(emotions_group, 
                         values=sum(value))
ggplot(aes(reorder(x=sentiment, values), y=values, fill=sentiment), data = by_emotions) +
  geom_bar(stat = 'identity') + ggtitle('Sentiment in A Tale of Two Cities') +
  coord_flip() + theme(legend.position="none")

The End

Again, that was so much fun, my post just touched a bit of it on text mining. There are many more things to do such as comparing text across different novelists, save it to the next time.

Source code that created this post can be found here. I am happy to hear any feedback and questions.

References:

The gutenbergr package

Text Mining With R

Text Mining Charles Dicken’s Novels was originally published by Susan Li at Susan Li | Data Ninja on April 25, 2017.

Predict Income Level from Census Data

2017-04-20T00:00:00+00:00

The data was extracted from 1994 Census bureau database. However, I downloaded from Kaggle at UCI Machine Learning Repository. The prediction task is to determine whether a person makes over $50K a year.

The data contains 32561 observations (people) and 15 variables. A high level summary of the data is below.

income <- read.csv('adult.csv', na.strings = c('','?'))
str(income)

##'data.frame':	32561 obs. of  15 variables:
## $ age           : int  90 82 66 54 41 34 38 74 68 41 ...
## $ workclass     : Factor w/ 8 levels "Federal-gov",..: NA 4 NA 4 4 4 4 7 1 4 ##...
## $ fnlwgt        : int  77053 132870 186061 140359 264663 216864 150601 88638 ##422013 70037 ...
## $ education     : Factor w/ 16 levels "10th","11th",..: 12 12 16 6 16 12 1 11 ##12 16 ...
## $ education.num : int  9 9 10 4 10 9 6 16 9 10 ...
## $ marital.status: Factor w/ 7 levels "Divorced","Married-AF-spouse",..: 7 7 7 ##1 6 1 6 5 1 5 ...
## $ occupation    : Factor w/ 14 levels "Adm-clerical",..: NA 4 NA 7 10 8 1 10 ##10 3 ...
## $ relationship  : Factor w/ 6 levels "Husband","Not-in-family",..: 2 2 5 5 4 ##5 5 3 2 5 ...
## $ race          : Factor w/ 5 levels "Amer-Indian-Eskimo",..: 5 5 3 5 5 5 5 5 ##5 5 ...
## $ sex           : Factor w/ 2 levels "Female","Male": 1 1 1 1 1 1 2 1 1 2 ...
## $ capital.gain  : int  0 0 0 0 0 0 0 0 0 0 ...
## $ capital.loss  : int  4356 4356 4356 3900 3900 3770 3770 3683 3683 3004 ...
## $ hours.per.week: int  40 18 40 40 40 45 40 20 40 60 ...
## $ native.country: Factor w/ 41 levels "Cambodia","Canada",..: 39 39 39 39 39 ##39 39 39 39 NA ...
## $ income        : Factor w/ 2 levels "<=50K",">50K": 1 1 1 1 1 1 1 2 1 2 ...

Statistics summary after changing missing values to ‘NA’.

summary(income)

##    age           workclass         fnlwgt               education   
## Min.   :17.00   Private         :22696   Min.   :  12285   HS-grad     :10501
## 1st Qu.:28.00   Self-emp-not-inc: 2541   1st Qu.: 117827   Some-college: 7291
## Median :37.00   Local-gov       : 2093   Median : 178356   Bachelors   : 5355
## Mean   :38.58   State-gov       : 1298   Mean   : 189778   Masters     : 1723
## 3rd Qu.:48.00   Self-emp-inc    : 1116   3rd Qu.: 237051   Assoc-voc   : 1382
## Max.   :90.00   (Other)         :  981   Max.   :1484705   11th        : 1175 ##                  NA's           : 1836                     (Other)     : 5134  
## education.num                 marital.status            occupation   
## Min.   : 1.00   Divorced             : 4443   Prof-specialty : 4140  
## 1st Qu.: 9.00   Married-AF-spouse    :   23   Craft-repair   : 4099  
## Median :10.00   Married-civ-spouse   :14976   Exec-managerial: 4066  
## Mean   :10.08   Married-spouse-absent:  418   Adm-clerical   : 3770  
## 3rd Qu.:12.00   Never-married        :10683   Sales          : 3650  
## Max.   :16.00   Separated            : 1025   (Other)        :10993  
##                 Widowed              :  993   NA's           : 1843  

##      relationship              race           sex         capital.gain  
## Husband  :13193   Amer-Indian-Eskimo:  311   Female:10771   Min.   :    0  
## Not-in-family :8305 Asian-Pac-Islander: 1039 Male  :21790   1st Qu.:    0  
## Other-relative:981   Black           : 3124                 Median :    0  
## Own-child     : 5068 Other           :  271                 Mean   : 1078  
## Unmarried     : 3446 White           :27816                 3rd Qu.:    0  
## Wife          : 1568                                        Max.   :99999  
##                                                                              ## capital.loss    hours.per.week        native.country    income     
## Min.   :   0.0   Min.   : 1.00   United-States:29170   <=50K:24720  
## 1st Qu.:   0.0   1st Qu.:40.00   Mexico       :  643   >50K : 7841  
## Median :   0.0   Median :40.00   Philippines  :  198                
## Mean   :  87.3   Mean   :40.44   Germany      :  137                
## 3rd Qu.:   0.0   3rd Qu.:45.00   Canada       :  121                
## Max.   :4356.0   Max.   :99.00   (Other)      : 1709                
##                                  NA's         :  583

Data Cleaning Process

Check for ‘NA’ values and look how many unique values there are for each variable.

sapply(income,function(x) sum(is.na(x)))

##         age      workclass         fnlwgt      education  education.num 
##             0           1836              0              0              0 
##marital.status     occupation   relationship           race            sex 
##             0           1843              0              0              0 
##  capital.gain   capital.loss hours.per.week native.country         income 
##             0              0              0            583              0

sapply(income, function(x) length(unique(x)))

##  age      workclass         fnlwgt      education  education.num 
##            73              9          21648             16             16 
##marital.status     occupation   relationship           race            sex 
##             7             15              6              5              2 
##  capital.gain   capital.loss hours.per.week native.country         income 
##           119             92             94             42              2

library(Amelia)
missmap(income, main = "Missing values vs observed")
table (complete.cases (income))

##FALSE  TRUE 
## 2399 30162

Approximate 7%(2399/32561) of the total data has missing value. They are mainly in variables ‘occupation’, ‘workclass’ and ‘native country’. I decided to remove those missing values because I don’t think its a good idea to replace categorical values by imputing.

income <- income[complete.cases(income),]

Explore Numeric Variables With Income Levels

library(ggplot2)
library(gridExtra)
p1 <- ggplot(aes(x=income, y=age), data = income) + geom_boxplot() + 
  ggtitle('Age vs. Income Level')
p2 <- ggplot(aes(x=income, y=education.num), data = income) + geom_boxplot() +
  ggtitle('Years of Education vs. Income Level')
p3 <- ggplot(aes(x=income, y=hours.per.week), data = income) + geom_boxplot() + 
  ggtitle('Hours Per Week vs. Income Level')
p4 <- ggplot(aes(x=income, y=capital.gain), data=income) + geom_boxplot() + 
  ggtitle('Capital Gain vs. Income Level')
p5 <- ggplot(aes(x=income, y=capital.loss), data=income) + geom_boxplot() +
  ggtitle('Capital Loss vs. Income Level')
p6 <- ggplot(aes(x=income, y=fnlwgt), data=income) + geom_boxplot() +
  ggtitle('Final Weight vs. Income Level')
grid.arrange(p1, p2, p3, p4, p5, p6, ncol=3)

“Age”, “Years of education” and “hours per week” all show significant variations with income level. Therefore, they will be kept for the regression analysis. “Final Weight” does not show any variation with income level, therefore, it will be excluded from the analysis. Its hard to see whether “Capital gain” and “Capital loss” have variation with Income level from the above plot, so I will keep them for now.

income$fnlwgt <- NULL

Explore Categorical Variables With Income Levels

library(dplyr)
by_workclass <- income %>% group_by(workclass, income) %>% summarise(n=n())
by_education <- income %>% group_by(education, income) %>% summarise(n=n())
by_education$education <- ordered(by_education$education, 
                                   levels = c('Preschool', '1st-4th', '5th-6th', '7th-8th', '9th', '10th', '11th', '12th', 'HS-grad', 'Prof-school', 'Assoc-acdm', 'Assoc-voc', 'Some-college', 'Bachelors', 'Masters', 'Doctorate'))
by_marital <- income %>% group_by(marital.status, income) %>% summarise(n=n())
by_occupation <- income %>% group_by(occupation, income) %>% summarise(n=n())
by_relationship <- income %>% group_by(relationship, income) %>% summarise(n=n())
by_race <- income %>% group_by(race, income) %>% summarise(n=n())
by_sex <- income %>% group_by(sex, income) %>% summarise(n=n())
by_country <- income %>% group_by(native.country, income) %>% summarise(n=n())

p7 <- ggplot(aes(x=workclass, y=n, fill=income), data=by_workclass) + geom_bar(stat = 'identity', position = position_dodge()) + ggtitle('Workclass with Income Level') + theme(axis.text.x = element_text(angle = 45, hjust = 1))
p8 <- ggplot(aes(x=education, y=n, fill=income), data=by_education) + geom_bar(stat = 'identity', position = position_dodge()) + ggtitle('Education vs. Income Level') + coord_flip()
p9 <- ggplot(aes(x=marital.status, y=n, fill=income), data=by_marital) + geom_bar(stat = 'identity', position=position_dodge()) + ggtitle('Marital Status vs. Income Level') + theme(axis.text.x = element_text(angle = 45, hjust = 1))
p10 <- ggplot(aes(x=occupation, y=n, fill=income), data=by_occupation) + geom_bar(stat = 'identity', position=position_dodge()) + ggtitle('Occupation vs. Income Level') + coord_flip()
p11 <- ggplot(aes(x=relationship, y=n, fill=income), data=by_relationship) + geom_bar(stat = 'identity', position=position_dodge()) + ggtitle('Relationship vs. Income Level') + coord_flip()
p12 <- ggplot(aes(x=race, y=n, fill=income), data=by_race) + geom_bar(stat = 'identity', position = position_dodge()) + ggtitle('Race vs. Income Level') + coord_flip()
p13 <- ggplot(aes(x=sex, y=n, fill=income), data=by_sex) + geom_bar(stat = 'identity', position = position_dodge()) + ggtitle('Sex vs. Income Level')
p14 <- ggplot(aes(x=native.country, y=n, fill=income), data=by_country) + geom_bar(stat = 'identity', position = position_dodge()) + ggtitle('Native Country vs. Income Level') + coord_flip()
grid.arrange(p7, p8, p9, p10, ncol=2)
grid.arrange(p11, p12, p13, p14, ncol=2)

Most of the data was collected from the United States, so variable “native country” does not have effect on my analysis, I will exclude it from regression model. And all the other categorial variables seem to have reasonable variation, so will be kept.

income$native.country <- NULL

income$income = as.factor(ifelse(income$income==income$income[1],0,1))

Convert income level to 0’s and 1’s,”<=50K” will be 0 and “>50K”” will be 1(binary outcome).

Model Fitting

split the data into two chunks: training and testing set.

train <- income[1:24000,]
test <- income[24001:30162,]

Fit the model

model <-glm(income ~.,family=binomial(link='logit'),data=train)
summary(model)

##Call:
##glm(formula = income ~ ., family = binomial(link = "logit"), 
##    data = train)

##Deviance Residuals: 
##    Min       1Q   Median       3Q      Max  
##-5.1023  -0.5221  -0.1872   0.0581   3.3415  

##Coefficients: (1 not defined because of singularities)
##                                  Estimate Std. Error z value Pr(>|z|)    
##(Intercept)                     -6.946e+00  4.711e-01 -14.743  < 2e-16 ***
##age                              2.436e-02  1.888e-03  12.899  < 2e-16 ***
##workclassLocal-gov              -6.826e-01  1.259e-01  -5.420 5.97e-08 ***
##workclassPrivate                -4.959e-01  1.049e-01  -4.727 2.28e-06 ***
##workclassSelf-emp-inc           -3.309e-01  1.383e-01  -2.392 0.016734 *  
##workclassSelf-emp-not-inc       -1.004e+00  1.228e-01  -8.181 2.82e-16 ***
##workclassState-gov              -7.998e-01  1.401e-01  -5.708 1.15e-08 ***
##workclassWithout-pay            -1.306e+01  2.386e+02  -0.055 0.956366    
##education11th                   -7.654e-03  2.285e-01  -0.034 0.973272    
##education12th                    2.253e-01  3.101e-01   0.727 0.467456    
##education1st-4th                -6.456e-01  5.343e-01  -1.208 0.226955    
##education5th-6th                -7.638e-01  3.970e-01  -1.924 0.054348 .  
##education7th-8th                -7.297e-01  2.656e-01  -2.748 0.006003 ** 
##education9th                    -6.099e-01  3.093e-01  -1.972 0.048662 *  
##educationAssoc-acdm              1.165e+00  1.941e-01   6.003 1.94e-09 ***
##educationAssoc-voc               1.088e+00  1.863e-01   5.840 5.23e-09 ***
##educationBachelors               1.784e+00  1.721e-01  10.366  < 2e-16 ***
##educationDoctorate               2.773e+00  2.433e-01  11.397  < 2e-16 ***
##educationHS-grad                 6.298e-01  1.671e-01   3.769 0.000164 ***
##educationMasters                 2.116e+00  1.851e-01  11.433  < 2e-16 ***
##educationPreschool               -2.026e+01  1.422e+02  -0.142 0.886719    
##educationProf-school             2.641e+00  2.266e-01  11.654  < 2e-16 ***
##educationSome-college            9.415e-01  1.698e-01   5.544 2.96e-08 ***
##education.num                           NA         NA      NA       NA    
##marital.statusMarried-AF-spouse  3.113e+00  6.846e-01   4.548 5.43e-06 ***
##marital.statusMarried-civ-spouse 2.071e+00  3.025e-01   6.846 7.57e-12 ***
##marital.statusMarried-spouse-absent -9.842e-02  2.684e-01  -0.367 0.713876    
##marital.statusNever-married     -4.215e-01  9.933e-02  -4.243 2.20e-05 ***
##marital.statusSeparated          4.981e-02  1.795e-01   0.277 0.781443    
##marital.statusWidowed            1.641e-01  1.811e-01   0.906 0.364857    
##occupationArmed-Forces          -1.030e+00  1.519e+00  -0.678 0.497620    
##occupationCraft-repair           1.312e-01  8.996e-02   1.458 0.144763    
##occupationExec-managerial         8.642e-01  8.719e-02   9.912  < 2e-16 ***
##occupationFarming-fishing        -9.219e-01  1.556e-01  -5.927 3.09e-09 ***
##occupationHandlers-cleaners      -6.340e-01  1.624e-01  -3.903 9.50e-05 ***
##occupationMachine-op-inspct      -2.581e-01  1.148e-01  -2.248 0.024571 *  
##occupationOther-service          -7.466e-01  1.302e-01  -5.735 9.74e-09 ***
##occupationPriv-house-serv        -4.065e+00  1.761e+00  -2.309 0.020966 *  
##occupationProf-specialty          5.969e-01  9.185e-02   6.499 8.11e-11 ***
##occupationProtective-serv         6.089e-01  1.401e-01   4.345 1.39e-05 ***
##occupationSales                   3.265e-01  9.278e-02   3.519 0.000434 ***
##occupationTech-support            7.090e-01  1.247e-01   5.684 1.31e-08 ***
##occupationTransport-moving        6.729e-03  1.104e-01   0.061 0.951385    
##relationshipNot-in-family         3.903e-01  2.989e-01   1.306 0.191598    
##relationshipOther-relative       -4.501e-01  2.736e-01  -1.645 0.100029    
##relationshipOwn-child            -7.227e-01  2.971e-01  -2.433 0.014990 *  
##relationshipUnmarried             2.333e-01  3.171e-01   0.736 0.461827    
##relationshipWife                 1.344e+00  1.176e-01  11.424  < 2e-16 ***
##raceAsian-Pac-Islander           2.932e-01  2.811e-01   1.043 0.296968    
##raceBlack                        4.212e-01  2.667e-01   1.579 0.114232    
##raceOther                       -5.576e-01  4.370e-01  -1.276 0.201988    
##raceWhite                        4.978e-01  2.549e-01   1.953 0.050844 .  
##sexMale                          8.690e-01  8.981e-02   9.677  < 2e-16 ***
##capital.gain                     3.239e-04  1.083e-05  29.899  < 2e-16 ***
##capital.loss                     6.432e-04  3.870e-05  16.622  < 2e-16 ***
##hours.per.week                   2.840e-02  1.912e-03  14.854  < 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: 27607  on 23999  degrees of freedom
##Residual deviance: 15626  on 23945  degrees of freedom
##AIC: 15736

##Number of Fisher Scoring iterations: 13

Interpreting the results of the logistic regression model:

“Age”, “Hours per week”, “sex”, “capital gain” and “capital loss” are the most statistically significant variables. Their lowest p-values suggesting a strong association with the probability of wage>50K from the data.
“Workclass”, “education”, “marital status”, “occupation” and “relationship” are all across the table. so cannot be eliminated from the model.
“Race” category is not statistically significant and can be eliminated from the model.

Run the anova() function on the model to analyze the table of deviance.

anova(model, test="Chisq")

##Analysis of Deviance Table

##Model: binomial, link: logit

##Response: income

##Terms added sequentially (first to last)


##               Df Deviance Resid. Df Resid. Dev  Pr(>Chi)    
##NULL                           23999      27607              
##age             1   1390.0     23998      26217 < 2.2e-16 ***
##workclass       6    357.4     23992      25859 < 2.2e-16 ***
##education      15   3009.1     23977      22850 < 2.2e-16 ***
##education.num   0      0.0     23977      22850              
##marital.status  6   4121.0     23971      18729 < 2.2e-16 ***
##occupation     13    634.8     23958      18094 < 2.2e-16 ***
##relationship    5    167.8     23953      17927 < 2.2e-16 ***
##race            4     19.9     23949      17907 0.0005157 ***
##sex             1    136.3     23948      17770 < 2.2e-16 ***
##capital.gain    1   1625.5     23947      16145 < 2.2e-16 ***
##capital.loss    1    293.2     23946      15852 < 2.2e-16 ***
##hours.per.week  1    225.6     23945      15626 < 2.2e-16 ***
##---
##Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

The difference between the null deviance and the residual deviance indicates how the model is doing against the null model. The bigger difference, the better. From the above table we can see the drop in deviance when adding each variable one at a time. Adding age, workclass, education, marital status, occupation, relationship, race, sex, capital gain, capital loss and hours per week significantly reduces the residual deviance. education.num seem to have no effect.

Apply model to the test set

fitted.results <- predict(model,newdata=test,type='response')
fitted.results <- ifelse(fitted.results > 0.5,1,0)
misClasificError <- mean(fitted.results != test$income)
print(paste('Accuracy',1-misClasificError))

##[1] "Accuracy 0.844368711457319"

The 0.84 accuracy on the test set is a very encouraging result.

At last, plot the ROC curve and calculate the AUC (area under the curve). The closer AUC for a model comes to 1, the better predictive ability.

library(ROCR)
p <- predict(model, newdata=test, type="response")
pr <- prediction(p, test$income)
prf <- performance(pr, measure = "tpr", x.measure = "fpr")
plot(prf)
auc <- performance(pr, measure = "auc")
auc <- auc@y.values[[1]]
auc

##[1] 0.8868877

The area under the curve corresponds the AUC.

As a last step, as I have just learned, use the effects package to compute and plot all variables.

library(effects)
plot(allEffects(model))

The End

I have been very cautious on removing variables because I don’t want to compromise the data as I may end up removing valid information. As a result, I may have kept variables that I should have removed such as “education.num”.

Source code that created this post can be found here. I am happy to hear any feedback or questions.

Reference: r-bloggers

Predict Income Level from Census Data was originally published by Susan Li at Susan Li | Data Ninja on April 20, 2017.

Atlanta Crime Analysis Jan 2016 to Apr 2017

2017-04-14T00:00:00+00:00

Atlanta Police Department’s online historical crime database has data from 1/1/2009 and is updated weekly. For this analysis I will examine all crime data posted on the Atlanta Police Department Open Data Portal from January 1, 2016 to April 7, 2017.

library(dplyr)
library(data.table)
library(ggplot2)
at <- rbind(COBRA_YTD2017, COBRADATA2016)
str(at)

##Classes ‘tbl_df’, ‘tbl’ and 'data.frame':	35064 obs. of  23 variables:
## $ MI_PRINX         : chr  "6320920" "6320921" "6320922" "6320923" ...
## $ offense_id       : chr  "170040711" "170040741" "170040743" "170040794" ...
## $ rpt_date         : chr  "01/04/2017" "01/04/2017" "01/04/2017" "01/04/2017" ##...
## $ occur_date       : chr  "01/03/2017" "01/03/2017" "01/03/2017" "01/04/2017" ##...
## $ occur_time       : chr  "16:00:00" "22:45:00" "20:00:00" "07:50:00" ...
## $ poss_date        : chr  "01/04/2017" "01/04/2017" "01/04/2017" "01/04/2017" ##...
## $ poss_time        : chr  "06:00:00" "07:30:00" "00:01:00" "08:00:00" ...
## $ beat             : chr  "406" "114" "409" "207" ...
## $ apt_office_prefix: chr  NA NA NA NA ...
## $ apt_office_num   : chr  NA NA "I-60" "1049" ...
## $ location         : chr  "2879 MOCKINGBIRD LN SW" "3466 FAIRLANE DR NW" ##"2929 LANDRUM DR SW" "2025 PEACHTREE RD NE @DARLINGTON APARTMEN" ...
## $ MinOfucr         : chr  "0720" "0710" "0640" "0440" ...
## $ MinOfibr_code    : chr  "2424" "2404" "2305" "1399" ...
## $ dispo_code       : chr  NA NA NA "20" ...
## $ MaxOfnum_victims : chr  "1" "1" "2" "1" ...
## $ Shift            : chr  "Morn" "Morn" "Eve" "Day" ...
## $ Avg Day          : chr  "Tue" "Wed" "Tue" "Wed" ...
## $ loc_type         : chr  "20" "20" "26" "26" ...
## $ UC2 Literal      : chr  "AUTO THEFT" "AUTO THEFT" "LARCENY-FROM VEHICLE" ##"AGG ASSAULT" ...
## $ neighborhood     : chr  "Audobon Forest West" "Fairburn Heights" ##"Southwest" NA ...
## $ npu              : chr  "I" "H" "R" "E" ...
## $ x                : chr  "-84.482590000000002" "-84.500590000000003" ##"-84.483879999999999" "-84.391440000000003" ...
## $ y                : chr  "33.728960000000001" "33.766730000000003" ##"33.706229999999998" "33.809649999999998" ...

The data contains 35064 crimes and 23 variables, and there are some wrangling need to do, such as remove the columns I don’t need, omit ‘NA’s, convert the data to the right types.

at$MI_PRINX <- at$apt_office_prefix <- at$apt_office_num <- at$location <- at$dispo_code <- at$loc_type <- at$npu <- NULL
library(chron)
library(lubridate)
at$lon <- at$x
at$lat <- at$y
at$occur_date <- mdy(at$occur_date)
at$rpt_date <- mdy(at$rpt_date)
at$occur_time <- chron(times=at$occur_time)
at$lon <- as.numeric(at$lon)
at$lat <- as.numeric(at$lat)
at$x <- at$y <- NULL
library(xts)
by_Date <- na.omit(at) %>% group_by(occur_date) %>% summarise(Total = n())
tseries <- xts(by_Date$Total, order.by= by_Date$occur_date)
library(highcharter)
hchart(tseries, name = "Crimes") %>% 
  hc_add_theme(hc_theme_darkunica()) %>%
  hc_credits(enabled = TRUE, text = "Sources: Atlanta Police Department", style = list(fontSize = "12px")) %>%
  hc_title(text = "Time Series of Atlanta Crimes") %>%
  hc_legend(enabled = TRUE)

Crimes have decreased in the recentl months.

The number of crimes increased around April, July and September 2016.

at$dayofWeek <- weekdays(as.Date(at$occur_date))
at$hour <- sub(":.*", "", at$occur_time)
at$hour <- as.numeric(at$hour)
ggplot(aes(x = hour), data = at) + geom_histogram(bins = 24, color='white', fill='black') +
  ggtitle('Histogram of Crime Time') + theme_fivethirtyeight()

The crime time distribution appears bimodal with peaking around midnight and again at the noon, then again between 6pm and 8pm.

by_neighborhood <- at %>% filter(!is.na(neighborhood)) %>%  group_by(neighborhood) %>% summarise(total=n()) %>% arrange(desc(total))
hchart(by_neighborhood[1:20,], "column", hcaes(x = neighborhood, y = total, color = total)) %>%
  hc_colorAxis(stops = color_stops(n = 10, colors = c("#440154", "#21908C", "#FDE725"))) %>%
  hc_add_theme(hc_theme_darkunica()) %>%
  hc_title(text = "Top 20 Neighborhood with most Crimes") %>%
  hc_credits(enabled = TRUE, text = "Sources: Atlanta Police Department", style = list(fontSize = "12px")) %>%
  hc_legend(enabled = FALSE)

Downtown and midtown are the most common locations where crimes take place, followed by Old Fourth Ward and West End.

by_crimeType <- at %>% group_by(`UC2 Literal`) %>% summarise(total=n()) %>% arrange(desc(total))
hchart(by_crimeType, "column", hcaes(x = `UC2 Literal`, y = total, color = total)) %>%
  hc_colorAxis(stops = color_stops(n = 10, colors = c("#440154", "#21908C", "#FDE725"))) %>%
  hc_add_theme(hc_theme_darkunica()) %>%
  hc_title(text = "Crime Types") %>%
  hc_credits(enabled = TRUE, text = "Sources: Atlanta Police Department", style = list(fontSize = "12px")) %>%
  hc_legend(enabled = FALSE)

larceny theft are the top crimes in Atlanta followed by aggravated assault

What days and times are especially dangerous?

topCrimes <- subset(at, `UC2 Literal`=='LARCENY-FROM VEHICLE'|`UC2 Literal`=="LARCENY-NON VEHICLE"|`UC2 Literal`=="AUTO THEFT"|`UC2 Literal`=="BURGLARY-RESIDENCE")
topCrimes$dayofWeek <- ordered(topCrimes$dayofWeek, 
                                   levels = c('Monday', 'Tuesday', 'Wednesday', 'Thursday', 'Friday', 'Saturday', 'Sunday'))
topCrimes <- within(topCrimes,  `UC2 Literal`<- factor(`UC2 Literal`, levels = names(sort(table(`UC2 Literal`), decreasing = T))))
ggplot(data = topCrimes, aes(x = dayofWeek, fill = `UC2 Literal`)) + 
  geom_bar(width = 0.9, position = position_dodge()) + ggtitle("Top Crimes by Day of Week") + 
  labs(x = "Day of Week", y = "Number of crimes", fill = guide_legend(title = "Crime category")) + theme(axis.text.x = element_text(angle = 45, hjust = 1))

Among the high crime categories, larceny tend to increase on Fridays and Saturdays. while burglary residence generally occurred more often during the weekdays than the weekends. Auto theft were least reported on Thursdays and increase for the weekends.

topLocations <- subset(at, neighborhood =="Downtown"|neighborhood =="Midtown" | neighborhood=="Old Fourth Ward" | neighborhood=="West End" | neighborhood=="Vine City" | neighborhood=="North Buckhead")
topLocations <- within(topLocations,  neighborhood <- factor(neighborhood, levels = names(sort(table(neighborhood), decreasing = T))))
topLocations$dayofWeek <- ordered(topLocations$dayofWeek, 
                                   levels = c('Monday', 'Tuesday', 'Wednesday', 'Thursday', 'Friday', 'Saturday', 'Sunday'))
ggplot(data = topLocations, aes(x = dayofWeek, fill = neighborhood)) + 
  geom_bar(width = 0.9, position = position_dodge()) + ggtitle(" Top Crime Neighborhood by Day of Week") + 
  labs(x = "Day of Week", y = "Number of crimes", fill = guide_legend(title = "Neighborhood")) + theme(axis.text.x = element_text(angle = 45, hjust = 1))

The number of crimes in downtown increased in weekends and decreased on Tuesdays. Crime distribution is fairly even throughout the week for Midtown and Old Fourth Ward. North Buckhead reported least crimes on Sundays.

topCrimes_1 <- topCrimes %>% group_by(`UC2 Literal`, hour) %>% 
  summarise(total = n())
ggplot(aes(x = hour, y = total), data = topCrimes_1) +
  geom_point(colour="blue", size=1) +
  geom_smooth(method="loess") +
  xlab('Hour(24 hour clock)') +
  ylab('Number of Crimes') +
  ggtitle('Top Crimes Time of the Day') +
  facet_wrap(~`UC2 Literal`)

The top crimes exhibit different sinusoid time-interval patterns. Larceny from vehicle declined around 5am and peaked in the evening, Larceny-non vehicle peaked around 3pm, Auto-theft had a steady increase during the day and peaked in the evening, burglary-residence happened more often in the late morning than in the evening.

Plot a location map of Crimes in Atlanta using stats$_$denisty layer.

I want to plot the density of crime on a map of the area around downtown Atlanta. The first step is to get the map data, then create the map use the following:

library(maps)
library(ggmap)
topCrimes$`UC2 Literal` <- factor(topCrimes$`UC2 Literal`, levels = c('LARCENY-FROM VEHICLE', "LARCENY-NON VEHICLE", "AUTO THEFT","BURGLARY-RESIDENCE"))
atlanta <- get_map('atlanta', zoom = 14) 
atlantaMap <- ggmap(atlanta, extent = 'device', legend = 'topleft')
atlantaMap + stat_density2d(aes(x = lon, y = lat, 
  fill = ..level.. , alpha = ..level..),size = 2, bins = 4, 
  data = topCrimes, geom = 'polygon') + 
  scale_fill_gradient('Crime\nDensity') +
  scale_alpha(range = c(.4, .75), guide = FALSE) +
  guides(fill = guide_colorbar(barwidth = 1, barheight = 8))

The density areas can be interpreted as follows: All the shaded areas together contain 3/4 of the top crimes in the data. Each shade represents 1/4 of the top crimes in the data. The smaller the area of a particular shade, the higher the crime density.

The End

Remember that we are seeing crime data here, not arrest data, It would be more meaningful if the original dataset contains arrest information. I would be interested to see where the arrests are happening.

Source code that created this post can be found here. I am happy to hear any feedback and questions.

Atlanta Crime Analysis Jan 2016 to Apr 2017 was originally published by Susan Li at Susan Li | Data Ninja on April 14, 2017.

Exploring 2016 H-1B Visa Petitions

2017-04-12T00:00:00+00:00

The H-1B program allows employers to temporarily employ foreign workers in the U.S on a nonimmigrant basis in specialty occupations. This is the most common visa status applied by international students after they complete higher education in the U.S and work in a full-time position. For those graduates to apply for H-1B visa, their employers must offer a job and petition for H-1B visa with the US immigration department.

The Office of Foreign Labor Certification (OFLC) generates program data. However, I downloaded the dataset from Kaggle directly after it has been mostly cleaned. To make it as relevant as possible, I will be only looking at the data from 2016.

I decide to remove all missing values, approximate 3% of applications were omitted. The data contains 629311 applications and 11 variables for 2016.

visa <- read.csv('h1b_kaggle.csv', stringsAsFactors = F)
visa <- visa[ which(visa$YEAR==2016),]
visa <- visa[complete.cases(visa[,-1]),]
str(visa)

##'data.frame':	629311 obs. of  11 variables:
## $ X                 : int  1 2 3 4 5 6 7 8 10 11 ...
## $ CASE_STATUS       : chr  "CERTIFIED-WITHDRAWN" "CERTIFIED-WITHDRAWN" ##"CERTIFIED-WITHDRAWN" "CERTIFIED-WITHDRAWN" ...
## $ EMPLOYER_NAME     : chr  "UNIVERSITY OF MICHIGAN" "GOODMAN NETWORKS, INC." ##"PORTS AMERICA GROUP, INC." "GATES CORPORATION, A WHOLLY-OWNED SUBSIDIARY OF ##TOMKINS PLC" ...
## $ SOC_NAME          : chr  "BIOCHEMISTS AND BIOPHYSICISTS" "CHIEF EXECUTIVES" ##"CHIEF EXECUTIVES" "CHIEF EXECUTIVES" ...
## $ JOB_TITLE         : chr  "POSTDOCTORAL RESEARCH FELLOW" "CHIEF OPERATING ##OFFICER" "CHIEF PROCESS OFFICER" "REGIONAL PRESIDEN, AMERICAS" ...
## $ FULL_TIME_POSITION: chr  "N" "Y" "Y" "Y" ...
## $ PREVAILING_WAGE   : num  36067 242674 193066 220314 157518 ...
## $ YEAR              : int  2016 2016 2016 2016 2016 2016 2016 2016 2016 2016 ##...
## $ WORKSITE          : chr  "ANN ARBOR, MICHIGAN" "PLANO, TEXAS" "JERSEY CITY, ##NEW JERSEY" "DENVER, COLORADO" ...
## $ lon               : num  -83.7 -96.7 -74.1 -105 -90.2 ...
## $ lat               : num  42.3 33 40.7 39.7 38.6 ...

Throughout the analysis, I will attempt to answer the following questions:

What are the top occupations America needs the most?
Who are the top employers that submit the most applications?
Which employers pay the most for what job?
Which states and cities hire the most H-1B visa workers?

library(dplyr)
library(ggthemes)
library(ggplot2)
visa <- mutate_each(visa, funs(toupper))
visa$PREVAILING_WAGE <- as.numeric(visa$PREVAILING_WAGE)
visa$YEAR <- as.numeric(visa$YEAR)
visa$lon <- as.numeric(visa$lon)
visa$lat <- as.numeric(visa$lat)
occu_group <- group_by(visa, SOC_NAME)
visa_by_occu <- dplyr::summarize(occu_group, 
                                 count = n(),
                                 mean = mean(PREVAILING_WAGE))
visa_by_occu <- visa_by_occu[with(visa_by_occu, order(-count)), ]
visa_by_occu <- visa_by_occu[1:20, ]
visa_by_occu$count[2] <- 114102
visa_by_occu= visa_by_occu[-6,]

What are the top occupations?

ggplot(aes(x = reorder(SOC_NAME, count), y=count), data = visa_by_occu) +
  geom_bar(stat = 'identity') + coord_flip() +
  xlab('Occupantions') +
  ylab('Number of Applications') +
  theme(axis.text = element_text(size = 8), 
        plot.title = element_text(size = 12)) +
  ggtitle('Top H-1B Visa Occupations 2016')

Technology related professions such as software developer, computer system analyst, programmer are among the most in demand occupations, analyst, accountant, engineer are among the second most in demand occupations.

Who are the top employers that submit the most applications?

employer_group <- group_by(visa, EMPLOYER_NAME)
visa_by_employer <- dplyr::summarize(employer_group, 
                                     count = n(),
                                     mean = mean(PREVAILING_WAGE))
visa_by_employer <- visa_by_employer[with(visa_by_employer, order(-count)), ]
visa_by_employer <- visa_by_employer[1:20, ]
ggplot(aes(x = reorder(EMPLOYER_NAME, count), y=count), data = visa_by_employer) +
  geom_bar(stat = 'identity') + coord_flip() +
  xlab('Employers') +
  ylab('Number of Applications') +
  theme(axis.text = element_text(size = 7),
        plot.title = element_text(size = 10)) +
  ggtitle('Top Employers for H-1B Visa Application 2016')

Infosys Limited leads by a large margin and submitted over 25000 applications last year. As a matter of fact, eight of the top 20 employers are Indian multinational IT companies.

employer_job_group <- group_by(visa, JOB_TITLE, EMPLOYER_NAME)
visa_by_employer_job <- dplyr::summarize(employer_job_group, 
                                         count = n(),
                                         mean = mean(PREVAILING_WAGE))

visa_by_employer_job <- visa_by_employer_job[with(visa_by_employer_job, order(-count)), ]
visa_by_employer_job <- visa_by_employer_job[1:20, ]
ggplot(aes(x = reorder(JOB_TITLE, count), y=count, fill=EMPLOYER_NAME), data = visa_by_employer_job) +
  geom_bar(stat = 'identity', position = position_dodge()) + 
  coord_flip() +
  ylab('Number of Applications') +
  xlab('Job Title') +
  theme(axis.text = element_text(size = 8), 
        axis.text.x = element_text(angle = 90, hjust = 1, vjust = .4),
        legend.justification=c(1,0), legend.position=c(1,0), legend.title=element_text(size=8), 
        legend.text=element_text(size=7), 
        plot.title = element_text(size = 10)) +
  ggtitle('Top Job Titles for H-1B Visa Application 2016')

Technology leads and technology analysts are in huge demand at Infosys, developers and programmers are liked by Tata, Google is mainly interested in software engineers. Deloitte and Ernst & Young apply visa for consultants and advisors.

What occupations make the most Money?

When I look at prevailing wage distribution, I found something interesting.

summary(visa$PREVAILING_WAGE)

##Min.   1st Qu.    Median      Mean   3rd Qu.      Max. 
##  0     57510     68410     89020     85180  329100000

Minimum wage is 0 and maximum wage is 329100000. I suspected ‘0’s were missing values, and there are only five of them. But let’s have a look which company offered $329100000 and for what job.

visa[which.max(visa$PREVAILING_WAGE),]

##      X CASE_STATUS      EMPLOYER_NAME           SOC_NAME
##5275 5580 DENIED E AND D MEDIA INC. MARKETING MANAGERS
##    JOB_TITLE FULL_TIME_POSITION PREVAILING_WAGE YEAR
##5275 DIRECTOR, SOCIAL AND DIGITAL MEDIA Y 329139200 2016
##          WORKSITE       lon      lat
##5275 SANTA MONICA, CALIFORNIA -118.4912 34.01945

For a digital media director? I am impressed. The application was denied anyway.

ggplot(aes(x = PREVAILING_WAGE), data = visa) + 
  scale_x_continuous(limits = c(40000, 250000)) +
  geom_histogram(aes(y = ..density..),bins=50) + geom_density(color='blue') +
  xlab('Prevailing Wage(USD)') +
  ggtitle('Prevailing Wage Distribution 2016')

Majority of the prevailing wages were between 50K and 100K USD per annum.

ggplot(aes(x = reorder(SOC_NAME, mean), y=mean), data = visa_by_occu) +
  geom_bar(stat = 'identity') + coord_flip() +
  xlab('Occupantions') +
  ylab('Average Prevailing Wage(USD)') +
  theme(axis.text = element_text(size = 8), 
        plot.title = element_text(size = 10)) +
  ggtitle('Top Wage H-1B Visa Occupations 2016')

physicians and surgeons enjoy the highest average prevailing wages that almost reach $175K per annum last year, computer information systems managers and electrical engineers take the second spot make approximate $163K per annum last year.

Which Employers pay the most?

ggplot(aes(x = reorder(JOB_TITLE, mean), y=mean, fill=EMPLOYER_NAME), data = visa_by_employer_job) +
  geom_bar(stat = 'identity', position = position_dodge()) + 
  coord_flip() +
  ylab('Average Prevailing Wage(USD)') +
  xlab('Job Title') +
  theme(axis.text = element_text(size = 8), 
        axis.text.x = element_text(angle = 90, hjust = 1, vjust = .4),
        legend.justification=c(1,0), legend.position=c(1,0), legend.title=element_text(size=8), legend.text=element_text(size=7), 
        plot.title = element_text(size = 9)) +
  ggtitle('Top Job Titles and Average Wages for H-1B Visa Application 2016')

When comes to the job title and employer, consultants hired by Deloitte enjoy the highest average prevailing wage, software engineers hird by Google are paid far more than the same job title hired by the other companeis.

top_employer_df <- filter(visa, EMPLOYER_NAME %in% visa_by_employer[['EMPLOYER_NAME']])
ggplot(aes(x = EMPLOYER_NAME, y = PREVAILING_WAGE), data = top_employer_df) +
  geom_boxplot() +
  coord_flip(ylim=c(0,150000)) +
  xlab('Employers') +
  ylab('Prevailing Wage(USD)') + 
  ggtitle('Wage by Top 20 Employers')
by(top_employer_df$PREVAILING_WAGE, top_employer_df$EMPLOYER_NAME, summary)

##top_employer_df$EMPLOYER_NAME: ACCENTURE LLP
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  21300   64940   74010   76420   84720  214900 
##--------------------------------------------------------------- 
##top_employer_df$EMPLOYER_NAME: AMAZON CORPORATE LLC
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  39040   83140   91190   93590  101100  173100 
##--------------------------------------------------------------- 
##top_employer_df$EMPLOYER_NAME: CAPGEMINI AMERICA INC
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  21050   69490   78400   81110   90790  229400 
##--------------------------------------------------------------- 
##top_employer_df$EMPLOYER_NAME: COGNIZANT TECHNOLOGY SOLUTIONS U.S. CORPORATION
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  29560   59740   70550   72920   83390  163900 
##--------------------------------------------------------------- 
##top_employer_df$EMPLOYER_NAME: DELOITTE CONSULTING LLP
##     Min.   1st Qu.    Median      Mean   3rd Qu.      Max. 
##    32220     62750     74960     95000     87820 136800000 
##--------------------------------------------------------------- 
##top_employer_df$EMPLOYER_NAME: ERNST & YOUNG U.S. LLP
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  32530   58180   72650   74120   85110  200900 
##--------------------------------------------------------------- 
##top_employer_df$EMPLOYER_NAME: GOOGLE INC.
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  32550   98340  103100  105300  119400  221300 
##--------------------------------------------------------------- 
##top_employer_df$EMPLOYER_NAME: HCL AMERICA, INC.
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  17260   60570   74090   75030   87840  165600 
##--------------------------------------------------------------- 
##top_employer_df$EMPLOYER_NAME: IBM CORPORATION
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  33970   71580   78750   80920   88330  210400 
##--------------------------------------------------------------- 
##top_employer_df$EMPLOYER_NAME: IBM INDIA PRIVATE LIMITED
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  42240   63320   68870   69880   74630 3277000 
##--------------------------------------------------------------- 
##top_employer_df$EMPLOYER_NAME: IGATE TECHNOLOGIES INC.
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  40440   63690   68870   69720   74690  129300 
##--------------------------------------------------------------- 
##top_employer_df$EMPLOYER_NAME: INFOSYS LIMITED
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  21300   59740   69970   72060   82200  180300 
##--------------------------------------------------------------- 
##top_employer_df$EMPLOYER_NAME: L&T TECHNOLOGY SERVICES LIMITED
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  16600   47670   56760   56660   63170  138300 
##--------------------------------------------------------------- 
##top_employer_df$EMPLOYER_NAME: LARSEN & TOUBRO INFOTECH LIMITED
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  27460   53520   62050   64040   73420  171400 
##--------------------------------------------------------------- 
##top_employer_df$EMPLOYER_NAME: MICROSOFT CORPORATION
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  37750   85180  101100   99120  110600  173100 
##--------------------------------------------------------------- 
##top_employer_df$EMPLOYER_NAME: SYNTEL CONSULTING INC.
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  34170   58680   66870   68780   74840  143700 
##--------------------------------------------------------------- 
##top_employer_df$EMPLOYER_NAME: TATA CONSULTANCY SERVICES LIMITED
##     Min.   1st Qu.    Median      Mean   3rd Qu.      Max. 
##    15220     57930     63460     73700     67890 133200000 
##--------------------------------------------------------------- 
##top_employer_df$EMPLOYER_NAME: TECH MAHINDRA (AMERICAS),INC.
##     Min.   1st Qu.    Median      Mean   3rd Qu.      Max. 
##    21200     64040     71430    189100     77600 170500000 
##--------------------------------------------------------------- 
##top_employer_df$EMPLOYER_NAME: UST GLOBAL INC
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  27460   52190   56560   57500   60110  145400 
##--------------------------------------------------------------- 
##top_employer_df$EMPLOYER_NAME: WIPRO LIMITED
##   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  51980   63150   69870   72750   77770  183900

Microsoft and Google offer the highest wages to their H-1B Visa workers. Their median wage exceeded $100K per annum, while the median wage of UST Global and L&T Technology are less than $60K per annum.

Which states and cities apply the most H-1B visas?

library(stringr)
visa$CITY <- str_replace(visa$WORKSITE, '(.+),.+', '\\1')
visa$STATE <- str_replace(visa$WORKSITE, '.+,(.+)', '\\1')
state_group <- group_by(visa, STATE)
visa_by_state <- dplyr::summarize(state_group, 
                                  count = n(),
                                  mean = mean(PREVAILING_WAGE))
visa_by_state <- visa_by_state[with(visa_by_state, order(-count)), ]
visa_by_state <- visa_by_state[1:20, ]
ggplot(aes(x = reorder(STATE, count), y = count), data = visa_by_state) +
  geom_bar(stat = 'identity') + coord_flip() +
  xlab('State') +
  ylab('Number of Applications') +
  ggtitle('Top States Apply the Most H-1B Visas')

Expectedly, California hires the most workers on H-1B visas, followed by Texas, New York, New Jersey and Illinois.

city_group <- group_by(visa, CITY)
visa_by_city <- dplyr::summarize(city_group, 
                                 count = n(),
                                 mean = mean(PREVAILING_WAGE))
visa_by_city <- visa_by_city[with(visa_by_city, order(-count)), ]
visa_by_city <- visa_by_city[1:20, ]
ggplot(aes(x = reorder(CITY, count), y = count), data = visa_by_city) +
  geom_bar(stat = 'identity') + coord_flip() +
  xlab('City') +
  ylab('Number of Applications') +
  ggtitle('Top Cities Apply the Most H-1B Visas')

This time New York City takes the lead by a large margin in the number of H-1B Visa applications. Not only high tech companies in New York hire H-1B visa workers, but also New York’s fashion industry is heavily reliant on immigrants, from top designers to creative staffs to the sewing workers.

A Map of H-1B Visa Applications

states_map <- map_data("state")
ggplot(visa_state, aes(map_id = region)) + 
    geom_map(aes(fill = count), map = states_map) +
    scale_colour_brewer(palette='Greens') + 
    expand_limits(x = states_map$long, y = states_map$lat) +
  xlab('longitude') + ylab('latitude') + ggtitle('State H-1B Visa Applications')

The End

It has been a great experience exploring 2016 H-1B visa petition data. With Trump’s Cracking down on the H-1B Visa program that Silicon Valley loves, I can’t wait to learn the data for 2017.

Source code that created this post can be found here. I am happy to hear any feedback or questions.

Exploring 2016 H-1B Visa Petitions was originally published by Susan Li at Susan Li | Data Ninja on April 12, 2017.

It's Movie Time!

2017-04-08T00:00:00+00:00

We are movie-goers, we have heavily relied on how many gold stars a movie gets before we decide whether we watch it or not. I have to admit that we miss good movies sometimes because some critics reviews are controversial, another time we regret after watching a movie because it was not what we expected.

When I was browsing Kaggle dataset, I came across an IMDB movie dataset which contains 5043 movies and 28 variables. Looking at the variables, I think I might be able to find something interesting.

library(ggplot2)
library(dplyr)
library(Hmisc)
library(psych)

movie <- read.csv('movie.csv', stringsAsFactors = F)
str(movie)

##'data.frame':	5043 obs. of  28 variables:
## $ color                    : chr  "Color" "Color" "Color" "Color" ...
## $ director_name            : chr  "James Cameron" "Gore Verbinski" "Sam ##Mendes" "Christopher Nolan" ...
## $ num_critic_for_reviews   : int  723 302 602 813 NA 462 392 324 635 375 ...
## $ duration                 : int  178 169 148 164 NA 132 156 100 141 153 ...
## $ director_facebook_likes  : int  0 563 0 22000 131 475 0 15 0 282 ...
## $ actor_3_facebook_likes   : int  855 1000 161 23000 NA 530 4000 284 19000 ##10000 ...
## $ actor_2_name             : chr  "Joel David Moore" "Orlando Bloom" "Rory ##Kinnear" "Christian Bale" ...
## $ actor_1_facebook_likes   : int  1000 40000 11000 27000 131 640 24000 799 ##26000 25000 ...
## $ gross                    : int  760505847 309404152 200074175 448130642 NA ##73058679 336530303 200807262 458991599 301956980 ...
## $ genres                   : chr  "Action|Adventure|Fantasy|Sci-Fi" ##"Action|Adventure|Fantasy" "Action|Adventure|Thriller" "Action|Thriller" ...
## $ actor_1_name             : chr  "CCH Pounder" "Johnny Depp" "Christoph ##Waltz" "Tom Hardy" ...
## $ movie_title              : chr  "AvatarÂ " "Pirates of the Caribbean: At ##World's EndÂ " "SpectreÂ " "The Dark Knight RisesÂ " ...
## $ num_voted_users          : int  886204 471220 275868 1144337 8 212204 ##383056 294810 462669 321795 ...
## $ cast_total_facebook_likes: int  4834 48350 11700 106759 143 1873 46055 2036 ##92000 58753 ...
## $ actor_3_name             : chr  "Wes Studi" "Jack Davenport" "Stephanie ##Sigman" "Joseph Gordon-Levitt" ...
## $ facenumber_in_poster     : int  0 0 1 0 0 1 0 1 4 3 ...
## $ plot_keywords            : chr  "avatar|future|marine|native|paraplegic" ##"goddess|marriage ceremony|marriage proposal|pirate|singapore" ##"bomb|espionage|sequel|spy|terrorist" ##"deception|imprisonment|lawlessness|police officer|terrorist plot" ...
## $ movie_imdb_link          : chr  ##"http://www.imdb.com/title/tt0499549/?ref_=fn_tt_tt_1" ##"http://www.imdb.com/title/tt0449088/?ref_=fn_tt_tt_1" ##"http://www.imdb.com/title/tt2379713/?ref_=fn_tt_tt_1" ##"http://www.imdb.com/title/tt1345836/?ref_=fn_tt_tt_1" ...
## $ num_user_for_reviews     : int  3054 1238 994 2701 NA 738 1902 387 1117 973 ##...
## $ language                 : chr  "English" "English" "English" "English" ...
## $ country                  : chr  "USA" "USA" "UK" "USA" ...
## $ content_rating           : chr  "PG-13" "PG-13" "PG-13" "PG-13" ...
## $ budget                   : num  237000000 300000000 245000000 250000000 NA ##...
## $ title_year               : int  2009 2007 2015 2012 NA 2012 2007 2010 2015 ##2009 ...
## $ actor_2_facebook_likes   : int  936 5000 393 23000 12 632 11000 553 21000 ##11000 ...
## $ imdb_score               : num  7.9 7.1 6.8 8.5 7.1 6.6 6.2 7.8 7.5 7.5 ...
## $ aspect_ratio             : num  1.78 2.35 2.35 2.35 NA 2.35 2.35 1.85 2.35 ##2.35 ...
## $ movie_facebook_likes     : int  33000 0 85000 164000 0 24000 0 29000 118000 ##10000 ...

Always start from the distribution of the data.

ggplot(aes(x = num_critic_for_reviews), data = movie) + geom_histogram(bins = 20, color = 'white') + ggtitle('Histogram of Number of reviews')
summary(movie$num_critic_for_reviews)

##Min. 1st Qu.  Median    Mean 3rd Qu.    Max.    NA's 
##      1      50     110     140     195     813      50

The distribution of the number of reviews is right skewed. Among these 5043 movies, the minimum number of review was 1 and the maximum number of reviews was 813. Majority of the movies received less than 200 reviews.

ggplot(aes(x = imdb_score), data = movie) + geom_histogram(bins = 20, color = 'white') + ggtitle('Histogram of Scores')
summary(movie$imdb_score)

##Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   1.60    5.80    6.60    6.44    7.20    9.50

The score distribution is left skewed, with minimum score at 1.60 and maximum score at 9.50.

ggplot(aes(x = title_year), data = movie) + geom_histogram(color='white') +
  ggtitle('Histogram of Title Year')

Most of the movies in the dataset were produced after 2000.

boxplot(imdb_score ~ title_year, data=movie, col='indianred')
title("IMDB score vs Title year")

However, the movies with the highest scores were produced in the 1950s, and there have been significant amount of low score movies came out in the recent years.

Which countries produced the most movies and which countries have the highest scores?

country_group <- group_by(movie, country)
movie_by_country <- summarise(country_group,
                               mean_score = mean(imdb_score),
                               n = n()) 
ggplot(aes(x = country, y = n, fill = country), data = movie_by_country) + geom_bar(stat = 'identity') + theme(legend.position = "none", axis.text=element_text(size=6)) +
  coord_flip() + ggtitle('Countries vs Number of Movies')

The USA produced the most number of movies.

ggplot(aes(x = country, y = mean_score, fill = country), data = movie_by_country) + geom_bar(stat = 'identity') + theme(legend.position = "none", axis.text=element_text(size=7)) +
  coord_flip() + ggtitle('Countries vs IMDB Scores')

But that does not mean their movie are all good quality. Kyrgyzstan, Libya and United Arab Emirates might have the highest average scores.

Multiple Linear Regression - Variable Selection

Time to do some serious work, I intend to predict IMDB scores from the other variables using multiple linear regression model. Because regression can’t deal with missing values, I will eliminate all missing values by converting to mean or median.

movie$imdb_score <- as.numeric(impute(movie$imdb_score, mean))
movie$num_critic_for_reviews <- as.numeric(impute(movie$num_critic_for_reviews, mean))
movie$duration <- as.numeric(impute(movie$duration, mean))
movie$director_facebook_likes <- as.numeric(impute(movie$director_facebook_likes, mean))
movie$actor_3_facebook_likes <- as.numeric(impute(movie$actor_3_facebook_likes, mean))
movie$actor_1_facebook_likes <- as.numeric(impute(movie$actor_1_facebook_likes, mean))
movie$gross <- as.numeric(impute(movie$gross, mean))
movie$cast_total_facebook_likes <- as.numeric(impute(movie$cast_total_facebook_likes, mean))
movie$facenumber_in_poster <- as.numeric(impute(movie$facenumber_in_poster, mean))
movie$budget <- as.numeric(impute(movie$budget, mean))
movie$title_year <- as.numeric(impute(movie$title_year, median))
movie$actor_2_facebook_likes <- as.numeric(impute(movie$actor_2_facebook_likes, mean))
movie$aspect_ratio <- as.numeric(impute(movie$aspect_ratio, mean))

Now I have got rid of all ‘NA’s. And I picked the following variables as potential candidates for the IMDB score predicators.

num_critic_for_reviews
duration
director_facebook_likes
actor_1_facebook_likes
gross
cast_total_facebook_likes
facenumber_in_poster
budget
movie_facebook_likes

Select a subset of numeric variables for regression modelling.

movie_sub <- subset(movie, select = c(num_critic_for_reviews, duration, director_facebook_likes, actor_1_facebook_likes, gross, cast_total_facebook_likes, facenumber_in_poster, budget, movie_facebook_likes, imdb_score))
pairs.panels(movie_sub, col='red')

Construct the model

Split data into training and testing.

set.seed(2017)
train_size <- 0.8 
train_index <- sample.int(length(movie_sub$imdb_score), length(movie_sub$imdb_score) * train_size)
train_sample <- movie_sub[train_index,]
test_sample <- movie_sub[-train_index,]

Fit the model

I will be using a stepwise selection of variables by backwards elimination. So I start with all candidate varibles and elimiate one at a time.

fit <- lm(imdb_score ~ num_critic_for_reviews + duration +    director_facebook_likes + actor_1_facebook_likes + gross + cast_total_facebook_likes + facenumber_in_poster + budget + movie_facebook_likes, data=train_sample)
summary(fit)

##Call:
##lm(formula = imdb_score ~ num_critic_for_reviews + duration + 
##    director_facebook_likes + actor_1_facebook_likes + gross + 
##    cast_total_facebook_likes + facenumber_in_poster + budget + 
##    movie_facebook_likes, data = train_sample)
##Residuals:
##   Min     1Q Median     3Q    Max 
##-5.088 -0.584  0.085  0.702  3.297 
##Coefficients:
##                                  Estimate       Std. Error t value
##(Intercept)                5.3211056356832  0.0734493165627   72.45
##num_critic_for_reviews     0.0017938921605  0.0001973870370    9.09
##duration                   0.0080649597024  0.0006762454257   11.93
##director_facebook_likes    0.0000392330050  0.0000059815295    6.56
##actor_1_facebook_likes     0.0000138466224  0.0000037417675    3.70
##gross                      0.0000000003871  0.0000000002990    1.29
##cast_total_facebook_likes -0.0000123493197  0.0000031674657   -3.90
##facenumber_in_poster      -0.0339624416792  0.0083551735721   -4.06
##budget                    -0.0000000000478  0.0000000000759   -0.63
##movie_facebook_likes       0.0000046436977  0.0000012015153    3.86
##                                      Pr(>|t|)    
##(Intercept)               < 0.0000000000000002 ***
##num_critic_for_reviews    < 0.0000000000000002 ***
##duration                  < 0.0000000000000002 ***
##director_facebook_likes         0.000000000061 ***
##actor_1_facebook_likes                 0.00022 ***
##gross                                  0.19543    
##cast_total_facebook_likes       0.000098245288 ***
##facenumber_in_poster            0.000048983645 ***
##budget                                 0.52916    
##movie_facebook_likes                   0.00011 ***
##---
##Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
##Residual standard error: 1.04 on 4024 degrees of freedom
##Multiple R-squared:  0.143,	Adjusted R-squared:  0.141 
##F-statistic: 74.8 on 9 and 4024 DF,  p-value: <0.0000000000000002

I am going to eliminate the variables that has little value, - gross and budget, one at a time, and fit it again.

fit <- lm(imdb_score ~ num_critic_for_reviews + duration + budget +   director_facebook_likes + actor_1_facebook_likes + cast_total_facebook_likes + facenumber_in_poster + movie_facebook_likes, data=train_sample)
summary(fit)

fit <- lm(imdb_score ~ num_critic_for_reviews + duration +   director_facebook_likes + actor_1_facebook_likes + cast_total_facebook_likes + facenumber_in_poster + movie_facebook_likes, data=train_sample)
summary(fit)

This is the final summary:

##Call:
##lm(formula = imdb_score ~ num_critic_for_reviews + duration + 
##    director_facebook_likes + actor_1_facebook_likes + ##cast_total_facebook_likes + 
##    facenumber_in_poster + movie_facebook_likes, data = train_sample)

##Residuals:
##   Min     1Q Median     3Q    Max 
##-5.080 -0.584  0.079  0.702  3.308 

##Coefficients:
##                             Estimate  Std. Error t value             Pr(>|t|)    
##(Intercept)                5.32209746  0.07343556   72.47 < 0.0000000000000002 ##***
##num_critic_for_reviews     0.00184176  0.00019151    9.62 < 0.0000000000000002 ##***
##duration                   0.00811866  0.00067383   12.05 < 0.0000000000000002 ##***
##director_facebook_likes    0.00003957  0.00000598    6.62        0.00000000004 ##***
##actor_1_facebook_likes     0.00001304  0.00000369    3.54              0.00041 ##***
##cast_total_facebook_likes -0.00001156  0.00000310   -3.72              0.00020 ##***
##facenumber_in_poster      -0.03422551  0.00834960   -4.10        0.00004230054 ##***
##movie_facebook_likes       0.00000478  0.00000120    3.99        0.00006632357 ##***
##---
##Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

##Residual standard error: 1.04 on 4026 degrees of freedom
##Multiple R-squared:  0.143,	Adjusted R-squared:  0.141 
##F-statistic: 95.9 on 7 and 4026 DF,  p-value: <0.0000000000000002

From the fitted model, I find that the model is significant since the p-value is very small. The “cast_total_facebook_likes” and “facenumber_in_poster” has negative weight. This model has multiple R-squared score of 0.143, meaning that around 14.3% of the variability can be explained by this model.

Let me make a few plots of the model I arrived at.

If I consider IMDB scores of all movies in the dataset, it is a non-linear fit, it has a small degree of nonlinearity.

This charts shows how all of the examples of residuals compare against theoretical distances from the model. I can see I have a bit problems here because some of the observations are not neatly fit the line.

This chart shows the distribution of residuals around the linear model in relation to the IMDB scores of all movies in my data. The higher the score, the less movies, and most movies are in the low or median score range.

This chart identifies all extrme values, but I don’t see any extrme value has huge impact on my model.

At this point, I think this model is as good as I can get. Let’s evaluate it.

train_sample$pred_score <- predict(fit, newdata = subset(train_sample, select=c(imdb_score, num_critic_for_reviews, duration, director_facebook_likes, actor_1_facebook_likes, cast_total_facebook_likes, facenumber_in_poster, movie_facebook_likes)))
test_sample$pred_score <- predict(fit, newdata = subset(test_sample, select=c(imdb_score, num_critic_for_reviews, duration, director_facebook_likes, actor_1_facebook_likes, cast_total_facebook_likes, facenumber_in_poster, movie_facebook_likes)))

The theoretical model performance is defined here as R-Squared

##Call:
##lm(formula = imdb_score ~ num_critic_for_reviews + duration + 
##    director_facebook_likes + actor_1_facebook_likes + ##cast_total_facebook_likes + 
##    facenumber_in_poster + movie_facebook_likes, data = train_sample)

##Residuals:
##   Min     1Q Median     3Q    Max 
##-5.080 -0.584  0.079  0.702  3.308 

##Coefficients:
##                             Estimate  Std. Error t value             Pr(>|t|)    
##(Intercept)                5.32209746  0.07343556   72.47 < 0.0000000000000002 ##***
##num_critic_for_reviews     0.00184176  0.00019151    9.62 < 0.0000000000000002 ##***
##duration                   0.00811866  0.00067383   12.05 < 0.0000000000000002 ##***
##director_facebook_likes    0.00003957  0.00000598    6.62        0.00000000004 ##***
##actor_1_facebook_likes     0.00001304  0.00000369    3.54              0.00041 ##***
##cast_total_facebook_likes -0.00001156  0.00000310   -3.72              0.00020 ##***
##facenumber_in_poster      -0.03422551  0.00834960   -4.10        0.00004230054 ##***
##movie_facebook_likes       0.00000478  0.00000120    3.99        0.00006632357 ##***
##---
##Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

##Residual standard error: 1.04 on 4026 degrees of freedom
##Multiple R-squared:  0.143,	Adjusted R-squared:  0.141 
##F-statistic: 95.9 on 7 and 4026 DF,  p-value: <0.0000000000000002

Check how good the model is on the training set.

train_corr <- round(cor(train_sample$pred_score, train_sample$imdb_score), 2)
train_rmse <- round(sqrt(mean((train_sample$pred_score - train_sample$imdb_score)^2)))
train_mae <- round(mean(abs(train_sample$pred_score - train_sample$imdb_score)))
c(train_corr^2, train_rmse, train_mae)

##[1] 0.1444 1.0000 1.0000

The correlation between predicted score and actual score for the training set is 14.44%, which is very close to theoretical R-Squared for the model, this is good news. However, on average, on the set of the observations I have previously seen, I am going to make 1 score difference when estimating.

Check how good the model is on the test set.

test_corr <- round(cor(test_sample$pred_score, test_sample$imdb_score), 2)
test_rmse <- round(sqrt(mean((test_sample$pred_score - test_sample$imdb_score)^2)))
test_mae <- round(mean(abs(test_sample$pred_score - test_sample$imdb_score)))
c(test_corr^2, test_rmse, test_mae)

##[1] 0.1521 1.0000 1.0000

This result is not bad, the results of the test set are not far from the results of the training set.

Conclusion

The most important factor that affect movie score is the duration, the longer the movie, the higher the sore will be.
The number of critic reviews is important, the more reviews a movie receives, the higher the score will be.
The face number in poster has a negative effect to the movie score. The more faces in a movie poster, the lower the score will be.

The End

I hope movie will be the same after I learn how to analyze movie data. Apprécier le film!

Source code that created this post can be found here. I am happy to hear any feedback and questions.

It's Movie Time! was originally published by Susan Li at Susan Li | Data Ninja on April 08, 2017.

Text Analysis Trump's Latest Tweets

2017-04-03T00:00:00+00:00

Just finished a few hours text mining lesson, can’t wait to put my new skill into practice, starting from Trump’s tweets.

First, apply API keys from twitter.

library(twitteR)
consumer_key <- "Your_Consumer_Key"
consumer_secret <- "Your_Consumer_Secret"
access_token <- NULL
access_secret <- NULL
setup_twitter_oauth(consumer_key, consumer_secret, access_token, access_secret)

The maximize request is 3200 tweets, I got 815, which is not bad.

tweets <- userTimeline("realDonaldTrump", n = 3200)
(n.tweet <- length(tweets))

##[1] 815

Have a look the first three, then convert all these 815 tweets to a data frame.

tweets[1:3]
tweets.df <- twListToDF(tweets)

##[[1]]
##[1] "realDonaldTrump: Looking forward to hosting our heroes from the Wounded ##Warrior Project (@WWP) Soldier Ride to the @WhiteHouse on Th… ##https://t.co/QLC0qFD94x"

##[[2]]
##[1] "realDonaldTrump: Getting ready to meet President al-Sisi of Egypt. On ##behalf of the United States, I look forward to a long and wonderful ##relationship."

##[[3]]
##[1] "realDonaldTrump: .@FoxNews from multiple sources: \"There was electronic ##surveillance of Trump, and people close to Trump. This is unprecedented.\" ##@FBI"

Text cleaning process, which includes convert all letters to lower case, remove URL, remove anything other than English letter and space, remove stopwords and extra white space.

library(tm) 
library(stringr)
myCorpus <- Corpus(VectorSource(tweets.df$text)) 
myCorpus <- tm_map(myCorpus, content_transformer(str_to_lower))
removeURL <- function(x) gsub("http[^[:space:]]*", "", x) 
myCorpus <- tm_map(myCorpus, content_transformer(removeURL)) 
removeNumPunct <- function(x) gsub("[^[:alpha:][:space:]]*", "", x) 
myCorpus <- tm_map(myCorpus, content_transformer(removeNumPunct)) 
myStopwords <- myStopwords <- c(stopwords('english'), "amp", "trump") 
myCorpus <- tm_map(myCorpus, removeWords, myStopwords) 
myCorpus <- tm_map(myCorpus, stripWhitespace)

Look at these three tweets again.

myCorpus <- tm_map(myCorpus, stemDocument)
inspect(myCorpus[1:3])

##<<SimpleCorpus>>
##Metadata:  corpus specific: 1, document level (indexed): 0
##Content:  documents: 3

##[1] look forward host hero wound warrior project wwp soldier ride whitehous th                
##[2] get readi meet presid alsisi egypt behalf unit state look forward long ##wonder relationship
##[3] foxnew multipl sourc electron surveil peopl close unpreced fbi

Need to replace a few words, such as “peopl” to “people”, “whitehous” to “whitehouse”, “countri” to “country”.

replaceWord <- function(corpus, oldword, newword) { 
  tm_map(corpus, content_transformer(gsub), 
         pattern=oldword, replacement=newword) 
} 
myCorpus <- replaceWord(myCorpus, "peopl", "people") 
myCorpus <- replaceWord(myCorpus, "whitehous", "whitehouse") 
myCorpus <- replaceWord(myCorpus, "countri", "country")

Building term document matrix

This is a matrix of numbers (0 and 1) that keeps track of which documents in a corpus use which terms.

tdm <- TermDocumentMatrix(myCorpus, control = list(wordLengths = c(1, Inf))) 
tdm

##<<TermDocumentMatrix (terms: 2243, documents: 815)>>
##Non-/sparse entries: 8419/1819626
##Sparsity           : 100%
##Maximal term length: 29
##Weighting          : term frequency (tf)

As you can see, the term-document matrix is composed of 2243 terms and 815 documents(tweets). It is very sparse, with 100% of the entries being zero. Let’s have a look at the terms of ‘clinton’, ‘bad’ and ‘great’, and tweets numbered 21 to 30.

idx <- which(dimnames(tdm)$Terms %in% c("clinton", "bad", "great"))
as.matrix(tdm[idx, 21:30])

##      Docs
##Terms     21 22 23 24 25 26 27 28 29 30
##  clinton  0  0  0  0  0  0  0  0  0  0
##  great    0  1  0  0  0  0  0  0  1  1
##  bad      0  0  0  0  0  0  0  0  0  0

What are the top frequent terms?

(freq.terms <- findFreqTerms(tdm, lowfreq = 40))

##[1] "get"  "presid"  "state"   "people"  "clinton" "hillari" "just"    "big" 
##[9] "us"   "join"    "go"      "time"    "will"    "news"    "thank"   "now" 
##[17] "country" "great" "today"   "elect"   "job"  "watch"  "make"   "america"
##[25] "pm"      "vote"

A picture worth a thousand words.

term.freq <- rowSums(as.matrix(tdm)) 
term.freq <- subset(term.freq, term.freq >= 40) 
df <- data.frame(term = names(term.freq), freq = term.freq)
library(ggplot2)
ggplot(df, aes(x=term, y=freq)) + geom_bar(stat="identity") + xlab("Terms") + ylab("Count") + coord_flip() + theme(axis.text=element_text(size=7))

Word Cloud

m <- as.matrix(tdm) 
word.freq <- sort(rowSums(m), decreasing = T) 
library(RColorBrewer)
pal <- brewer.pal(9, "BuGn")[-(1:4)]
library(wordcloud)
wordcloud(words = names(word.freq), freq = word.freq, min.freq = 3, random.order = F, colors = pal)

Which word/words are associated with ‘will’?

findAssocs(tdm, "will", 0.2)

##$will
## bring  dream wealth   back togeth    god    pig 
##  0.28   0.27   0.27   0.22   0.22   0.20   0.20

Which word/words are associated with ‘great’? - This is obvious.

findAssocs(tdm, "great", 0.2)

##$great
##america    make  togeth 
##   0.35    0.32    0.25

Which word/ words are associated with ‘bad’?

findAssocs(tdm, "bad", 0.2)

##$bad
##    dude      stupid    judg   relationship     fool      ban 
##    0.34       0.34     0.25         0.24       0.24      0.23

Clustering Words

tdm2 <- removeSparseTerms(tdm, sparse=0.95)
m2 <- as.matrix(tdm2)
distMatrix <- dist(scale(m2))
fit <- hclust(distMatrix, method="ward.D")
plot(fit)
rect.hclust(fit, k=10)
(groups <- cutree(fit, k=10))

##get presid  state people clinton hillari  just  us  join     go 
##1       1     1    2       3       3       4    5     6       1 
##time  will  news   thank  now country   great   today   elect   watch 
## 1      7     4       8     1     2       9      10       1       1 
##make america    vote 
##  1     1       1

We can see the words in the tweets, words “will, great, thank, us, join, today” are not clustered into any group, “hillari, clinton” are clustered into one group, “now, president, elect, time, go, make, america, state, watch, get, vote” are clustered in one group, “people, country” are clustered into one group, and “just, nows” are clustered into one group.

Clustering Tweets with the k-means Algorithm

m3 <- t(m2)
set.seed(100)
k <- 8
kmeansResult <- kmeans(m3, k)
round(kmeansResult$centers, digits=3)

##  get presid state people clinton hillari just us    join  go  time  will
##1 0.000 0.042 0.021 0.729  0.000  0.021 0.167 0.021 0.000 0.083 0.042 0.021
##2 0.027 0.068 0.000 0.000  0.057  0.000 0.070 0.000 0.000 0.043 0.062 0.000
##3 0.100 0.036 0.027 0.091  0.009  0.009 0.045 0.000 0.009 0.073 0.082 1.209
##4 0.047 0.093 0.023 0.070  0.395  1.047 0.093 0.000 0.000 0.070 0.023 0.116
##5 0.146 0.042 0.115 0.125  0.010  0.000 0.052 0.021 0.000 0.115 0.073 0.146
##6 0.130 0.037 0.000 0.000  0.000  0.037 0.056 1.093 0.019 0.056 0.037 0.185
##7 0.023 0.000 0.000 0.000  0.000  0.000 0.047 0.163 1.000 0.000 0.047 0.070
##8 0.212 0.038 0.654 0.058  0.077   0.019 0.077 0.019 0.000 0.058 0.096 0.038
##   news thank   now country great today elect watch  make america  vote
##1 0.042 0.021 0.021   0.542 0.021 0.042 0.083 0.062 0.042   0.000 0.062
##2 0.073 0.119 0.068   0.000 0.000 0.060 0.068 0.054 0.027   0.019 0.000
##3 0.027 0.118 0.027   0.055 0.136 0.055 0.027 0.055 0.073   0.027 0.027
##4 0.000 0.000 0.047   0.000 0.000 0.023 0.047 0.000 0.000   0.000 0.023
##5 0.104 0.240 0.073   0.042 1.125 0.135 0.031 0.083 0.323   0.281 0.052
##6 0.019 0.185 0.074   0.185 0.074 0.019 0.000 0.000 0.074   0.037 0.019
##7 0.000 0.023 0.047   0.000 0.000 0.023 0.000 0.070 0.000   0.047 0.023
##8 0.019 0.135 0.038   0.038 0.000 0.115 0.115 0.058 0.019   0.019 0.635

Check the top three words in every cluster

for (i in 1:k) {
cat(paste("cluster ", i, ": ", sep=""))
s <- sort(kmeansResult$centers[i,], decreasing=T)
cat(names(s)[1:3], "\n")
}

##cluster 1: people country just 
##cluster 2: thank news just 
##cluster 3: will great thank 
##cluster 4: hillari clinton will 
##cluster 5: great make america 
##cluster 6: us will thank 
##cluster 7: join us will 
##cluster 8: state vote get

I have admit that I can’t easily distinguish cluster 2, cluster 3 and cluster 6 of Trump’s tweets are of diﬀerent topics.

Sentiment Analysis

The sentiment analysis algorithm used here is based on NRC Word Emotion Association Lexion, available from the tidytext package which developed by Julia Silge and David Robinson. The algorithm associates with eight basic emotions (anger, fear, anticipation, trust, surprise, sadness, joy, and disgust) and two sentiments (negative and positive).

Sometimes there are tweaks I need to do to get rid of the problem characters.

library(tidytext)
library(syuzhet)
tweets.df$text <- sapply(tweets.df$text,function(row) iconv(row, "latin1", "ASCII", sub=""))
Trump_sentiment <- get_nrc_sentiment(tweets.df$text)

Have a look the head of Trump’s tweets sentiment scores:

head(Trump_sentiment)

##anger anticipation disgust fear joy sadness surprise trust negative positive
##1   2         0       0    1    0       1        0     0        0        3
##2   0         2       0    0    1       0        1     3        0        4
##3   0         0       0    1    0       0        2     0        0        0
##4   0         1       0    0    1       1        1     1        0        3
##5   1         1       1    0    1       0        1     2        1        2
##6   0         0       0    0    0       0        0     1        1        2

Then combine Trump tweets dataframe and Trump sentiment dataframe together.

tweets.df <- cbind(tweets.df, Trump_sentiment)
sentiment_total <- data.frame(colSums(tweets.df[,c(17:26)]))
names(sentiment_total) <- "count"
sentiment_total <- cbind("sentiment" = rownames(sentiment_total), sentiment_total)

Let’s visualize it!

ggplot(aes(x = sentiment, y = count, fill = sentiment), data = sentiment_total) +
  geom_bar(stat = 'identity') + ggtitle('Sentiment Score for Trump Latest Tweets') + theme(legend.position = "none")

Trump’s tweets appear more positive than negative, more trust than anger. Has Trump’s tweets always been positive or only after he won the election?

library(dplyr)
library(lubridate)
library(reshape2)
tweets.df$timestamp <- with_tz(ymd_hms(tweets.df$created), "America/New_York")
Tweets_trend <- tweets.df %>% 
        group_by(timestamp = cut(timestamp, breaks="1 months")) %>%
        summarise(negative = mean(negative),
                  positive = mean(positive)) %>% melt
library(scales)
ggplot(aes(x = as.Date(timestamp), y = value, group = variable), data = Tweets_trend) +
  geom_line(size = 2.5, aes(color = variable)) + 
  geom_point(size = 1) +
  ylab("Average sentiment score") + 
  ggtitle("Trump Tweets Sentiment Over Time")

The positive sentiment scores are always higher than the negative sentiment scores. And the negative sentiment experienced a significant drop recently, the positive sentiment have increased to the highest point. However, the simple text mining process conducted in this post does not make this conclusion. A more sophisticated text analysis of Trump’s tweets by David Robinson found that Trump writes only the angrier half from Android, and another postive half from his staff using iPhone.

The end

I really enjoyed working on Trump Tweets analysis. Learning about text mining and social network analysis is very rewarding. Thanks to Julia Silge and Yanchang Zhao’s tutorials to make it possible.

Source code that created this post can be found here. I am happy to hear any feedback or questions.

Text Analysis Trump's Latest Tweets was originally published by Susan Li at Susan Li | Data Ninja on April 03, 2017.