In this exercise, we’re going to explore what makes news stories go viral. The data we’ll use is from the New York Times facebook page. At the end of the session, we’ll ask you to present your results to the class very briefly (2-3 min) and casually (just the html output of this Rmd file will do). Bolded items below should be part of your presentation!

  1. Try downloading a small sample of data from the NYT facebook page.

% Note: the ‘eval=FALSE’ argument below prevents the R code from being run when you compile % the RMarkdown document, since it’s slow

library(Rfacebook)
# check the help for the function fbOauth (type into R console ?fbOAuth)
# for instructions on obtaining a temporary access token
# when you have a token, paste it in place of abc123" below
auth_token <- "abc123" 
nyt.fb <- getPage(page="nytimes", token=auth_token, n=100, since="2015/01/01")
  1. Now, read in a larger sample of data from your computer (this saves a lot of downloading time!). Explore some basic features of the data such as how many entries it contains, what variables are included, and what type (class) these variables are.
nyt.fb <- read.csv("./nyt-fb.csv", stringsAsFactors=FALSE)

str(nyt.fb)
## 'data.frame':    9960 obs. of  10 variables:
##  $ from_id       : num  5.28e+09 5.28e+09 5.28e+09 5.28e+09 5.28e+09 ...
##  $ from_name     : chr  "The New York Times" "The New York Times" "The New York Times" "The New York Times" ...
##  $ message       : chr  "\"What if our toxic pattern was how well we got along and how much we loved each other?\"" "If you're on the East Coast, here are The New York Times Food's delicious ways to hunker down before the storm rolls in." "“At the time when I came into this country, they didn’t give us money or anything like that. You came in. You put your money in"| __truncated__ "\"It's OK, we have a really great water, from Australia.\"" ...
##  $ created_time  : chr  "2016-01-22T00:25:00+0000" "2016-01-21T23:55:00+0000" "2016-01-21T23:25:00+0000" "2016-01-21T22:55:00+0000" ...
##  $ type          : chr  "link" "link" "photo" "link" ...
##  $ link          : chr  "http://nyti.ms/1P8WA8w" "http://cooking.nytimes.com/68861692-nyt-cooking/922671-cooking-for-the-storm?smid=fb-nytimes&smtyp=cur" "https://www.facebook.com/nytimes/photos/a.283559809998.33779.5281959998/10150729101899999/?type=3" "http://nyti.ms/1OIM2th" ...
##  $ id            : chr  "5281959998_10150730340399999" "5281959998_10150730161409999" "5281959998_10150729101899999" "5281959998_10150730302924999" ...
##  $ likes_count   : int  128 438 106 478 322 481 293 4774 190 228 ...
##  $ comments_count: int  8 32 36 46 161 22 28 312 28 35 ...
##  $ shares_count  : int  24 202 20 98 76 91 204 1280 50 49 ...
  1. (Optional but possibly helpful) Create separate variables for month and time (just hour) of each post and add them to your data frame. Note that the time is UTC, which is 5 hours ahead of Eastern Time. These are potentially useful factors in predicting whether a post goes viral (e.g. maybe there is less activity over the summer months or late in the day).
month <- substr(nyt.fb$created_time, 6, 7)
hour <- substr(nyt.fb$created_time, 12, 13)
nyt.fb <- data.frame(nyt.fb, month, hour)

# write.csv(data.frame(month, hour), file="month-hour.csv", row.names=F)
  1. Come up with criteria for determining whether a post is “viral”. For example, it might help to look at a histogram of likes, counts, or shares (or some combination of these variables). Create a logical variable viral based on this and add it to your data frame.
total.resp <- nyt.fb$likes_count + nyt.fb$shares_count + nyt.fb$comments_count
quantile(total.resp, .95) # top 5% total share/count/comment total
##     95% 
## 10928.4
viral <- total.resp > 10000
nyt.fb$viral <- viral

# write.csv(data.frame(viral), file="viral.csv", row.names=F)

