Drone Sightings in the US

This is my entry for the new weekly data visualization challenge posted here:

https://rud.is/b/2016/03/30/introducing-a-weekly-r-python-js-etc-vis-challenge/

 

 

Main_plot_01

 

Animated to show concentration over time. Interestingly, at the peak in August 2015, the sightings are relatively concentrated:

DRONES

 

Where are you most likely to see drones in the US? According to the above maps, we see distinct hot zones in and around NYC, Southern Florida, Texas, and LA. The city of Lost Angels takes the cake, far outpacing even Silicon Valley, which surprised me quite a bit.

Why LA? I know drones are used for highway patrol around SoCal, so maybe that’s it. Or, perhaps, the paparazzi are stepping up their invasion-of-privacy game stalking celebs. Either way, if you’re a drone vendor, here are your target markets!

# Let's make some geo spatial heatmaps with drone data! (no nerds here or anything...)

# set your wd:
setwd("~/Dropbox (Personal)/Viz_Challenges")

library(ggplot2)
library(ggthemes)
library(readxl)
library(dplyr)
library(grid)
library(readr)
library(gplots)

# get copies of the data locally
URL1 <- "http://www.faa.gov/uas/media/UAS_Sightings_report_21Aug-31Jan.xlsx"
URL2 <- "http://www.faa.gov/uas/media/UASEventsNov2014-Aug2015.xls"

fil1 <- basename(URL1)
fil2 <- basename(URL2)

if (!file.exists(fil1)) download.file(URL1, fil1)
if (!file.exists(fil2)) download.file(URL2, fil2)

# read it in
xl1 <- read_excel(fil1)
xl2 <- read_excel(fil2)

# munge it a bit so we can play with it by various calendrical options

drones <- setNames(bind_rows(xl2[,1:3],
 xl1[,c(1,3,4)]),
 c("ts", "city", "state"))
drones <- mutate(drones,
 year=format(ts, "%Y"),
 year_mon=format(ts, "%Y%m"),
 ymd=as.Date(ts),
 yw=format(ts, "%Y%V"))

## to plot on a map, we'll need lat/lon coordinates of US cities
# read in geo lat/lon coordinates by city
# credit to the fine folks at MIT for open-sourcing that!

URL3<-"http://simplemaps.com/files/cities.csv"
fil3 <- basename(URL3)
if (!file.exists(fil3)) download.file(URL3, fil3)
Cities<-read_csv("cities.csv")

# list of states with their abbreviations:
URL4<-"http://www.fonz.net/blog/wp-content/uploads/2008/04/states.csv"
fil4 <- basename(URL4)
if (!file.exists(fil4)) download.file(URL4, fil4)
States<-read_csv("states.csv")

Cities2<-
 left_join(Cities,States,by=c("state"="Abbreviation")) %>%
 mutate("City-State"=paste0(city,"-",State)) %>%
 select(`City-State`,lat,lng,zip)

# looking at drone counts by city
By_City<-
drones %>%
 group_by(year,city,state) %>%
 dplyr::summarise(count=n()) %>%
 mutate("City-State"=paste0(city,"-",state)) %>%
 left_join(Cities2,by="City-State")

# the mapping isn't perfect... how many did we get?
table(is.na(By_City$lat)) # good enough!

## ================ PLOTTING =============== ##
library(ggplot2)
library(grid)
library(gridExtra)

# using ggplot2's map feature
states <- map_data("state")

#draw the base ggplot
ggplot(By_City %>% filter(!is.na(year))) + 

 # add the US map
 geom_polygon(data = states
 ,aes(x = long, y = lat, group = group),
 fill = "grey", color = "black") +

 # plot the drone sightings
 geom_point(aes(x=lng, y=lat, size=count),color="darkred")+

 # add density lines
 stat_density2d(aes(x = lng
 , y = lat)
 ,n=100
 ,size=0.5
 ,bins=10
 ,color="white") + 

 # add a second density layer, this time with color
 stat_density2d(aes(x = lng
 , y = lat
 ,fill=..level..
 ,alpha=..level..)
 ,n=100
 ,size=1
 ,bins = 10
 ,geom = "polygon") + 

 # various theme parameters
 scale_fill_gradient(low = "yellow", high = "red") +
 scale_alpha_continuous(range = c(0.1,0.8))+
 coord_map(xlim=c(-130,-60),ylim=c(23,50))+
 theme_map()+
 theme(legend.position="none"
 ,title=element_text(size=15,face="bold")
 ,panel.background=element_rect(fill="black")
 )+
 labs(title="Where are you most likely to see a drone in the U.S?"
 ,subtitle="Drone sightings in the US; 2014 - 2016"
 ,caption="Data from http://www.faa.gov/uas/law_enforcement/uas_sighting_reports/")

 

 

 

