Election data example

cartogram-labels.csv

cartogram-polygons.csv

generate_dotplot.r

load_poll_data <- function() {
  require(plyr)

  polls_state_recent <- read.csv("polls_state_recent.csv")
  polls_state_avg     <- read.csv("polls_state_avg.csv")

  # Rename Region to State
  names(polls_state_recent)[names(polls_state_recent) == "Region"] <- "State"
  names(polls_state_avg)[names(polls_state_avg) == "Region"] <- "State"

  # Order factor levels of State by Obama_Romney ---------------------------------
  # First sort data frame by Obama_Romney, then assign the factor levels in
  # the resulting order
  polls_state_avg          <- arrange(polls_state_avg, Obama_Romney)
  polls_state_avg$State    <- factor(polls_state_avg$State,    levels=polls_state_avg$State)
  polls_state_recent$State <- factor(polls_state_recent$State, levels=polls_state_avg$State)

  # Add a column representing the leader
  polls_state_avg$Leader                                   <- "Tie"
  polls_state_avg$Leader[polls_state_avg$Obama_Romney > 0] <- "Obama"
  polls_state_avg$Leader[polls_state_avg$Obama_Romney < 0] <- "Romney"


  # Return them in a list
  list(state_recent = polls_state_recent, state_avg = polls_state_avg)
}


generate_dotplot <- function(mean=TRUE, point=TRUE, boxplot=FALSE) {
  require(ggplot2)

  polls <- load_poll_data()

  # The base plot
  election_dotplot <-
    ggplot(polls$state_recent, aes(x=State, y=Obama_Romney)) +
    # geom_point(size=2, alpha=0.2) +
    # geom_boxplot() +
    geom_hline(xintercept=0, size=20, colour="yellow", alpha=0.2) +
    # geom_point(data=polls_state_avg, aes(colour=Leader), size=3, shape=23) +
    scale_colour_manual(values=c("Tie"="white", "Obama"="blue", "Romney"="red"),
                        guide=FALSE) +
    scale_y_continuous("  Romney ------ |  ------ Obama", limits=c(-50, 50),
      breaks=seq(-50, 50, 10), labels=c(seq(50, 0, -10), seq(10, 50, 10))) +
    coord_flip() +
    theme_bw()


  if (boxplot) {
    election_dotplot <- election_dotplot + geom_boxplot()
  }
  if (point) {
    election_dotplot <- election_dotplot + geom_point(size=2, alpha=0.2)
  }
  if (mean) {
    election_dotplot <- election_dotplot +
      geom_point(data=polls$state_avg, aes(colour=Leader), size=3, shape=23)
  }

  election_dotplot <-
    election_dotplot + 
    annotate("text", label="Obama",  x=25, y=35,  colour="blue", size=10, alpha=0.3) +
    annotate("text", label="Romney", x=25, y=-35, colour="red",  size=10, alpha=0.3)

  election_dotplot
}

generate_maps.r

###############################################
## Working with maps

library(maps)
library(mapdata)
library(ggplot2)
library(plyr)
library(grid)

# ==============================================================================
# Load map data and polling data
# ==============================================================================

# Load state map data
states <- map_data("state")

## add missing states
missing.states <- data.frame(
  long   = c(-122, -122, -118, -118, -122, -113, -113, -109, -109, -113, -68, -68, -72, -72, -68, -68, -68, -72, -72, -68),
  lat    = c(27, 29, 29, 27, 27, 27, 29, 29, 27, 27, 33, 35, 35, 33, 33, 30, 32, 32, 30, 30),
  group  = rep(64:67, rep(5,4)), 
  order  = rep(1:5, 4), 
  region = c(rep("alaska", 5), rep("hawaii", 5), rep("rhode island", 5),
             rep("district of columbia", 5)),
  subregion = NA)

states <- rbind(states, missing.states)

# Load state polling data
state.polls <- read.csv("polls_state.csv")

# Rename column
names(state.polls)[names(state.polls) == "Region"] <- "State"

