ShinyCCmaps-v3-StateCompare

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

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

))