I’ve found that when looking at geospatial data over time, the GIF is a wonderful tool! Let’s make one…

 


## Draw a GIF!!!

# we'll slice the drone data by month for our GIF (don't want too many panes)
By_month<-
 drones %>%
 mutate(month=lubridate::month(ts,lab=T)) %>%
 group_by(year,month,year_mon,city,state) %>%
 dplyr::summarise(count=n()) %>%
 mutate("City-State"=paste0(city,"-",state)) %>%
 left_join(Cities2,by="City-State") %>%
 ungroup() %>%
 mutate(MonthLab=paste0(month,"-",year))

# some quick munging to make the plot order correct
monthOrder<-
By_month %>%
 group_by(year_mon,MonthLab) %>% summarise(count=sum(count)) %>%
 select(-count) %>%
 filter(!is.na(year_mon)) %>%
 ungroup() %>%
 select(-year_mon)
monthOrder<-as.character(monthOrder$MonthLab)

By_month<-By_month %>% mutate(MonthLab=factor(MonthLab,levels=monthOrder))

# Here's our draw.map function. This will create the main ggplots we
# want in our GIF. We'll make a title, the heatmap, a barplot showing
# what month we're looking at, and then a caption with source info

draw.map<-function(period){

 # 1) The main heatmap. Similar to above
 plot<-
 ggplot(By_month %>% filter(year_mon==period))+

 # add the US map
 geom_polygon(data = states
 ,aes(x = long, y = lat, group = group),
 fill = "grey", color = "black") +

 # plot the drone sightings
 geom_point(aes(x=lng, y=lat, size=count),color="darkred")+

 # add density lines
 stat_density2d(aes(x = lng
 , y = lat)
 ,n=100
 ,size=0.5
 ,bins=5
 ,color="white") + 

 # add a second density layer, this time with color
 stat_density2d(aes(x = lng
 , y = lat
 ,fill=..level..
 ,alpha=..level..)
 ,n=100
 ,size=1
 ,bins = 5
 ,geom = "polygon") + 

 # various theme parameters
 scale_fill_gradient(low = "yellow", high = "red") +
 scale_alpha_continuous(range = c(0.1,0.3))+
 coord_map(xlim=c(-130,-60),ylim=c(23,50))+
 theme_map()+
 theme(legend.position="none"
 ,title=element_text(size=15,face="bold")
 ,panel.background=element_rect(fill="black")
 )

 # 2) adding a nice bar plot below the heatmap so we can see relative volume by month
 bar_plot<-
 By_month %>%
 mutate(color=ifelse(year_mon==period,"current","other")) %>%
 ggplot(aes(x=MonthLab,y=count,group=color,fill=color))+
 geom_bar(stat="identity")+
 geom_vline(xintercept=period,color="red")+
 scale_fill_fivethirtyeight()+
 theme_bw()+
 theme(axis.text.x=element_text(angle=45,hjust=1,size=20)
 ,legend.position="none")+
 xlab(NULL)+ylab(NULL)

 # 3) title
 text<-
 textGrob("Drone Sightings in the US"
 ,gp = gpar(fontsize=30,fontface="bold")
 )

 # 4) caption
 captionText<-
 textGrob("Data from http://www.faa.gov/uas/law_enforcement/uas_sighting_reports/"
 ,gp = gpar(fontsize=20,fontface="italic")
 )

 # arrange everything and play with the height ratios
 grid.arrange(text,plot,bar_plot,captionText,ncol=1,heights=c(0.5,3,0.5,0.5))
}

# we'll need a sequence to run draw.map over
seq<-names(table(By_month$year_mon))

# finally, a second function which just runs the above function
trace.animate <- function() {
 lapply(seq, function(i) {
 draw.map(i)
 })
}

# execute and save the GIF!
library(animation)
saveGIF(trace.animate(), movie.name="DRONES.gif",ani.width = 1400, ani.height = 1400)

 

 

Advertisements

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s