Release

.gitignore

@@ -45,3 +45,6 @@ $RECYCLE.BIN/
 Network Trash Folder
 Temporary Items
 .apdisk
+
+#Shiny / R
+.Rproj.user/

Brexit_model.Rproj

@@ -0,0 +1,13 @@
+Version: 1.0
+
+RestoreWorkspace: Default
+SaveWorkspace: Default
+AlwaysSaveHistory: Default
+
+EnableCodeIndexing: Yes
+UseSpacesForTab: Yes
+NumSpacesForTab: 2
+Encoding: UTF-8
+
+RnwWeave: Sweave
+LaTeX: pdfLaTeX

global.R

@@ -0,0 +1,4 @@
+# libs --------------------------------------------------------------------
+library(pacman)
+p_load(lubridate, rvest, stringr, kirkegaard, ggplot2, scales, boot, plotly)
+

server.R

@@ -0,0 +1,110 @@
+#
+# This is the server logic of a Shiny web application. You can run the 
+# application by clicking 'Run App' above.
+#
+# Find out more about building applications with Shiny here:
+# 
+#    http://shiny.rstudio.com/
+#
+
+library(shiny)
+
+# scrape data -------------------------------------------------------------
+#get newest data on website
+d_brexit = read_html("https://ig.ft.com/sites/brexit-polling/") %>% html_node("table") %>% html_table()
+
+#rename
+colnames(d_brexit) = c("Stay", "Leave", "Undecided", "Date", "Pollster", "N")
+
+# transform ---------------------------------------------------------------
+#make gap
+d_brexit$Favor_Leave = d_brexit$Leave - d_brexit$Stay
+
+#interpret date
+d_brexit$Date = lubridate::mdy(d_brexit$Date, locale = "English_United States.1252")
+#this code may not run on your computer. If not, then find out how locales are treated there. You may not need to use a custom locale at all.
+
+#num date
+d_brexit$Date_num = as.numeric(d_brexit$Date)
+
+#fix N
+d_brexit$N[d_brexit$N == "-"] = NA #recode NA
+d_brexit$N = d_brexit["N"] %>% as_num_df() %>% unlist() #convert to num
+
+#impute N with medians
+d_brexit$N[is.na(d_brexit$N)] = median(d_brexit$N, na.rm=T)
+
+#other Ns
+d_brexit$sqrt_N = sqrt(d_brexit$N) #for sqrt weights
+d_brexit$ones = rep(1, nrow(d_brexit)) #for no weights
+
+# Define server logic required to draw a histogram
+shinyServer(function(input, output) {
+
+  output$polls = renderPlotly({
+
+    #replot
+    input$go
+
+    isolate({
+      #fetch weight data
+      d_brexit$weights_var = d_brexit[[input$weights]]
+
+      #loess
+      fit_loess = loess("Favor_Leave ~ Date_num", data = d_brexit, control=loess.control(surface="direct"), weights = weights_var, span = input$span)
+      v_predicted_outcome = predict(object = fit_loess, newdata = data.frame(Date_num = dmy("23 Jun 2016") %>% as.numeric()))
+      d_brexit$loess_predict = fitted(fit_loess) #get values
+
+      #plot
+      gg = ggplot(d_brexit, aes(x = Date, y = Favor_Leave, weight = weights_var)) + 
+        geom_point(aes(size = sqrt(N)), alpha = .3) + 
+        scale_size_continuous(guide = F) + 
+        geom_smooth(method = loess, fullrange = TRUE, method.args = list(control = loess.control(surface = "direct"), span = input$span)) +
+        ylab("Leave advantage (%)") + 
+        scale_x_date(limits = c(input$date_start, dmy("23 Jun 2016"))) +
+        geom_vline(xintercept = dmy("23 Jun 2016") %>% as.numeric(), linetype = "dotted", color = "red")
+
+      ggplotly(gg)
+    })
+
+
+  })
+
+  output$confidence = renderPlot({
+
+    #replot
+    input$go
+
+    isolate({
+      #fetch weight data
+      d_brexit$weights_var = d_brexit[[input$weights]]
+
+      #bootstrap
+      set.seed(1) #reproducible results
+      boot_replications = boot(data = d_brexit, statistic = function(data, i) {
+        #subset data
+        tmp = data[i, ]
+
+        #fit
+        fit_loess = loess("Favor_Leave ~ Date_num", data = tmp, control=loess.control(surface="direct"), weights = weights_var, span = input$span)
+
+        #get value
+        predict(object = fit_loess, newdata = data.frame(Date_num = dmy("23 Jun 2016") %>% as.numeric()))
+      }, R = 1000)
+
+      #extract values
+      v_values = boot_replications$t %>% as.vector()
+
+      #leave win %
+      v_leave_pct = percent_cutoff(v_values, cutoffs = 0)
+
+      #plot
+      GG_denhist(v_values) + 
+        xlab("Election day 'Leave' advantage (bootstrapped, 1000 runs)") +
+        annotate(geom = "text", x = 0, y = .5, label = "Probability that Leave will win = " + (v_leave_pct * 100) + "%", size = 5)
+    })
+
+
+  })
+
+})