Please complete at least 2 out of the following 3 tasks

  1. Fit a topic model to the message content of each post. Incorporate the results as a feature you add to your nyt.fb data frame. Note that you will need to preprocess the text first (removing punctuation, converting to lowercase, etc.). Can you interpret the topics based on their associated terms?
library(topicmodels)
library(tm)
## Loading required package: NLP
# nyt.fb$message <- gsub('\\"', "", x=nyt.fb$message)
corpus <- VCorpus(VectorSource(nyt.fb$message))
corpus <- tm_map(corpus, removePunctuation)
corpus <- tm_map(corpus, content_transformer(tolower))
corpus <- tm_map(corpus, function(x) removeWords(x, stopwords("english")))
dtm <- DocumentTermMatrix(corpus, control=list(bounds=list(global=c(5, Inf))))

# remove messages with no topic terms
row.sum <- apply(dtm , 1, sum)
dtm.new   <- dtm[row.sum > 0, ]

# fit topic model, k=20 topics
lda <- LDA(dtm.new, k=20, method="Gibbs", 
           control=list(verbose=1000, seed=0, burnin=100, iter=5000))
## K = 20; V = 4974; M = 9960
## Sampling 5100 iterations!
## Iteration 1000 ...
## Iteration 2000 ...
## Iteration 3000 ...
## Iteration 4000 ...
## Iteration 5000 ...
## Gibbs sampling completed!
terms <- get_terms(lda, 10)
terms # look pretty interpretable
##       Topic 1     Topic 2     Topic 3  Topic 4    Topic 5      Topic 6    
##  [1,] "president" "new"       "world"  "now"      "news"       "said"     
##  [2,] "obama"     "york"      "first"  "school"   "breaking"   "just"     
##  [3,] "barack"    "times"     "time"   "children" "said"       "get"      
##  [4,] "house"     "opinion"   "city"   "work"     "two"        "good"     
##  [5,] "white"     "read"      "game"   "money"    "officials"  "going"    
##  [6,] "americans" "section"   "series" "come"     "federal"    "something"
##  [7,] "john"      "writes"    "major"  "even"     "found"      "people"   
##  [8,] "deal"      "board"     "sports" "parents"  "government" "really"   
##  [9,] "american"  "editorial" "team"   "less"     "case"       "like"     
## [10,] "will"      "nicholas"  "since"  "told"     "including"  "things"   
##       Topic 7  Topic 8    Topic 9  Topic 10       Topic 11 Topic 12 
##  [1,] "day"    "change"   "say"    "donald"       "like"   "state"  
##  [2,] "back"   "health"   "women"  "trump"        "know"   "paris"  
##  [3,] "life"   "court"    "men"    "hillary"      "want"   "attacks"
##  [4,] "way"    "said"     "part"   "clinton"      "dont"   "isis"   
##  [5,] "time"   "right"    "made"   "republican"   "need"   "across" 
##  [6,] "home"   "francis"  "young"  "campaign"     "love"   "war"    
##  [7,] "every"  "pope"     "theres" "debate"       "well"   "islamic"
##  [8,] "quote"  "care"     "often"  "bernie"       "youre"  "trying" 
##  [9,] "long"   "marriage" "woman"  "politics"     "didnt"  "friday" 
## [10,] "making" "law"      "said"   "presidential" "story"  "europe" 
##       Topic 13   Topic 14   Topic 15 Topic 16   Topic 17  Topic 18
##  [1,] "look"     "american" "years"  "people"   "new"     "year"  
##  [2,] "think"    "states"   "now"    "police"   "york"    "last"  
##  [3,] "week"     "united"   "best"   "man"      "times"   "show"  
##  [4,] "ahead"    "million"  "watch"  "black"    "via"     "photo" 
##  [5,] "today"    "nearly"   "still"  "death"    "food"    "live"  
##  [6,] "take"     "since"    "ago"    "killed"   "photo"   "photos"
##  [7,] "national" "china"    "big"    "least"    "styles"  "david" 
##  [8,] "season"   "plan"     "next"   "video"    "summer"  "follow"
##  [9,] "spoilers" "nations"  "star"   "officers" "dining"  "see"   
## [10,] "might"    "used"     "far"    "south"    "fashion" "sunday"
##       Topic 19  Topic 20 
##  [1,] "one"     "will"   
##  [2,] "never"   "can"    
##  [3,] "around"  "many"   
##  [4,] "ever"    "may"    
##  [5,] "history" "make"   
##  [6,] "took"    "help"   
##  [7,] "much"    "use"    
##  [8,] "2015"    "without"
##  [9,] "another" "better" 
## [10,] "place"   "much"
topics <- get_topics(lda, 3)
topic1 <- as.character(topics[1, ])
topic2 <- as.character(topics[2, ])
topic3 <- as.character(topics[3, ])
nyt.fb$topic1 <- topic1
nyt.fb$topic2 <- topic2
nyt.fb$topic3 <- topic3