# ==============================================================================
# find most recent polls
# ==============================================================================
# library(lubridate)
# state.polls$Date <- as.Date(state.polls$Date)
# polls_state_recent <- ddply(state.polls, .(State), transform,
#   rank = length(Date) - rank(Date) + 1,
#   age = as.numeric(today() - Date))

# # subset on the ddply result to get polls from the last three weeks or most recent
# polls_state_recent <- subset(polls_state_recent, 
#                              (age <= 21) | ((age > 21) & (rank == 1)))

# # Take the average of polls for each state
# polls_state_recent <- ddply(polls_state_recent, "State", summarise,
#                             Obama_Romney = mean(Obama_Romney), na.rm = TRUE)

polls_state_recent <- read.csv("polls_state_recent.csv")

names(polls_state_recent)[names(polls_state_recent) == "Region"] <- "State"


# ==============================================================================
# Merge data with map data
# ==============================================================================
names(states)[names(states) == "region"] <- "State"

states.map <- merge(states, polls_state_recent, by="State")

## piece electoral map together
states.map <- arrange(states.map, group, order)

## add text to state 'boxes'
missing.states.text <- data.frame(
    long=c(-117.5, -108.5, -67.5, -67.5), 
    lat=c(28, 28, 34, 31),
    text=c("AK","HI","RI","DC"))

theme_bare <- theme(legend.position  = "bottom",
                    legend.key.width = unit(1, "inch"),
                    plot.background  = element_rect(fill="white"), 
                    panel.background = element_blank(), 
                    axis.line        = element_blank(), 
                    panel.grid       = element_blank(),
                    axis.ticks       = element_blank(),
                    axis.text        = element_blank(),
                    axis.title       = element_blank())


election_choropleth <-
ggplot(states.map, aes(long, lat, group=group, fill=Obama_Romney, order=order)) + 
  geom_polygon(colour = "black", size = 0.25) +
  geom_text(aes(long, lat, label=text), colour="grey50", hjust=0, size=4, 
            data = missing.states.text, inherit.aes=FALSE) +
  scale_fill_gradient2("Obama - Romney", low="blue", high="red") +
  coord_map() +
  theme_bare

# ==============================================================================
# Cartogram
# ==============================================================================

carto <- read.csv("cartogram-polygons.csv")
carto.polls <- merge(carto, polls_state_recent, by="State")
carto.labels <- read.csv("cartogram-labels.csv")

election_cartogram <-
ggplot(carto.polls, aes(Longitude, Latitude, group=State, fill=Obama_Romney)) + 
  geom_polygon(colour = "black", size = 0.25) +
  geom_text(data=carto.labels, aes(label=Abbrv, fill=1), size=4) +
  scale_fill_gradient2("Obama - Romney", low="blue", high="red") +
  coord_fixed() +
  ggtitle("Area proportional to number of electoral votes") +
  theme_bare

get_poll_data.r