ui.R

@@ -0,0 +1,62 @@
+#
+# This is the user-interface definition of a Shiny web application. You can
+# run the application by clicking 'Run App' above.
+#
+# Find out more about building applications with Shiny here:
+# 
+#    http://shiny.rstudio.com/
+#
+
+library(shiny)
+
+# Define UI for application that draws a histogram
+shinyUI(fluidPage(
+
+  # Application title
+  titlePanel("Brexit prediction model"),
+
+  # Sidebar with a slider input for number of bins 
+  sidebarLayout(
+    sidebarPanel(
+       selectInput("weights",
+                   label = "Weights to use",
+                   choices = list("None" = "ones",
+                                  "N-weighted" = "N",
+                                  "Sqrt(N)-weighted" = "sqrt_N"),
+                   selected = "N"),
+
+       sliderInput("span",
+                   label = "Smoothing factor",
+                   min = 0.05, max = 2,
+                   value = .75,
+                   step = .05),
+       dateInput("date_start",
+                      label = "Show polls from",
+                      min = "2010-09-09",
+                      max = "2016-06-23",
+                      value = "2010-09-09"),
+       actionButton("go", label = "Go!"),
+       helpText("The plots will only update when you click this magic button.")
+    ),
+
+    # Show a plot of the generated distribution
+    mainPanel(
+      HTML("<p>This is an interactive prediction model to forecast the result of <a href='https://en.wikipedia.org/wiki/United_Kingdom_European_Union_membership_referendum,_2016'>the British election about leaving the EU</a> ('Brexit') to be held on the 23rd of June, 2016.</p>"),
+      HTML("<p>The model uses a moving average-type function (<a href='https://en.wikipedia.org/wiki/Local_regression'>LOESS</a>) to predict future values from the polling data <a href='https://ig.ft.com/sites/brexit-polling/'>here</a>. You can control the settings of the model by using the menu to the left.</p>"),
+      tabsetPanel(
+        tabPanel(title = "polls",
+                 HTML("<p>This tab shows the polls and the fit. The red vertical line marks election day. Mouse-over the predicted value on election day to see the predicted outcome.</p>"),
+                 plotlyOutput("polls")
+                 ),
+        tabPanel(title = "prediction confidence",
+                 HTML("<p>How much confidence should we have in the prediction? This tab shows the distributed of predicted values based on <a href='https://en.wikipedia.org/wiki/Bootstrapping_%28statistics%29'>bootstrapping</a>. This may take a some seconds to calculate (depending on server load).</p>"),
+                 plotOutput("confidence"),
+                 HTML("<p>This calculation uses a <a href='https://en.wikipedia.org/wiki/Random_seed'>seed</a> to ensure reproducible results when using the same settings and data. Otherwise, results would vary slightly.</p>")
+                 )
+      ),
+      HTML("<p>Made by <a href='http://emilkirkegaard.dk/'>Emil O. W. Kirkegaard</a>. Source code on <a href=''>Github</a>.</p>")
+
+
+    )
+  )
+))