# write.csv(data.frame(topic1, topic2, topic3), file="topics.csv", row.names=F)
  1. Search message content for some key words of interest, such as “israel”, “yankees”, “trump”, etc. For each key word, create a new variable for whether the message content contains that word. Add these variables to the nyt.fb data frame. It will be helpful to use regular expressions to match the key words as flexibly as possible.
message <- removePunctuation(tolower(nyt.fb$message))
nyt.fb$israel <- grepl("israel", message)
nyt.fb$trump <- grepl("trump", message)
nyt.fb$hillary <- grepl("hillary", message)
nyt.fb$obama <- grepl("barack|obama", message)
nyt.fb$terror <- grepl("terror|isis|isil|qaeda", message)
nyt.fb$kill <- grepl("kill|murder|shot", message)
nyt.fb$debate <- grepl("debat", message)

# write.csv(nyt.fb[, c("israel", "trump", "hillary", "obama", "terror", "kill", "debate")], file="keywords.csv", row.names=F)
  1. Using the file lexicon.csv we saw in the “text” module, extract a sentiment score for the content of each message. Add this score to the nyt.fb data frame.
lexicon <- read.csv("lexicon.csv", stringsAsFactors=F)
pos.words <- lexicon$word[lexicon$polarity=="positive"]
neg.words <- lexicon$word[lexicon$polarity=="negative"]

get_sentiment <- function(message, pos.words, neg.words){
    # count number of positive and negative word matches in message
    words.list <- strsplit(message, " +")
    pos.matches <- sapply(words.list, function(w) sum(w %in% pos.words))
    neg.matches <- sapply(words.list, function(w) sum(w %in% neg.words))
    return(pos.matches - neg.matches)
}

message <- removePunctuation(tolower(nyt.fb$message))
sent.score <- get_sentiment(message, pos.words, neg.words)
nyt.fb$sent.score <- sent.score

# write.csv(data.frame(sent.score), file="sent-score.csv", row.names=F)
  1. Build at least one statistical or machine learning model (e.g. regression, support vector machine) to classify whether posts are viral based on any features of the data (including those you’ve created in this exercise) EXCEPT the number of shares, counts, or likes. Note that it might be advantageous to first train a model to predict some combination of shares, counts, and/or likes (if you used that to define your viral variable), and then classify “viral” or not based on the predictions of that model.
# SVM example
library(e1071)
svm.viral <- svm(as.factor(viral) ~ month + hour + topic1 + topic2 + topic3 + 
                   israel + trump + hillary + obama + terror + kill + 
                   debate + sent.score, data=nyt.fb)
# use log of total response count
svm.resp <- svm(I(log(shares_count + likes_count + comments_count)) ~ month + 
                  hour + topic1 + topic2 + topic3 + israel + trump + 
                  hillary + obama + terror + kill + debate + sent.score, data=nyt.fb)

# regression example
glm.viral <- glm(as.factor(viral) ~ month + hour + topic1 + topic2 + topic3 + 
                   israel + trump + hillary + obama + terror + kill + 
                   debate + sent.score, data=nyt.fb, family=binomial(logit))
