PRED 413 - Discussion Week 9: Neural Networks for Forecasting

For this week’s class discussion, I’ll use an autoregressive neural network to forecast the percentage of stories published by POLITICO that mention the word “poll” anywhere in them. This data set was compiled as a response to a POLITICO story decrying how reporters are over-reliant on polling in their political coverage, which is a less-than-credible claim coming from a new outlet that mentions polls in up to 40% of their stories!

POLITICO’s search function appears to include all articles, so searching for a period returns their total publication volume and searching for “poll” returns all poll-mentioning articles. From that point, it’s a simple scraping job (warning: if you’re playing along at home, this part takes a while…). The resulting data set has columns for date, count of stories mentioning “poll,” and the total number of stories published that day. Finally, the data is grouped by week and converted to percentages then cast to a tm() object.

library(rvest)
library(dplyr)
# dates <- list()
# for(i in seq(1,2174)){
#   url = paste0("http://www.politico.com/search/",i,"?q=poll")
#   articles <- read_html(url)%>%
#     html_nodes('p time')%>%
#     html_attr('datetime')
#   dates[[i]] <- articles
# }
# 
# all_articles <- list()
# for(i in seq(1,15501)){
#   url = paste0("http://www.politico.com/search/",i,"?q=.")
#   articles <- read_html(url)%>%
#     html_nodes('p time')%>%
#     html_attr('datetime')
#   all_articles[[i]] <- articles
# }
# 
# library(lubridate)
# 
# condense_to_days <- function(l){
#   date_dfs <- list()
#   for(i in seq(1,length(l))){
#     date_dfs[[i]] <- data.frame(date = l[[i]])
#   }
# 
#   article_dates <- bind_rows(date_dfs)
#   
#   article_dates <- article_dates%>%
#     mutate(date_day = round_date(as.Date(substr(date, 1,10), format = '%Y-%m-%d'), unit = 'day'))%>%
#     group_by(date_day)%>%
#     summarise(n = n())
# 
#   return(article_dates)  
# } 
# 
# poll_dates <- condense_to_days(dates)
# all_dates <- condense_to_days(all_articles)
# 
# article_mentions <- full_join(
#   poll_dates%>%dplyr::select(date_day, poll = n),
#   all_dates%>%dplyr::select(date_day, all = n)
# )
# Since I did this already, I'll just read in the csv saved from when I ran this...
politico_raw <- readr::read_csv('C:/Users/joshy/Desktop/politico_data.csv')%>%
  filter(date_day > '2007-01-21')%>%
  group_by(week = floor_date(date_day, 'weeks'))%>%
  summarise(poll = sum(poll, na.rm = T), 
            all = sum(all, na.rm = T))%>%
  mutate(percentage = poll/all)

Missing column names filled in: 'X1' [1]Parsed with column specification:
cols(
  X1 = col_integer(),
  date_day = col_date(format = ""),
  poll = col_integer(),
  all = col_integer()
)

politico_ts <- ts(politico_raw, frequency = 52, start = c(2007, 1, 14))
politico_raw%>%head(100)

TheThe data has a clear seasonal pattern, but no real trend. From visual inspection, it looks like the spikes in polling-related stories happen in October-November of even numbered years and the beginnings of presidential years.

library(forecast)
library(ggplot2)
library(yaztheme)
autoplot(decompose(politico_ts[,'percentage']))

First, we’ll develop and test a neural net model. The forecast from this model looks like a naiive projection with incredibly wide confidence intervals. Perhaps an ARIMA or STL model will fit the data more effectively.

nn.fit <- nnetar(politico_ts[,'percentage'])
autoplot(forecast(nn.fit, h = 50, PI = TRUE))+
  theme_yaz()+
  labs(y = 'Percentage of Stories Mentioning "Poll"')

The auto ARIMA model performed similarly to the NNAR model. The STL method more appropriately fit the seasonality of the data, with a spike projected for November 2018 when the next major election is scheduled. None of the models reach the extremes of the past peaks in poll-related publications.

stl.fit <- stlf(politico_ts[,'percentage'])
arima.fit <- auto.arima(politico_ts[,'percentage'])
autoplot(politico_ts[,'percentage'])+
  autolayer(forecast(stl.fit, h = 60), series = 'STL', colour = yaz_cols[3], PI = F)+
  autolayer(forecast(arima.fit, h = 60), series = 'ARIMA', colour = yaz_cols[4], PI = F)+
  autolayer(forecast(nn.fit, h = 60), series = 'NNAR', colour = yaz_cols[6], PI = F)+
  theme_yaz()+
  labs(y = 'Percentage of Stories Mentioning "Poll"',
       title = 'Projected Incidence of Polling Related Stories',
       subtitle = 'Green = STL | Blue = ARIMA | Pink = NNAR')

The STL model performs the best of all, confirming the suggestion from the chart of projected values.

acc.measures <- bind_rows(
  data.frame(accuracy(stl.fit))%>%mutate(method = 'STL'),
  data.frame(accuracy(arima.fit))%>%mutate(method = 'ARIMA'),
  data.frame(accuracy(nn.fit))%>%mutate(method = 'NNAR')
)
acc.measures%>%
  reshape2::melt(id.vars= 'method')%>%
  ggplot(aes(x = method, y = value))+
  geom_col(fill = yaz_cols[1])+
  facet_wrap(~variable, scales = 'free', nrow = 2)+
  theme_yaz()