get_poll_data <- function() {
  require(ggplot2)
  require(XML)
  require(lubridate)
  require(plyr)

  webpg ="http://www.nationalpolls.com/2012/obama-vs-romney.html"
  doc <- htmlParse(webpg)
  r <- xmlRoot(doc)
  body <- xmlChildren(r)[[2]]
  tables <- getNodeSet(doc, "//table")
  polls<-NULL

  x <- xmlValue(tables[[6]], "td")
  #dt <- as.Date(paste(strsplit(x, " ")[[1]][2], "2012"), "%b %d %Y")
  xp <- getNodeSet(tables[[6]], "tr")
  xps <- data.frame(do.call("rbind", sapply(xp[-1], function(x) (xpathSApply(x, "td", xmlValue)))))
  names(xps) <- c("Pollster", "Region", "Date.Range", "Obama", "Romney")
  xps$Date.Range <- as.character(xps$Date.Range)
  xps$Obama <- as.numeric(as.character(xps$Obama))
  xps$Romney <- as.numeric(as.character(xps$Romney))

  xps$Date <- as.Date(sapply(xps$Date.Range, FUN= function(i) strsplit(i, "-")[[1]][2]), "%m/%d/%y")
  xps$Region[which(xps$Region=="ConnecticutPPP")] <- "Connecticut"

  polls.sub <- xps[which(rowSums(is.na(xps))==0), -3]
  polls.sub$Obama_Romney<-polls.sub$Obama-polls.sub$Romney
  polls.sub$isNational <- polls.sub$Region=="National"

  # Drop polls where the state is "Battleground State"
  polls.sub <- subset(polls.sub, Region != "Battleground State" &
                                 Region != "Battleground-State")

  # Drop polls that have NA for Obama or Romney
  polls.sub <- subset(polls.sub, !is.na(Obama) & !is.na(Romney))


  #write.csv(polls.sub, file="NationalPolling-current-polls.csv", row.names=F)

  # Drop useless levels
  polls.sub$Region <- as.character(polls.sub$Region)

  # ==============================================================================
  # Categorize Pollster into MajorPollster
  polls.sub$Pollster <- as.character(polls.sub$Pollster)
  polls.sub$MajorPollster <- polls.sub$Pollster

  polls.sub$MajorPollster[grepl("Gallup", polls.sub$Pollster, ignore.case=TRUE)] <- "Gallup"
  polls.sub$MajorPollster[grepl("Rasmussen", polls.sub$Pollster, ignore.case=TRUE)] <- "Rasmussen" 
  polls.sub$MajorPollster[grepl("Ramussen", polls.sub$Pollster, ignore.case=TRUE)] <- "Rasmussen" 
  polls.sub$MajorPollster[grepl("ABC", polls.sub$Pollster, ignore.case=TRUE)] <- "ABC" 
  polls.sub$MajorPollster[grepl("NBC", polls.sub$Pollster, ignore.case=TRUE)] <- "NBC" 
  polls.sub$MajorPollster[grepl("CBS", polls.sub$Pollster, ignore.case=TRUE)] <- "CBS" 
  polls.sub$MajorPollster[grepl("CNN", polls.sub$Pollster, ignore.case=TRUE)] <- "CNN"
  polls.sub$MajorPollster[grepl("Pew", polls.sub$Pollster, ignore.case=TRUE)] <- "Pew" 
  polls.sub$MajorPollster[grepl("Public Policy", polls.sub$Pollster, ignore.case=TRUE)] <- "PPP" 
  polls.sub$MajorPollster[grepl("PPP", polls.sub$Pollster, ignore.case=TRUE)] <- "PPP"
  polls.sub$MajorPollster[grepl("Fox", polls.sub$Pollster, ignore.case=TRUE)] <- "Fox"
  polls.sub$MajorPollster[grepl("Quinnipiac", polls.sub$Pollster, ignore.case=TRUE)] <- "Quinnipiac"
  polls.sub$MajorPollster[grepl("Dixon", polls.sub$Pollster, ignore.case=TRUE)] <- "MasonDixon"
  polls.sub$MajorPollster[grepl("Democracy", polls.sub$Pollster, ignore.case=TRUE)] <- "DemocracyCorps"
  polls.sub$MajorPollster[grepl("Survey.*USA", polls.sub$Pollster, ignore.case=TRUE)] <- "SurveyUSA"
  polls.sub$MajorPollster[grepl("Reuters", polls.sub$Pollster, ignore.case=TRUE)] <- "AP.Reuters"
  polls.sub$MajorPollster[grepl("AP", polls.sub$Pollster, ignore.case=TRUE)] <- "AP.Reuters"
  polls.sub$MajorPollster[grepl("YouGov", polls.sub$Pollster, ignore.case=TRUE)] <- "YouGov"

  # Categorize all the pollsters with <10 samples as "Other"
  pollsters <- unique(polls.sub$MajorPollster)
  for (i in 1:length(pollsters)) {
    indx <- c(1:nrow(polls.sub))[polls.sub$MajorPollster == pollsters[i]]
    if (length(indx) < 10) 
      polls.sub$MajorPollster[indx] <- "Other"
  }
  polls.sub$MajorPollster <- factor(polls.sub$MajorPollster)
  polls.sub$IsMajor <- polls.sub$MajorPollster != "Other"

  # Find most recent polls
  polls_state <- subset(polls.sub, Region!="National", Pollster:Obama_Romney)
  polls_state <- subset(polls_state, Date > as.Date("2012-9-4", format="%Y-%d-%m"))
  polls_state$Pollster <- as.character(polls_state$Pollster)
  polls_state$Date <- as.character(polls_state$Date)
  polls_state$Region <- tolower(as.character(polls_state$Region))
  polls_state$Region<-gsub("-", " ", polls_state$Region)
  polls_state$Region<-gsub("hamsphire", "hampshire", polls_state$Region)

  states <- map_data("state")

  x <- unique(states$region)
  y <- unique(polls_state$Region)
  missing.polls <- x[! x %in% y]
  missing.values <- NULL
  if ("alabama" %in% missing.polls) 
    missing.values <- rbind(missing.values, c("guess", "alabama", 40, 55, "2012-04-09", -14))
  if ("arkansas" %in% missing.polls) 
    missing.values <- rbind(missing.values, c("guess", "arkansas", 40, 55, "2012-04-09", -12))
  if ("delaware" %in% missing.polls) 
    missing.values <- rbind(missing.values,c("guess", "delaware", 55, 40, "2012-04-09", 15))
  if ("district of columbia" %in% missing.polls)
    missing.values <- rbind(missing.values,c("guess", "district of columbia", 55, 40, "2012-04-09", 25))
  if ("idaho" %in% missing.polls)
    missing.values <- rbind(missing.values,c("guess", "idaho", 40, 55, "2012-04-09", -20))
  if ("kansas" %in% missing.polls)
    missing.values <- rbind(missing.values,c("guess", "kansas", 40, 55, "2012-04-09", -18))
  if ("louisiana" %in% missing.polls) 
    missing.values <- rbind(missing.values,c("guess", "louisiana", 40, 55, "2012-04-09", -17))
  if ("maryland" %in% missing.polls) 
    missing.values <- rbind(missing.values,c("guess", "maryland", 55, 40, "2012-04-09", 12))
  if ("mississippi" %in% missing.polls) 
    missing.values <- rbind(missing.values,c("guess", "mississippi", 40, 55, "2012-04-09", -13))
  if ("rhode island" %in% missing.polls) 
    missing.values <- rbind(missing.values,c("guess", "rhode island", 55, 40, "2012-04-09", 14))
  if ("south carolina" %in% missing.polls) 
    missing.values <- rbind(missing.values,c("guess", "south carolina", 40, 55, "2012-04-09", -18))
  if ("south dakota" %in% missing.polls) 
  missing.values <- rbind(missing.values,c("guess", "south dakota", 40, 55, "2012-04-09", -10))
  if ("west virginia" %in% missing.polls) 
    missing.values <- rbind(missing.values,c("guess", "west virginia", 40, 55, "2012-04-09", -12))
  if ("wyoming" %in% missing.polls) 
    missing.values <- rbind(missing.values,c("guess", "wyoming", 40, 55, "2012-04-09", -23))
  if ("alaska" %in% missing.polls) 
    missing.values <- rbind(missing.values,c("guess", "alaska", 40, 55, "2012-04-09", -19))
  if ("hawaii" %in% missing.polls) 
    missing.values <- rbind(missing.values,c("guess", "hawaii", 55, 40, "2012-04-09", 22))
  colnames(missing.values)<-c("Pollster", "Region", "Obama", "Romney", "Date", "Obama_Romney")
  missing.values <- as.data.frame(missing.values)
  missing.values$Pollster <- as.character(missing.values$Pollster)
  missing.values$Region <- as.character(missing.values$Region)
  missing.values$Obama <- as.numeric(as.character(missing.values$Obama))
  missing.values$Romney <- as.numeric(as.character(missing.values$Romney))
  missing.values$Date <- as.character(missing.values$Date)
  missing.values$Obama_Romney <- as.numeric(as.character(missing.values$Obama_Romney))
  polls_state <- rbind(polls_state, missing.values)
  polls_state$Date <- as.Date(polls_state$Date, format="%Y-%m-%d")


  write.csv(xps,         file = "polls_all.csv", row.names = FALSE)
  write.csv(polls_state, file = "polls_state.csv", row.names = FALSE)



  # Get the recent polls and averages of recent polls --------------------------

  indx <- unique(polls_state$Region)
  polls_state_recent <- NULL
  for (i in 1:length(indx)) {
    x <- subset(polls_state, Region == indx[i])
    if (length(x$Date[x$Date>=(today()-days(21))])>0) 
      polls_state_recent <- rbind(polls_state_recent, x[x$Date>=(today()-days(21)), ])
    else  # Keep the latest poll
      polls_state_recent <- rbind(polls_state_recent, x[order(x$Date, decreasing=T)[1], ])
  }

  # Averages for each state
  polls_state_avg <- ddply(polls_state_recent, "Region", summarise, 
                          Obama_Romney = mean(Obama_Romney, na.rm=TRUE),
                          n = length(Obama_Romney))

  # # Order the levels of Region by their Obama_Romney value
  # polls_state_avg <- arrange(polls_state_avg, desc(Obama_Romney))
  # # Turn Region into a factor, with levels in the same order
  # polls_state_avg$Region <- factor(polls_state_avg$Region, levels=polls_state_avg$Region)

  # # Turn polls_state_recent$Region into a factor, with the same order as
  # # polls_state_avg$Region
  # polls_state_recent$Region <- factor(polls_state_recent$Region, levels=levels(polls_state_avg$Region))
  # polls_state_recent$Obama_Romney <- -polls_state_recent$Obama_Romney

  write.csv(polls_state_avg,    file = "polls_state_avg.csv",    row.names = FALSE)
  write.csv(polls_state_recent, file = "polls_state_recent.csv", row.names = FALSE)

  invisible()
}