lm.resp <- lm(I(log(shares_count + likes_count + comments_count)) ~ month + 
                hour + topic1 + topic2 + topic3 + israel + trump + 
                hillary + obama + terror + kill + debate + sent.score, data=nyt.fb)

# random forest example
library(randomForest)
## randomForest 4.6-12
## Type rfNews() to see new features/changes/bug fixes.
rf.viral <- randomForest(as.factor(viral) ~ month + hour + topic1 + topic2 + topic3 + 
                   israel + trump + hillary + obama + terror + kill + 
                   debate + sent.score, data=nyt.fb)
rf.resp <- randomForest(I(log(shares_count + likes_count + comments_count)) ~ month + 
                          hour + topic1 + topic2 + topic3 + israel + trump + 
                          hillary + obama + terror + kill + debate + sent.score, data=nyt.fb)
  1. Using cross validation or out-of-sample testing (this is when you train the model on a subst of data, and test model predictions on the remaining data), evaluate the predictive performance of your model(s). Can you show your predictions beat a baseline?
set.seed(0)
train.sample <- sample(nrow(nyt.fb), floor(.75 * nrow(nyt.fb)))
train.data <- nyt.fb[train.sample, ]
test.data <- nyt.fb[-train.sample, ]

svm.resp <- svm(I(log(shares_count + likes_count + comments_count)) ~ month + 
                  hour + topic1 + topic2 + topic3 + israel + trump + 
                  hillary + obama + terror + kill + debate + sent.score, data=train.data)
lm.resp <- lm(I(log(shares_count + likes_count + comments_count)) ~ month + 
                hour + topic1 + topic2 + topic3 + israel + trump + 
                hillary + obama + terror + kill + debate + sent.score, data=train.data)
rf.resp <- randomForest(I(log(shares_count + likes_count + comments_count)) ~ month + 
                          hour + topic1 + topic2 + topic3 + israel + trump + 
                          hillary + obama + terror + kill + debate + sent.score, data=train.data)

# get predictions on test data
svm.resp.pred <- predict(svm.resp, test.data)
lm.resp.pred <- predict(lm.resp, test.data)
rf.resp.pred <- predict(rf.resp, test.data)

resp_to_viral <- function(resp, cutoff=10000, logged=TRUE) {
  if(logged)
    resp <- exp(resp)
  viral <- resp > cutoff
  return(viral)
}

# set cutoff so that % predicted viral in test data is the same as in training data
svm.viral.pred <- resp_to_viral(svm.resp.pred, cutoff=2250) 
mean(svm.viral.pred)
## [1] 0.05100402
lm.viral.pred <- resp_to_viral(lm.resp.pred, cutoff=2450) 
rf.viral.pred <- resp_to_viral(rf.resp.pred, cutoff=2480) 

