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/
Animated to show concentration over time. Interestingly, at the peak in August 2015, the sightings are relatively concentrated:
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)