Skip to content

Instantly share code, notes, and snippets.

@kellobri

kellobri/server.R

Last active August 29, 2015 14:07
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save kellobri/625630d345ae05ca8d3a to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save kellobri/625630d345ae05ca8d3a to your computer and use it in GitHub Desktop.
Download ZIP
ShinyCCmaps-v2-3x3shell
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({
minLAct <- input$LArange[1]
maxLAct <- input$LArange[2]
minDI <- input$DIrange[1]
maxDI <- input$DIrange[2]
minOb <- input$OBrange[1]
maxOb <- input$OBrange[2]
#Apply Physical Activity and Obesity Prevalence Filters
c_a1data <- dataset %>%
filter(
val1 < minLAct,
val3 >= maxOb
)
c_a2data <- dataset %>%
filter(
val1 >= minLAct & val1 < maxLAct,
val3 >= maxOb
)
c_a3data <- dataset %>%
filter(
val1 >= maxLAct,
val3 >= maxOb
)
c_b1data <- dataset %>%
filter(
val1 < minLAct,
val3 >= minOb & val3 < maxOb
)
c_b2data <- dataset %>%
filter(
val1 >= minLAct & val1 < maxLAct,
val3 >= minOb & val3 < maxOb
)
c_b3data <- dataset %>%
filter(
val1 >= maxLAct,
val3 >= minOb & val3 < maxOb
)
c_c1data <- dataset %>%
filter(
val1 < minLAct,
val3 < minOb
)
c_c2data <- dataset %>%
filter(
val1 >= minLAct & val1 < maxLAct,
val3 < minOb
)
c_c3data <- dataset %>%
filter(
val1 >= maxLAct,
val3 < minOb
)
classData <- dataset
ctCol <- cut(classData$val2, breaks = c(0,minDI,maxDI,1), include.lowest=TRUE)
breaks <- c(0,minDI,maxDI,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")
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.2 : 3x3 Grid Continental US, Random-Uniform Data"),
#plotOutput("map"),
fluidRow(
column(4,
h4("Horizontal Filter Variable"),
sliderInput("LArange", "Range:", min = 0, max = 1, value = c(0.3,0.7))
),
column(4,
h4("Color Filter Variable"),
sliderInput("DIrange", "Range:", min = 0, max = 1, value = c(0.25,0.75))
),
column(4,
h4("Vertical Filter Variable"),
sliderInput("OBrange", "Range:", min = 0, max = 1, value = c(0.3,0.7))
)
),
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