# evaluate predictions
library(caret)
## Loading required package: lattice
## Loading required package: ggplot2
## 
## Attaching package: 'ggplot2'
## 
## The following object is masked from 'package:randomForest':
## 
##     margin
## 
## The following object is masked from 'package:NLP':
## 
##     annotate
confusionMatrix(test.data$viral, svm.viral.pred)
## Confusion Matrix and Statistics
## 
##           Reference
## Prediction FALSE TRUE
##      FALSE  2250  115
##      TRUE    113   12
##                                           
##                Accuracy : 0.9084          
##                  95% CI : (0.8964, 0.9195)
##     No Information Rate : 0.949           
##     P-Value [Acc > NIR] : 1.0000          
##                                           
##                   Kappa : 0.047           
##  Mcnemar's Test P-Value : 0.9472          
##                                           
##             Sensitivity : 0.95218         
##             Specificity : 0.09449         
##          Pos Pred Value : 0.95137         
##          Neg Pred Value : 0.09600         
##              Prevalence : 0.94900         
##          Detection Rate : 0.90361         
##    Detection Prevalence : 0.94980         
##       Balanced Accuracy : 0.52333         
##                                           
##        'Positive' Class : FALSE           
## 
confusionMatrix(test.data$viral, lm.viral.pred)
## Confusion Matrix and Statistics
## 
##           Reference
## Prediction FALSE TRUE
##      FALSE  2231  134
##      TRUE    102   23
##                                          
##                Accuracy : 0.9052         
##                  95% CI : (0.893, 0.9164)
##     No Information Rate : 0.9369         
##     P-Value [Acc > NIR] : 1.0000         
##                                          
##                   Kappa : 0.1136         
##  Mcnemar's Test P-Value : 0.0436         
##                                          
##             Sensitivity : 0.9563         
##             Specificity : 0.1465         
##          Pos Pred Value : 0.9433         
##          Neg Pred Value : 0.1840         
##              Prevalence : 0.9369         
##          Detection Rate : 0.8960         
##    Detection Prevalence : 0.9498         
##       Balanced Accuracy : 0.5514         
##                                          
##        'Positive' Class : FALSE          
## 
confusionMatrix(test.data$viral, rf.viral.pred)
## Confusion Matrix and Statistics
## 
##           Reference
## Prediction FALSE TRUE
##      FALSE  2245  120
##      TRUE    107   18
##                                           
##                Accuracy : 0.9088          
##                  95% CI : (0.8968, 0.9199)
##     No Information Rate : 0.9446          
##     P-Value [Acc > NIR] : 1.0000          
##                                           
##                   Kappa : 0.0889          
##  Mcnemar's Test P-Value : 0.4258          
##                                           
##             Sensitivity : 0.9545          
##             Specificity : 0.1304          
##          Pos Pred Value : 0.9493          
##          Neg Pred Value : 0.1440          
##              Prevalence : 0.9446          
##          Detection Rate : 0.9016          
##    Detection Prevalence : 0.9498          
##       Balanced Accuracy : 0.5425          
##                                           
##        'Positive' Class : FALSE           
##
  1. Find an example of a viral post that you correctly predict is viral, and a non-viral post you incorrectly predict as viral.
correct.pred <- sample(which(test.data$viral & svm.viral.pred), 1)
incorrect.pred <- sample(which(!test.data$viral & svm.viral.pred), 1)
test.data[correct.pred, ]
##         from_id          from_name
## 2857 5281959998 The New York Times
##                                                                                                                                                                                                                                                                                                                                                                       message
## 2857 "We are reminded in this time of tragedy that the bonds of liberté and égalité and fraternité are not only values that the French people care so deeply about, but they are values that we share. And those values are going to endure far beyond any act of terrorism or the hateful vision of those who perpetrated the crimes this evening." — President Barack Obama
##                  created_time  type
## 2857 2015-11-14T03:06:12+0000 video
##                                                            link
## 2857 https://www.facebook.com/nytimes/videos/10150694294884999/
##                                id likes_count comments_count shares_count
## 2857 5281959998_10150694294884999       20063            903         2172
##      month hour viral topic1 topic2 topic3 israel trump hillary obama
## 2857    11   03  TRUE      8      1     11  FALSE FALSE   FALSE  TRUE
##      terror  kill debate sent.score
## 2857   TRUE FALSE  FALSE          0
test.data[incorrect.pred, ]
##         from_id          from_name
## 6835 5281959998 The New York Times
##                                                                                                                                                                                                              message
## 6835 From instagram.com/nytimesfashion: Dominique Thaysen of Cape Town feeds a carrot to one of the tortoises at the Turtle Conservancy in Ojai, Southern California.\n\nPhoto: Jake Michaels for The New York Times
##                  created_time  type
## 6835 2015-07-13T23:25:01+0000 photo
##                                                                                                   link
## 6835 https://www.facebook.com/nytimes/photos/a.283559809998.33779.5281959998/10150624412599999/?type=3
##                                id likes_count comments_count shares_count
## 6835 5281959998_10150624412599999        2341             49          135
##      month hour viral topic1 topic2 topic3 israel trump hillary obama
## 6835    07   23 FALSE     17      2      4  FALSE FALSE   FALSE FALSE
##      terror  kill debate sent.score
## 6835  FALSE FALSE  FALSE          0