Skip to content

Instantly share code, notes, and snippets.

@kellobri

kellobri/server.R

Last active August 29, 2015 14:07
Show Gist options
  • Save kellobri/1b8fbf9b6bd2cb829755 to your computer and use it in GitHub Desktop.
Save kellobri/1b8fbf9b6bd2cb829755 to your computer and use it in GitHub Desktop.
Download ZIP
ShinyCCmaps-v3-StateCompare
Raw
server.R
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)
)
})
}
)
Raw
ui.R
# 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