polls_all.csv

polls_state.csv

polls_state_avg.csv

polls_state_recent.csv

server.r

library(shiny)
library(datasets)
library(ggplot2)

# Only need to get the data every so often - not every single time
# source("get_poll_data.r")
source("generate_maps.r")
source("generate_dotplot.r")

# Define server logic
shinyServer(function(input, output) {

  output$States <- reactive(function() input$States)

  # Generate a plot of the requested variable against mpg and only 
  # include outliers if requested
  output$electoral_map <- reactivePlot(function() {
    if (input$map_type == "choropleth")
      print(election_choropleth)
    else if (input$map_type == "cartogram")
      print(election_cartogram)
  })

  output$states_dotplot<- reactivePlot(function() {
    print(
      generate_dotplot(
        mean    = input$dotplot_geom_mean,
        point   = input$dotplot_geom_point,
        boxplot = input$dotplot_geom_boxplot
    ))
  })


})

ui.r

library(shiny)

# Define UI for miles per gallon application
shinyUI(pageWithSidebar(

  # Application title
  headerPanel("Election Polling Data"),
  
  # Sidebar with controls to select the variable to plot against mpg
  # and to specify whether outliers should be included
  sidebarPanel(

    # Options for maps--------------------------------------------------------
    conditionalPanel(
      condition = "input.mainTab == 'map'",

      selectInput("map_type", "Map type:",
                  c("Choropleth" = "choropleth",
                    "Cartogram"  = "cartogram"))
    ),

    # Options for States dotplot ---------------------------------------------
    conditionalPanel(
      condition = "input.mainTab == 'states'",

      # Width of band

      # Geom: indivial polls, means, boxplot
      checkboxInput("dotplot_geom_mean",    strong("Means"), TRUE),
      checkboxInput("dotplot_geom_point",   strong("Individual polls"), TRUE),
      checkboxInput("dotplot_geom_boxplot", strong("Boxplot"), FALSE)

      # Sort by number of polls
      # Sort by Romney-Obama
    )
  ),

  
  # Show the caption and plot of the requested variable against mpg
  mainPanel(
    tabsetPanel(id = "mainTab",
      tabPanel("Map",    value="map",    plotOutput("electoral_map")),
      tabPanel("States", value="states", plotOutput("states_dotplot"))
    )
  )


))