flu-crew / octoflushow

A Shiny app for swine IAV surveillance
MIT License
1 stars 1 forks source link

Feature Request: USA Map #3

Closed j23414 closed 5 years ago

j23414 commented 5 years ago

Is it possible to incorporate a USA heatmap for the segments and range? Something like the following figure and code?

H1

library(magrittr)
library(readxl)
library(zoo)
library(lubridate)
library(ggplot2)
library(reshape2)

# ===== State plots
# state stuff starts here...

# Make sure all states are there, rename states to regions for plotting maps
prepStateNames <- function(state_str){
  state_str = as.character(state_str) %>% {
    . = case_when(.=="AK"~"alaska", .=="AL"~"alabama", .=="AR"~"arkansas",
                  .=="AZ"~"arizona", .=="CA"~"california", .=="CO"~"colorado",
                  .=="CT"~"connecticut", .=="DC"~"district of columbia", .=="DE"~"delaware",  
                  .=="FL"~"florida", .=="GA"~"georgia", .=="HI"~"hawaii",  
                  .=="IA"~"iowa", .=="ID"~"idaho", .=="IL"~"illinois",  
                  .=="IN"~"indiana", .=="KS"~"kansas", .=="KY"~"kentucky",  
                  .=="LA"~"louisiana", .=="MA"~"massachusetts", .=="MD"~"maryland",  
                  .=="ME"~"maine", .=="MI"~"michigan", .=="MN"~"minnesota",  
                  .=="MO"~"missouri", .=="MS"~"mississippi", .=="MT"~"montana",  
                  .=="NC"~"north carolina", .=="ND"~"north dakota", .=="NE"~"nebraska",  
                  .=="NH"~"new hampshire", .=="NJ"~"new jersey", .=="NM"~"new mexico", 
                  .=="NV"~"nevada", .=="NY"~"new york", .=="OH"~"ohio",  
                  .=="OK"~"oklahoma", .=="OR"~"oregon", .=="PA"~"pennsylvania",  
                  .=="RI"~"rhode island", .=="SC"~"south carolina", .=="SD"~"south dakota", 
                  .=="TN"~"tennessee", .=="TX"~"texas", .=="UT"~"utah",  
                  .=="VA"~"virginia", .=="VT"~"vermont", .=="WA"~"washington",  
                  .=="WI"~"wisconsin", .=="WV"~"west virginia", .=="WY"~"wyoming")
  } %>% factor(.,
               levels=c("alaska","alabama","arkansas","arizona","california","colorado","connecticut",
                        "district of columbia","delaware","florida","georgia","hawaii","iowa","idaho",
                        "illinois","indiana","kansas","kentucky","louisiana","massachusetts","maryland",
                        "maine","michigan","minnesota","missouri","mississippi","montana","north carolina",
                        "north dakota","nebraska","new hampshire","new jersey","new mexico","nevada",
                        "new york","ohio","oklahoma","oregon","pennsylvania","rhode island","south carolina",
                        "south dakota","tennessee","texas","utah","virginia","vermont","washington","wisconsin",
                        "west virginia","wyoming"))
  return(state_str)
}

facetMaps <- function(df, col1){
  # get states long and lat values
  states <- map_data("state")

  # add info
  cdata <- df %>% subset(.,State!="NoState" ) %>%
    subset(.,!is.na(.[[col1]])) %>%
    mutate(region=State %>% prepStateNames ) %>%
    dcast(.,region~.[[col1]], fun.aggregate = length, value.var=col1,drop=FALSE) %>%
    melt(.,id="region") 

  data_geo <- cdata %>%
    merge(states,., by="region",all.x=T) %>%
    arrange(order)

  # Labels
  snames <- data.frame(region=tolower(state.name), long=state.center$x, lat=state.center$y)
  snames <- merge(snames, cdata, by="region")

  # do not label zeros
  snames$value[snames$value=="0"]=""

  #plot, viridae color palette?
  p <- ggplot() + 
    geom_polygon(data=data_geo,aes(x=long,y=lat,group=group,fill=log(value)),color="lightgrey") + 
    scale_fill_gradient2(low="white", mid = "#43a2ca",high="#0868ac", midpoint = 3, guide="colorbar")+
    geom_text(data=snames, aes(long, lat, label=value))+
    theme_void()+theme(legend.position = "none",text=element_text(size=28))+
    facet_wrap(~variable)+
    coord_fixed(1.3)
}

# == subtype map
(p<-my.data %>% {
  .$Subtype[grep(",",.$Subtype)]="Mixed"
  .$Subtype[grep("mixed",.$Subtype)]="Mixed"
  .
} %>%
    facetMaps(., "Subtype"))

# H1 map
p<-my.data %>% {
    .$H1 = gsub(",.*","",.$H1)
    .
} %>%
  facetMaps(., "H1")
p
arendsee commented 5 years ago

Done, thanks for the code, worked great!