ShinyCCmaps-v2-3x3shell

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)
		)
	
    })
  }	
)

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")
	      )
	)
	)					  

))