Last active
August 29, 2015 14:07
-
-
Save kellobri/1b8fbf9b6bd2cb829755 to your computer and use it in GitHub Desktop.
ShinyCCmaps-v3-StateCompare
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| library(maps) | |
| library(ggplot2) | |
| library(dplyr) | |
| set.seed(500) | |
| states = c("alabama","arizona","arkansas","california", | |
| "colorado","connecticut","delaware","district of columbia", | |
| "florida","georgia","idaho","illinois", | |
| "indiana","iowa","kansas","kentucky", | |
| "louisiana","maine","maryland","massachusetts", | |
| "michigan","minnesota","mississippi","missouri", | |
| "montana","nebraska","nevada","new hampshire", | |
| "new jersey","new mexico","new york","north carolina", | |
| "north dakota","ohio","oklahoma","oregon", | |
| "pennsylvania","rhode island","south carolina","south dakota", | |
| "tennessee","texas","utah","vermont", | |
| "virginia","washington","west virginia","wisconsin", | |
| "wyoming") | |
| dataset <- data.frame(region=states,val1=runif(49, 0,1),val2=runif(49, 0,1),val3=runif(49, 0,1)) | |
| shinyServer( | |
| function(input,output) { | |
| #Filter Data, Return Data Frame | |
| dataR <- reactive({ | |
| cState <- input$statePick | |
| cState <- as.numeric(cState) | |
| output$value <- renderPrint({ input$statePick }) | |
| btmV1 = dataset$val1[cState] - 0.1 | |
| topV1 = dataset$val1[cState] + 0.1 | |
| btmV2 = dataset$val2[cState] - 0.1 | |
| topV2 = dataset$val2[cState] + 0.1 | |
| btmV3 = dataset$val3[cState] - 0.1 | |
| topV3 = dataset$val3[cState] + 0.1 | |
| #Apply Sorting Filters | |
| c_a1data <- dataset %>% | |
| filter( | |
| val1 < btmV1, | |
| val3 >= topV3 | |
| ) | |
| c_a2data <- dataset %>% | |
| filter( | |
| val1 >= btmV1 & val1 < topV1, | |
| val3 >= topV3 | |
| ) | |
| c_a3data <- dataset %>% | |
| filter( | |
| val1 >= topV1, | |
| val3 >= topV3 | |
| ) | |
| c_b1data <- dataset %>% | |
| filter( | |
| val1 < btmV1, | |
| val3 >= btmV3 & val3 < topV3 | |
| ) | |
| c_b2data <- dataset %>% | |
| filter( | |
| val1 >= btmV1 & val1 < topV1, | |
| val3 >= btmV3 & val3 < topV3 | |
| ) | |
| c_b3data <- dataset %>% | |
| filter( | |
| val1 >= topV1, | |
| val3 >= btmV3 & val3 < topV3 | |
| ) | |
| c_c1data <- dataset %>% | |
| filter( | |
| val1 < btmV1, | |
| val3 < btmV3 | |
| ) | |
| c_c2data <- dataset %>% | |
| filter( | |
| val1 >= btmV1 & val1 < topV1, | |
| val3 < btmV3 | |
| ) | |
| c_c3data <- dataset %>% | |
| filter( | |
| val1 >= topV1, | |
| val3 < btmV3 | |
| ) | |
| classData <- dataset | |
| breaks <- c(-0.1,btmV2,topV2,1.1) | |
| grpCol <- cut(classData$val2,breaks=breaks,inc=TRUE,lab=FALSE) | |
| lev <- c("L","M","H","B") | |
| A1 = seq(1,49) | |
| for (ai in 1:length(classData$region)) { | |
| if (classData$region[ai] %in% c_a1data$region) { | |
| A1[ai] = TRUE | |
| } else A1[ai] = FALSE | |
| } | |
| tfA1 <- ifelse(A1,grpCol,4) | |
| lvA1 <- factor(lev[tfA1],levels=lev) | |
| classData$lvA1 <- lvA1 | |
| A2 = seq(1,49) | |
| for (aj in 1:length(classData$region)) { | |
| if (classData$region[aj] %in% c_a2data$region) { | |
| A2[aj] = TRUE | |
| } else A2[aj] = FALSE | |
| } | |
| tfA2 <- ifelse(A2,grpCol,4) | |
| lvA2 <- factor(lev[tfA2],levels=lev) | |
| classData$lvA2 <- lvA2 | |
| A3 = seq(1,49) | |
| for (ak in 1:length(classData$region)) { | |
| if (classData$region[ak] %in% c_a3data$region) { | |
| A3[ak] = TRUE | |
| } else A3[ak] = FALSE | |
| } | |
| tfA3 <- ifelse(A3,grpCol,4) | |
| lvA3 <- factor(lev[tfA3],levels=lev) | |
| classData$lvA3 <- lvA3 | |
| B1 = seq(1,49) | |
| for (bi in 1:length(classData$region)) { | |
| if (classData$region[bi] %in% c_b1data$region) { | |
| B1[bi] = TRUE | |
| } else B1[bi] = FALSE | |
| } | |
| tfB1 <- ifelse(B1,grpCol,4) | |
| lvB1 <- factor(lev[tfB1],levels=lev) | |
| classData$lvB1 <- lvB1 | |
| B2 = seq(1,49) | |
| for (bj in 1:length(classData$region)) { | |
| if (classData$region[bj] %in% c_b2data$region) { | |
| B2[bj] = TRUE | |
| } else B2[bj] = FALSE | |
| } | |
| tfB2 <- ifelse(B2,grpCol,4) | |
| lvB2 <- factor(lev[tfB2],levels=lev) | |
| classData$lvB2 <- lvB2 | |
| B3 = seq(1,49) | |
| for (bk in 1:length(classData$region)) { | |
| if (classData$region[bk] %in% c_b3data$region) { | |
| B3[bk] = TRUE | |
| } else B3[bk] = FALSE | |
| } | |
| tfB3 <- ifelse(B3,grpCol,4) | |
| lvB3 <- factor(lev[tfB3],levels=lev) | |
| classData$lvB3 <- lvB3 | |
| C1 = seq(1,49) | |
| for (ci in 1:length(classData$region)) { | |
| if (classData$region[ci] %in% c_c1data$region) { | |
| C1[ci] = TRUE | |
| } else C1[ci] = FALSE | |
| } | |
| tfC1 <- ifelse(C1,grpCol,4) | |
| lvC1 <- factor(lev[tfC1],levels=lev) | |
| classData$lvC1 <- lvC1 | |
| C2 = seq(1,49) | |
| for (cj in 1:length(classData$region)) { | |
| if (classData$region[cj] %in% c_c2data$region) { | |
| C2[cj] = TRUE | |
| } else C2[cj] = FALSE | |
| } | |
| tfC2 <- ifelse(C2,grpCol,4) | |
| lvC2 <- factor(lev[tfC2],levels=lev) | |
| classData$lvC2 <- lvC2 | |
| C3 = seq(1,49) | |
| for (ck in 1:length(classData$region)) { | |
| if (classData$region[bk] %in% c_c3data$region) { | |
| C3[ck] = TRUE | |
| } else C3[ck] = FALSE | |
| } | |
| tfC3 <- ifelse(C3,grpCol,4) | |
| lvC3 <- factor(lev[tfC3],levels=lev) | |
| classData$lvC3 <- lvC3 | |
| us_state_map <- map_data('state') | |
| mdata <- merge(us_state_map, classData, by='region', all=T) | |
| mdata <- mdata[order(mdata$order), ] | |
| mdata | |
| }) | |
| output$value <- renderPrint({ dataR() }) | |
| cols <- c("L" = "olivedrab","M" = "royalblue2","H" = "tomato2","B" = "wheat2") | |
| output$a1_Plot <- renderPlot({ | |
| (qplot(long, lat, data=dataR(), geom="polygon", group=group, fill=lvA1) | |
| + theme_bw() | |
| + theme(plot.background = element_blank(), | |
| panel.grid.major = element_blank(), | |
| panel.grid.minor = element_blank(), | |
| panel.border = element_blank(), | |
| axis.line = element_blank(), | |
| axis.ticks = element_blank(), | |
| axis.text.y = element_blank(), | |
| axis.text.x = element_blank(), | |
| axis.title.x=element_blank(), | |
| axis.title.y=element_blank(), | |
| legend.position = "none") | |
| + scale_fill_manual(values = cols) | |
| ) | |
| }) | |
| output$a2_Plot <- renderPlot({ | |
| (qplot(long, lat, data=dataR(), geom="polygon", group=group, fill=lvA2) | |
| + theme_bw() | |
| + theme(plot.background = element_blank(), | |
| panel.grid.major = element_blank(), | |
| panel.grid.minor = element_blank(), | |
| panel.border = element_blank(), | |
| axis.line = element_blank(), | |
| axis.ticks = element_blank(), | |
| axis.text.y = element_blank(), | |
| axis.text.x = element_blank(), | |
| axis.title.x=element_blank(), | |
| axis.title.y=element_blank(), | |
| legend.position = "none") | |
| + scale_fill_manual(values = cols) | |
| ) | |
| }) | |
| output$a3_Plot <- renderPlot({ | |
| (qplot(long, lat, data=dataR(), geom="polygon", group=group, fill=lvA3) | |
| + theme_bw() | |
| + theme(plot.background = element_blank(), | |
| panel.grid.major = element_blank(), | |
| panel.grid.minor = element_blank(), | |
| panel.border = element_blank(), | |
| axis.line = element_blank(), | |
| axis.ticks = element_blank(), | |
| axis.text.y = element_blank(), | |
| axis.text.x = element_blank(), | |
| axis.title.x=element_blank(), | |
| axis.title.y=element_blank(), | |
| legend.position = "none") | |
| + scale_fill_manual(values = cols) | |
| ) | |
| }) | |
| output$b1_Plot <- renderPlot({ | |
| (qplot(long, lat, data=dataR(), geom="polygon", group=group, fill=lvB1) | |
| + theme_bw() | |
| + theme(plot.background = element_blank(), | |
| panel.grid.major = element_blank(), | |
| panel.grid.minor = element_blank(), | |
| panel.border = element_blank(), | |
| axis.line = element_blank(), | |
| axis.ticks = element_blank(), | |
| axis.text.y = element_blank(), | |
| axis.text.x = element_blank(), | |
| axis.title.x=element_blank(), | |
| axis.title.y=element_blank(), | |
| legend.position = "none") | |
| + scale_fill_manual(values = cols) | |
| ) | |
| }) | |
| output$b2_Plot <- renderPlot({ | |
| (qplot(long, lat, data=dataR(), geom="polygon", group=group, fill=lvB2) | |
| + theme_bw() | |
| + theme(plot.background = element_blank(), | |
| panel.grid.major = element_blank(), | |
| panel.grid.minor = element_blank(), | |
| panel.border = element_blank(), | |
| axis.line = element_blank(), | |
| axis.ticks = element_blank(), | |
| axis.text.y = element_blank(), | |
| axis.text.x = element_blank(), | |
| axis.title.x=element_blank(), | |
| axis.title.y=element_blank(), | |
| legend.position = "none") | |
| + scale_fill_manual(values = cols) | |
| ) | |
| }) | |
| output$b3_Plot <- renderPlot({ | |
| (qplot(long, lat, data=dataR(), geom="polygon", group=group, fill=lvB3) | |
| + theme_bw() | |
| + theme(plot.background = element_blank(), | |
| panel.grid.major = element_blank(), | |
| panel.grid.minor = element_blank(), | |
| panel.border = element_blank(), | |
| axis.line = element_blank(), | |
| axis.ticks = element_blank(), | |
| axis.text.y = element_blank(), | |
| axis.text.x = element_blank(), | |
| axis.title.x=element_blank(), | |
| axis.title.y=element_blank(), | |
| legend.position = "none") | |
| + scale_fill_manual(values = cols) | |
| ) | |
| }) | |
| output$c1_Plot <- renderPlot({ | |
| (qplot(long, lat, data=dataR(), geom="polygon", group=group, fill=lvC1) | |
| + theme_bw() | |
| + theme(plot.background = element_blank(), | |
| panel.grid.major = element_blank(), | |
| panel.grid.minor = element_blank(), | |
| panel.border = element_blank(), | |
| axis.line = element_blank(), | |
| axis.ticks = element_blank(), | |
| axis.text.y = element_blank(), | |
| axis.text.x = element_blank(), | |
| axis.title.x=element_blank(), | |
| axis.title.y=element_blank(), | |
| legend.position = "none") | |
| + scale_fill_manual(values = cols) | |
| ) | |
| }) | |
| output$c2_Plot <- renderPlot({ | |
| (qplot(long, lat, data=dataR(), geom="polygon", group=group, fill=lvC2) | |
| + theme_bw() | |
| + theme(plot.background = element_blank(), | |
| panel.grid.major = element_blank(), | |
| panel.grid.minor = element_blank(), | |
| panel.border = element_blank(), | |
| axis.line = element_blank(), | |
| axis.ticks = element_blank(), | |
| axis.text.y = element_blank(), | |
| axis.text.x = element_blank(), | |
| axis.title.x=element_blank(), | |
| axis.title.y=element_blank(), | |
| legend.position = "none") | |
| + scale_fill_manual(values = cols) | |
| ) | |
| }) | |
| output$c3_Plot <- renderPlot({ | |
| (qplot(long, lat, data=dataR(), geom="polygon", group=group, fill=lvC3) | |
| + theme_bw() | |
| + theme(plot.background = element_blank(), | |
| panel.grid.major = element_blank(), | |
| panel.grid.minor = element_blank(), | |
| panel.border = element_blank(), | |
| axis.line = element_blank(), | |
| axis.ticks = element_blank(), | |
| axis.text.y = element_blank(), | |
| axis.text.x = element_blank(), | |
| axis.title.x=element_blank(), | |
| axis.title.y=element_blank(), | |
| legend.position = "none") | |
| + scale_fill_manual(values = cols) | |
| ) | |
| }) | |
| } | |
| ) |
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| # Example Data from http://www.dataincolour.com/2011/07/maps-with-ggplot2/ | |
| library(maps) | |
| library(ggplot2) | |
| states = c("alabama","arizona","arkansas","california", | |
| "colorado","connecticut","delaware","district of columbia", | |
| "florida","georgia","idaho","illinois", | |
| "indiana","iowa","kansas","kentucky", | |
| "louisiana","maine","maryland","massachusetts", | |
| "michigan","minnesota","mississippi","missouri", | |
| "montana","nebraska","nevada","new hampshire", | |
| "new jersey","new mexico","new york","north carolina", | |
| "north dakota","ohio","oklahoma","oregon", | |
| "pennsylvania","rhode island","south carolina","south dakota", | |
| "tennessee","texas","utah","vermont", | |
| "virginia","washington","west virginia","wisconsin", | |
| "wyoming") | |
| stChoice = list("alabama"=1,"arizona"=2,"arkansas"=3,"california"=4, | |
| "colorado"=5,"connecticut"=6,"delaware"=7,"district of columbia"=8, | |
| "florida"=9,"georgia"=10,"idaho"=11,"illinois"=12, | |
| "indiana"=13,"iowa"=14,"kansas"=15,"kentucky"=16, | |
| "louisiana"=17,"maine"=18,"maryland"=19,"massachusetts"=20, | |
| "michigan"=21,"minnesota"=22,"mississippi"=23,"missouri"=24, | |
| "montana"=25,"nebraska"=26,"nevada"=27,"new hampshire"=28, | |
| "new jersey"=29,"new mexico"=30,"new york"=31,"north carolina"=32, | |
| "north dakota"=33,"ohio"=34,"oklahoma"=35,"oregon"=36, | |
| "pennsylvania"=37,"rhode island"=38,"south carolina"=39,"south dakota"=40, | |
| "tennessee"=41,"texas"=42,"utah"=43,"vermont"=44, | |
| "virginia"=45,"washington"=46,"west virginia"=47,"wisconsin"=48, | |
| "wyoming"=49) | |
| set.seed(500) | |
| dataset <- data.frame(region=states,val1=runif(49, 0,1),val2=runif(49, 0,1),val3=runif(49, 0,1)) | |
| us_state_map <- map_data('state') | |
| map_data <- merge(us_state_map, dataset, by='region', all=T) | |
| map_data <- map_data[order(map_data$order), ] | |
| shinyUI(fluidPage( | |
| h2("CC Maps Project v.3 : 3x3 Grid Continental US, Select State Comparison"), | |
| #plotOutput("map"), | |
| hr(), | |
| fluidRow( | |
| column(6, selectInput("statePick", label = h3("Pick a State"), | |
| choices = stChoice, | |
| selected = 1)) | |
| ), | |
| wellPanel( | |
| fluidRow( | |
| column(4, | |
| plotOutput("a1_Plot", height = "200px") | |
| ), | |
| column(4, | |
| plotOutput("a2_Plot", height = "200px") | |
| ), | |
| column(4, | |
| plotOutput("a3_Plot", height = "200px") | |
| ) | |
| ), | |
| fluidRow( | |
| column(4, | |
| plotOutput("b1_Plot", height = "200px") | |
| ), | |
| column(4, | |
| plotOutput("b2_Plot", height = "200px") | |
| ), | |
| column(4, | |
| plotOutput("b3_Plot", height = "200px") | |
| ) | |
| ), | |
| fluidRow( | |
| column(4, | |
| plotOutput("c1_Plot", height = "200px") | |
| ), | |
| column(4, | |
| plotOutput("c2_Plot", height = "200px") | |
| ), | |
| column(4, | |
| plotOutput("c3_Plot", height = "200px") | |
| ) | |
| ) | |
| ) | |
| )) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment