#Author: Josh Roll
#Date: 5/12/2021
#Subject:  Z-score analysis to analyze Pedestrain Injuries
#Description: This script uses a standardized scoring method to categorize Census tracts in Oregon into categories based on their concentration of poverty and BIPOC populations.
#Commonly referred to as a Social Vulnerability Index, this categorization is then used to understand pedestrian injury rate disparies and pathways to these disparities that include
#traffic expsoure and built environmental variables

#Version notes:

#Load libraries
#------------------------------
	#Establish library path
	library(tigris)
	library(dplyr)
	library(rgdal)
	library(htmlwidgets)
	library(sf)
	library(stringr)
	library(leaflet)
	library(htmlwidgets)
	library(tidyr)
	library(ggplot2)

#Set environmanetal
#-----------------
  options( scipen = 10 )

#Define custom scripts functions
#------------------------------
	#Function that simplifies loading .RData objects
	assignLoad <- function(filename){
       load(filename)
       get(ls()[ls() != "filename"])
    }

	#Function to create bin labels
	label_Bins <- function(Breaks.){
		Labels_ <- list()
		for(i in 1:(length(Breaks.)-1)){
			Labels_[[i]] <- paste(Breaks.[[i]], Breaks.[[i + 1]], sep="-")
		}
		#Return result
		unlist(Labels_)
	}

#Load Data
#------------------------------------
	#Recent period
	##########################
	Load_Tracts.. <- assignLoad(file = "//wpdotfill09/R_VMP3_USERS/tdb069/Crash Analysis/SPR 841/Data/Crash Modeling/Tracts_Data_2014-2018.RData")
	#Use only tracts with land
	Tracts.. <- filter(Load_Tracts.., ALAND > 0)
	#Tracts.. %>% group_by(Tract) %>% summarise(Non_Drive_Prop = sum(Jtw_Transit +  Jtw_Walk + Jtw_Bike ) / sum(Workers))
	#Calcualte z scores
	Tracts.. <- #left_join(Tracts.., Tracts.. %>% group_by(Tract) %>% summarise(Non_Drive_Prop = sum(Jtw_Transit +  Jtw_Walk + Jtw_Bike ) / sum(Workers))) %>%
		Tracts.. %>%
		mutate(
			z_Poverty = as.numeric(scale(Poverty_Prop, center = TRUE, scale = TRUE)),
			z_Bipoc = as.numeric(scale(Bipoc_Prop, center = TRUE, scale = TRUE)),
			#z_Disability_Hh = as.numeric(scale(Disability_Hh_Prop, center = TRUE, scale = TRUE)) ,
			#z_Limited_English = as.numeric(scale(Limited_English, center = TRUE, scale = TRUE)) ,
			#z_Age_Over_64 = as.numeric(scale(Age_Over_64_Prop, center = TRUE, scale = TRUE)),
			#z_Non_Drive_Prop = as.numeric(scale(Non_Drive_Prop, center = TRUE, scale = TRUE)) ,
			#z_Vehicle_0_Prop = as.numeric(scale(Vehicle_0_Prop, center = TRUE, scale = TRUE)) ,
			#z_Vmt_All_Arterial_Density = as.numeric(scale(Vmt_All_Arterial_Density, center = TRUE, scale = TRUE)) ,
			#Miles_Non_Int_45_Plus_Density = as.numeric(scale(Miles_Non_Int_45_Plus_Density, center = TRUE, scale = TRUE)) ,
			#Mean_Transit_Stops_Density = as.numeric(scale(Mean_Transit_Stops_Density, center = TRUE, scale = TRUE)) ,
			#Index = z_Poverty + z_Bipoc
			Index = z_Poverty + z_Bipoc
			#Index = z_Non_Drive_Prop + z_Vehicle_0_Prop + z_Vmt_All_Arterial_Density + Mean_Transit_Stops_Density
	)

	#Create categories
	Tracts..$Index_Cat <- cut(Tracts..$Index, breaks = c(-10,-1,0,1,25), labels = c("Lowest","Low","Moderate","High"))
	Tracts..$Index_Cat <- as.character(Tracts..$Index_Cat)
	Tracts..$Index_Cat[is.na(Tracts..$Index_Cat)] <- "No Population"
	Tracts..$Index_Cat <- factor(Tracts..$Index_Cat, levels = c("No Population","Lowest","Low","Moderate","High"))
	#Add z score
	#Join with life expectancy
	Tracts.. <- left_join(Tracts.., Life_Exp.., by= "Tract")
	#Summarise data
	Index_Summary.. <- rbind(Tracts.. %>% group_by(Index_Cat) %>% summarise(
		Population = sum(Population),
		Ped_KABC_Mean = mean(Ped_KABC), Ped_KABC = sum(Ped_KABC), Ped_KA_Mean = mean(Ped_KA), Ped_KA = sum(Ped_KA),
		Ped_KABC_Rate = Ped_KABC / Population * 100000, Ped_KA_Rate = Ped_KA / Population*100000,
		Non_Drive_Prop = sum(Jtw_Transit +  Jtw_Walk + Jtw_Bike ) / sum(Workers),Vehicle_0_Prop = mean(Vehicle_0_Prop),
		Vmt_All_Arterial  = mean(Vmt_All_Arterial_Density)*1e6 , Miles_Non_Int_45_Plus_Density  = mean(Miles_Non_Int_45_Plus_Density) *100,Mean_Transit_Stops = mean(Mean_Transit_Stops_Density),
		Poverty_Prop = mean(Poverty_Prop), Bipoc_Prop = mean(Bipoc_Prop),
		Age_Over_64_Prop = mean(Age_Over_64_Prop),
		),
		#Create Oregon average row
		cbind(Index_Cat = "Oregon Average", Tracts.. %>% group_by() %>% 	summarise(Population = sum(Population),
		Ped_KABC_Mean = mean(Ped_KABC), Ped_KABC = sum(Ped_KABC), Ped_KA_Mean = mean(Ped_KA),Ped_KA = sum(Ped_KA),
		Ped_KABC_Rate = Ped_KABC / Population * 100000, Ped_KA_Rate = Ped_KA / Population*100000,
		Non_Drive_Prop = sum(Jtw_Transit +  Jtw_Walk + Jtw_Bike ) / sum(Workers),Vehicle_0_Prop = mean(Vehicle_0_Prop),
		Vmt_All_Arterial  = mean(Vmt_All_Arterial_Density)*1e6 , Miles_Non_Int_45_Plus_Density  = mean(Miles_Non_Int_45_Plus_Density) *100, Mean_Transit_Stops = mean(Mean_Transit_Stops_Density),
		Poverty_Prop = mean(Poverty_Prop), Bipoc_Prop = mean(Bipoc_Prop),
		Age_Over_64_Prop = mean(Age_Over_64_Prop)
	)))
	Ped_KABCO
	#Write to file
	###########################
	save(Tracts.., file = "//wpdotfill09/R_VMP3_USERS/tdb069/Crash Analysis/SPR 841/Data/Social Vulnerability Index/SVI_2014-2018.RData")
	write.csv(Tracts.., file = "//wpdotfill09/R_VMP3_USERS/tdb069/Crash Analysis/SPR 841/Data/Social Vulnerability Index/SVI_2014-2018.csv")

	#Summarise by index value
	Index_Summary.. <- rbind(Tracts.. %>% group_by(Index_Cat) %>% summarise(
		Population = sum(Population),
		Ped_KABCO_Mean = mean(Ped_KABCO), Ped_KABCO = sum(Ped_KABCO), Ped_KA_Mean = mean(Ped_KA), Ped_KA = sum(Ped_KA),
		Ped_KABCO_Rate = Ped_KABCO / Population * 100000, Ped_KA_Rate = Ped_KA / Population*100000,
		Non_Drive_Prop = sum(Jtw_Transit +  Jtw_Walk + Jtw_Bike ) / sum(Workers),Vehicle_0_Prop = mean(Vehicle_0_Prop),
		Vmt_All_Arterial  = mean(Vmt_All_Arterial_Density)*1e6 , Miles_Non_Int_45_Plus_Density  = mean(Miles_Non_Int_45_Plus_Density) *100,Mean_Transit_Stops = mean(Mean_Transit_Stops_Density),
		Poverty_Prop = mean(Poverty_Prop), Bipoc_Prop = mean(Bipoc_Prop),
		Age_Over_64_Prop = mean(Age_Over_64_Prop)
		),
		#Create Oregon average row
		cbind(Index_Cat = "Oregon Average", Tracts.. %>% group_by() %>% 	summarise(Population = sum(Population),
		Ped_KABCO_Mean = mean(Ped_KABCO), Ped_KABCO = sum(Ped_KABCO), Ped_KA_Mean = mean(Ped_KA),Ped_KA = sum(Ped_KA),
		Ped_KABCO_Rate = Ped_KABCO / Population * 100000, Ped_KA_Rate = Ped_KA / Population*100000,
		Non_Drive_Prop = sum(Jtw_Transit +  Jtw_Walk + Jtw_Bike ) / sum(Workers),Vehicle_0_Prop = mean(Vehicle_0_Prop),
		Vmt_All_Arterial  = mean(Vmt_All_Arterial_Density)*1e6 , Miles_Non_Int_45_Plus_Density  = mean(Miles_Non_Int_45_Plus_Density) *100, Mean_Transit_Stops = mean(Mean_Transit_Stops_Density),
		Poverty_Prop = mean(Poverty_Prop), Bipoc_Prop = mean(Bipoc_Prop),
		Age_Over_64_Prop = mean(Age_Over_64_Prop)
	))) %>% dplyr::select(c(Index_Cat,Poverty_Prop, Bipoc_Prop, Ped_KA_Rate, Ped_KABCO_Rate, Ped_KA, Ped_KABCO,Ped_KA_Mean, Ped_KABCO_Mean, Vmt_All_Arterial,
		 Miles_Non_Int_45_Plus_Density, Non_Drive_Prop, Mean_Transit_Stops,  Vehicle_0_Prop,Population))
	Index_Summary_1.. <- Index_Summary..
	#Format for table
	x <- t(Index_Summary..)
	#Format for table
	x <- t(Index_Summary..)
	Index_Summary_1.. <- Index_Summary..

	#Data descriptives for report
	#####################
	dat <- rbind(dplyr::select(mutate(Tracts..[,c("Tract","Poverty_Prop","Index_Cat")],Measure = Poverty_Prop, Type = "Poverty %"),-Poverty_Prop),
			dplyr::select(mutate(Tracts..[,c("Tract","Bipoc_Prop","Index_Cat")],Measure = Bipoc_Prop, Type = "BIPOC %"),-Bipoc_Prop),
			#dplyr::select(mutate(Index..[,c("Tract","Disability_Hh_Prop","Index_Cat")],Measure = Disability_Hh_Prop, Type = "Disability %"),-Disability_Hh_Prop),
			#dplyr::select(mutate(Index..[,c("Tract","Limited_English_Prop","Index_Cat")],Measure = Limited_English_Prop, Type = "Limted English Proficiency %"),-Limited_English_Prop),
			#dplyr::select(mutate(Index..[,c("Tract","Age_Over_64_Prop","Index_Cat")],Measure = Age_Over_64_Prop, Type = "Population 65+ %"),-Age_Over_64_Prop),
			dplyr::select(mutate(Tracts..[,c("Tract","Index","Index_Cat")],Measure = Index, Type = "Composite SVI Index"),-Index))
	 group_by(Type) %>% summarise(Mean = mean(Measure)),by = "Type")

	#Chart the index values to determine cut lines for categories
	#############################
	dat <- filter(dat, Type == "Composite SVI Index" & !(Index_Cat%in%"No Population") )
	#dat <- mutate(filter(dat,!(Index_Cat%in%"No Population") ),

	ggplot(dat, aes(Measure)) +
		geom_histogram(binwidth = 0.1, aes(fill = Index_Cat)) +
		facet_wrap(~Type, scales = "free",nrow = 3) +
		ylab("Count of Tracts") + xlab("Composite Z-Score") +
		ggtitle("Distribution of Composite Z-Scores for Race/Ethnicity & Income Index (REII)\n2014-2018") +
		#scale_fill_manual( values=c(Colors.)) +
		theme(text = element_text(size = 16)) +
		#geom_hline(yintercept=	State_Avg_K_Rate., linetype = "dashed", color = "grey42", size = 1.25) +
		#Center plot
		theme(plot.title = element_text(hjust = 0.5)) +
		guides(fill=guide_legend(title="Race/Ethnicity & \nIncome (REII) Index\nCategory")) +
		theme(legend.text=element_text(size=16),legend.title=element_text(size=16)) +
		theme(axis.text.y=element_text(size=16),axis.title.y=element_text(size=16)) +
		theme(axis.text.x=element_text(size=16),axis.title.x=element_text(size=16)) +
		theme(axis.title.x=element_text(size=16)) +
		theme(strip.text.x = element_text(size = 14)) +
		geom_vline(xintercept=c(0), linetype="dashed", color = "black", size=1) +
		geom_vline(xintercept=c(-1,1), linetype="twodash", color = "black", size=1)
		#annotate("text", aes(x = Mean), y = 65, label = "Oregon Average", size = 8.5)
		#geom_text(aes(x = 0), y = 65, label = "Oregon Average", size = 8.5)

	#Create a chart of rates by index value
	#############################
	#NMake a copy of data
	dat <- mutate(filter(Index_Summary_1.., !(Index_Cat%in%c("No Population","Oregon Average"))), Ped_KA_Rate_Label = round(Ped_KA_Rate,1))
	#Iregon average
	Avg_Rate <- filter(Index_Summary.., Index_Cat=="Oregon Average")$Ped_KA_Rate
	Colors. <- colorRampPalette(c("grey","blue", "red"))(4)
	dat$Avg_Rate <- Avg_Rate
	dat1 <- dat

	#Chart for report
	####################
	ggplot(dat, aes(x = Index_Cat, y = Ped_KA_Rate)) +
	  geom_bar(stat="identity", width=.5, position = "dodge",aes(fill = Index_Cat))  +
	  geom_text(aes(x = Index_Cat, y = Ped_KA_Rate, label = Ped_KA_Rate_Label),fontface = "bold", size = 8, position = position_nudge(y = 1.0)) +
	  ylab("Injuries per 100,000 people") + xlab("Social Vulnerability Index") +
	  ggtitle("Pedestrian Fatal & Severe Injury Rate by\n Social Vulnerability Index\n in Oregon\n2014 - 2018") +
	  scale_fill_manual( values=c(Colors.)) +
	   theme(text = element_text(size = 16)) +
	  #geom_hline(yintercept=	State_Avg_K_Rate., linetype = "dashed", color = "grey42", size = 1.25) +
	  #Center plot
	  theme(plot.title = element_text(hjust = 0.5)) +
	  guides(fill=guide_legend(title="Social Vulnerability Index")) +
	  theme(legend.text=element_text(size=16),legend.title=element_text(size=16)) +
	  theme(axis.text.y=element_text(size=16),axis.title.y=element_text(size=16)) +
	  theme(axis.text.x=element_text(size=16),axis.title.x=element_text(size=16)) +
	  theme(axis.title.x=element_text(size=16)) +
	  theme(strip.text.x = element_text(size = 14)) +
	  geom_hline(yintercept=Avg_Rate, linetype="dashed", color = "black", size=1) +
	  annotate("text", x = 1.1, y = Avg_Rate+1.5, label = "Oregon Average", size = 8.5)

	#Chart for Equity Series
	####################
	mypal <- colorFactor("Spectral", domain =1:5, na.color = "grey")
	Colors. <- 	mypal(c(1:5))
	Colors. <- 	mypal(c(2,3,4,5))

	ggplot(dat, aes(x = Index_Cat, y = Ped_KA_Rate)) +
	  geom_bar(stat="identity", width=.5, position = "dodge",aes(fill = Index_Cat))  +
	  geom_text(aes(x = Index_Cat, y = Ped_KA_Rate, label = Ped_KA_Rate_Label),fontface = "bold", size = 8, position = position_nudge(y = 1.0)) +
	  ylab("Injuries per 100,000 people") + xlab("Level of Concentration of Low income and BIPOC Populations") +
	  ggtitle("Pedestrian Fatal & Severe Injury Rate by\n Low Income & BIPOC Populations Concentration Level\n in Oregon\n2014 - 2018") +
	  scale_fill_manual( values=c(Colors.)) +
	   theme(text = element_text(size = 16)) +
	  #geom_hline(yintercept=	State_Avg_K_Rate., linetype = "dashed", color = "grey42", size = 1.25) +
	  #Center plot
	  theme(plot.title = element_text(hjust = 0.5)) +
	  guides(fill=guide_legend(title="Concentration Level")) +
	  theme(legend.text=element_text(size=16),legend.title=element_text(size=16)) +
	  theme(axis.text.y=element_text(size=16),axis.title.y=element_text(size=16)) +
	  theme(axis.text.x=element_text(size=16),axis.title.x=element_text(size=16)) +
	  theme(axis.title.x=element_text(size=16)) +
	  theme(strip.text.x = element_text(size = 14)) +
	  geom_hline(yintercept=Avg_Rate, linetype="dashed", color = "black", size=1) +
	  annotate("text", x = 1.1, y = Avg_Rate+1.5, label = "Oregon Average", size = 8.5)

	#Chart for Equity Series
	####################
	mypal <- colorFactor("Spectral", domain =1:5, na.color = "grey")
	Colors. <- 	mypal(c(1:5))
	Colors. <- 	mypal(c(2,3,4,5))

	ggplot(dat, aes(x = Index_Cat, y = Ped_KA_Rate)) +
		geom_bar(stat="identity", width=.5, position = "dodge",aes(fill = Index_Cat))  +
		geom_text(aes(x = Index_Cat, y = Ped_KA_Rate, label = Ped_KA_Rate_Label),fontface = "bold", size = 8, position = position_nudge(y = 1.0)) +
		ylab("Injuries per 100,000 people") + xlab("Level of Concentration of Low income and BIPOC Populations") +
		ggtitle("Pedestrian Fatal & Severe Injury Rate by\n Low Income & BIPOC Populations Concentration Level\n in Oregon\n2014 - 2018") +
		scale_fill_manual( values=c(Colors.)) +
		theme(text = element_text(size = 16)) +
		#geom_hline(yintercept=	State_Avg_K_Rate., linetype = "dashed", color = "grey42", size = 1.25) +
		theme(plot.title = element_text(hjust = 0.5)) +
		guides(fill=guide_legend(title="Concentration Level")) +
		theme(legend.text=element_text(size=20),legend.title=element_text(size=20)) +
		theme(axis.text.x=element_text(size=20),axis.title.x=element_text(size=20)) +
		theme(strip.text.x = element_text(size = 2)) +
		theme(text = element_text(size = 20))  +
		geom_hline(yintercept=Avg_Rate, linetype="dashed", color = "black", size=1) +
		annotate("text", x = 1.1, y = Avg_Rate+1.5, label = "Oregon Average", size = 8.5)

#------------------------------------------------------------------------------------
#Historic period - 2008-2012
#------------------------------------------------------------------------------------
	#Load data
	Load_Tracts.. <- assignLoad(file = "//wpdotfill09/R_VMP3_USERS/tdb069/Crash Analysis/SPR 841/Data/Crash Modeling/Tracts_Data_2008-2012.RData")
	#Select only tracts with land
	Tracts.. <- filter(Load_Tracts.., ALAND >0)
	#Calcualte standarized scores
	Tracts.. <- Tracts.. %>%
		mutate(
		z_Poverty = as.numeric(scale(Poverty_Prop, center = TRUE, scale = TRUE)),
		z_Bipoc = as.numeric(scale(Bipoc_Prop, center = TRUE, scale = TRUE)),
		z_Disability_Hh = as.numeric(scale(Disability_Hh_Prop, center = TRUE, scale = TRUE)) ,
		z_Limited_English = as.numeric(scale(Limited_English, center = TRUE, scale = TRUE)) ,
		z_Age_Over_64 = as.numeric(scale(Age_Over_64_Prop, center = TRUE, scale = TRUE)) ,
		Index = z_Poverty + z_Bipoc
	)
	#Create categories for the index
	Tracts..$Index_Cat <- cut(Tracts..$Index, breaks = c(-9.0,-1,0,1,13), labels = c("Lowest","Low","Moderate","High"))
	Tracts..$Index_Cat <- as.character(Tracts..$Index_Cat)
	Tracts..$Index_Cat[is.na(Tracts..$Index_Cat)] <- "No Population"
	Tracts..$Index_Cat <- factor(Tracts..$Index_Cat, levels = c("No Population","Lowest","Low","Moderate","High"))

	#Write to file
	save(Tracts.., file = "//wpdotfill09/R_VMP3_USERS/tdb069/Crash Analysis/SPR 841/Data/Social Vulnerability Index/SVI_2008-2012.RData")
	write.csv(Tracts.., file = "//wpdotfill09/R_VMP3_USERS/tdb069/Crash Analysis/SPR 841/Data/Social Vulnerability Index/SVI_2008-2012.csv")

	#Summarise by index value
	Index_Summary.. <- rbind(Tracts.. %>% group_by(Index_Cat) %>% summarise(
		Population = sum(Population),
		Ped_KABCO_Mean = mean(Ped_KABCO), Ped_KABCO = sum(Ped_KABCO), Ped_KA_Mean = mean(Ped_KA), Ped_KA = sum(Ped_KA),
		Ped_KABCO_Rate = Ped_KABCO / Population * 100000, Ped_KA_Rate = Ped_KA / Population*100000,
		Non_Drive_Prop = sum(Jtw_Transit +  Jtw_Walk + Jtw_Bike ) / sum(Workers),Vehicle_0_Prop = mean(Vehicle_0_Prop),
		Vmt_All_Arterial  = mean(Vmt_All_Arterial_Density)*1e6 , Miles_Non_Int_45_Plus_Density  = mean(Miles_Non_Int_45_Plus_Density) *100,Mean_Transit_Stops = mean(Mean_Transit_Stops_Density),
		Poverty_Prop = mean(Poverty_Prop), Bipoc_Prop = mean(Bipoc_Prop),
		Age_Over_64_Prop = mean(Age_Over_64_Prop)
		),
		#Create Oregon average row
		cbind(Index_Cat = "Oregon Average", Tracts.. %>% group_by() %>% 	summarise(Population = sum(Population),
		Ped_KABCO_Mean = mean(Ped_KABCO), Ped_KABCO = sum(Ped_KABCO), Ped_KA_Mean = mean(Ped_KA),Ped_KA = sum(Ped_KA),
		Ped_KABCO_Rate = Ped_KABCO / Population * 100000, Ped_KA_Rate = Ped_KA / Population*100000,
		Non_Drive_Prop = sum(Jtw_Transit +  Jtw_Walk + Jtw_Bike ) / sum(Workers),Vehicle_0_Prop = mean(Vehicle_0_Prop),
		Vmt_All_Arterial  = mean(Vmt_All_Arterial_Density)*1e6 , Miles_Non_Int_45_Plus_Density  = mean(Miles_Non_Int_45_Plus_Density) *100, Mean_Transit_Stops = mean(Mean_Transit_Stops_Density),
		Poverty_Prop = mean(Poverty_Prop), Bipoc_Prop = mean(Bipoc_Prop),
		Age_Over_64_Prop = mean(Age_Over_64_Prop)
	))) %>% dplyr::select(c(Index_Cat,Poverty_Prop, Bipoc_Prop, Ped_KA_Rate, Ped_KABCO_Rate, Ped_KA, Ped_KABCO,Ped_KA_Mean, Ped_KABCO_Mean, Vmt_All_Arterial,
		 Miles_Non_Int_45_Plus_Density, Non_Drive_Prop, Mean_Transit_Stops,  Vehicle_0_Prop,Population))
	Index_Summary_2.. <- Index_Summary..
	#Format for table
	x <- t(Index_Summary..)
	Tracts.. %>% group_by(Index_Cat) %>% summarise(Tract_Count = length(Tract))
	#Create a chart
	#############################
	#NMake a copy of data
	dat <- mutate(filter(Index_Summary.., !(Index_Cat%in%c("No Population","Oregon Average"))), Ped_KA_Rate_Label = round(Ped_KA_Rate,1))
	#Iregon average
	Avg_Rate <- filter(Index_Summary.., Index_Cat=="Oregon Average")$Ped_KA_Rate
	Colors. <- colorRampPalette(c("grey","blue", "red"))(4)
	dat$Avg_Rate <- Avg_Rate
	dat2 <- dat
#	Plot <-
	ggplot(dat, aes(x = Index_Cat, y = Ped_KA_Rate)) +
	  geom_bar(stat="identity", width=.5, position = "dodge",aes(fill = Index_Cat))  +
	  geom_text(aes(x = Index_Cat, y = Ped_KA_Rate, label = Ped_KA_Rate_Label),fontface = "bold", size = 8, position = position_nudge(y = 1.5)) +
	    ylab("Injuries per 100,000 people") + xlab("Concentration Index") +
	  ggtitle("Pedestrian Fatal & Severe Injury Rate by\n \n in Oregon\n2008-2012") +
	  scale_fill_manual( values=c(Colors.)) +
	   theme(text = element_text(size = 16)) +
	  #geom_hline(yintercept=	State_Avg_K_Rate., linetype = "dashed", color = "grey42", size = 1.25) +
	  #Center plot
	  theme(plot.title = element_text(hjust = 0.5)) +
	  guides(fill=guide_legend(title="Social Vulnerability Index")) +
	  theme(legend.text=element_text(size=16),legend.title=element_text(size=16)) +
	  theme(axis.text.y=element_text(size=16),axis.title.y=element_text(size=16)) +
	  theme(axis.text.x=element_text(size=16),axis.title.x=element_text(size=16)) +
	  theme(axis.title.x=element_text(size=16)) +
	  theme(strip.text.x = element_text(size = 14)) +
	  geom_hline(yintercept=Avg_Rate, linetype="dashed", color = "black", size=1) +
	  annotate("text", x = 1.1, y = Avg_Rate+1.5, label = "Oregon Average", size = 8.5)

	#Show both periods
	##############################
	#Make a copy of data
	dat1 <- 	Index_Summary_1..
	dat2 <- 	Index_Summary_2..
	dat <- rbind(cbind(dat1[,colnames(dat2)],Year = "Period: 2014-2018"),
		cbind(dat2,Year = "Period: 2008-2012")) %>% mutate(Ped_KA_Rate_Label = round(Ped_KA_Rate,1),Ped_KABCO_Rate_Label = round(Ped_KABCO_Rate,1))
	dat <- left_join(dat, data.frame(Avg_Rate = filter(dat, Index_Cat=="Oregon Average")$Ped_KA_Rate, Year = filter(dat, Index_Cat=="Oregon Average")$Year))
	dat <- dat[dat$Index_Cat != "Oregon Average",]
	Colors. <- colorRampPalette(c("grey","blue", "red"))(4)
	mypal <- colorFactor("Spectral", domain =1:5, na.color = "grey")
	Colors. <- 	mypal(c(1:5))
	Colors. <- 	mypal(c(2,3,4,5))

	#Fatal and severe injury rate--------------
#	Plot <-
	ggplot(dat, aes(x = Index_Cat, y = Ped_KA_Rate)) +
	  geom_bar(stat="identity", width=.5, position = "dodge",aes(fill = Index_Cat))  +
	  geom_text(aes(x = Index_Cat, y = Ped_KA_Rate, label = Ped_KA_Rate_Label),fontface = "bold", size = 10, position = position_nudge(y = 1.0)) +
	  ylab("Injuries per 100,000 people") + xlab("Concentration Index") +
	  ggtitle("Changes in\nPedestrian Fatal & Severe Injury Rate by\n Low Income & BIPOC Populations Concentration Level\n in Oregon") +
	  scale_fill_manual( values=c(Colors.)) +
	   theme(text = element_text(size = 16)) +
	  facet_wrap(~Year, nrow = 1) +
	  #Center plot
	  theme(plot.title = element_text(hjust = 0.5)) +
	  guides(fill=guide_legend(title="Concentration Level")) +
	  theme(axis.text.x=element_text(size=20),axis.title.x=element_text(size=20)) +
	  theme(strip.text.x = element_text(size = 2)) +
	  theme(text = element_text(size = 20))  +
	  geom_hline(aes(yintercept=Avg_Rate), linetype="dashed", color = "black", size=1) +
	  geom_text(aes(x = 1.1, y = Avg_Rate + 1.5), label = "Oregon Average", size = 8.5)
	#All injury rate--------------
	dat1 <- 	Index_Summary_1..
	dat2 <- 	Index_Summary_2..
	dat <- rbind(cbind(dat1[,colnames(dat2)],Year = "Period: 2014-2018"),
		cbind(dat2,Year = "Period: 2008-2012")) %>% mutate(Ped_KA_Rate_Label = round(Ped_KA_Rate,1),Ped_KABCO_Rate_Label = round(Ped_KABCO_Rate,1))
	dat <- left_join(dat, data.frame(Avg_Rate = filter(dat, Index_Cat=="Oregon Average")$Ped_KABCO_Rate, Year = filter(dat, Index_Cat=="Oregon Average")$Year))
	dat <- dat[dat$Index_Cat != "Oregon Average",]
	Colors. <- colorRampPalette(c("grey","blue", "red"))(4)
	mypal <- colorFactor("Spectral", domain =1:5, na.color = "grey")
	Colors. <- 	mypal(c(1:5))
	Colors. <- 	mypal(c(2,3,4,5))
	ggplot(dat, aes(x = Index_Cat, y = Ped_KABCO_Rate)) +
	  geom_bar(stat="identity", width=.5, position = "dodge",aes(fill = Index_Cat))  +
	  geom_text(aes(x = Index_Cat, y = Ped_KABCO_Rate +5, label = Ped_KABCO_Rate_Label),fontface = "bold", size = 10, position = position_nudge(y = 1.0)) +
	  ylab("Injuries per 100,000 people") + xlab("Concentration Index") +
	  ggtitle("Changes in\nPedestrian Injury Rate by\n Low Income & BIPOC Populations Concentration Level\n in Oregon") +
	  scale_fill_manual( values=c(Colors.)) +
	   theme(text = element_text(size = 16)) +
	  facet_wrap(~Year, nrow = 1) +
	  #Center plot
	  theme(plot.title = element_text(hjust = 0.5)) +
	  guides(fill=guide_legend(title="Concentration Level")) +
	  theme(axis.text.x=element_text(size=20),axis.title.x=element_text(size=20)) +
	  theme(strip.text.x = element_text(size = 2)) +
	  theme(text = element_text(size = 20))  +
	  geom_hline(aes(yintercept=Avg_Rate), linetype="dashed", color = "black", size=1) +
	  geom_text(aes(x = 1.1, y = Avg_Rate + 6.9), label = "Oregon Average", size = 8.5)

	#Show change in rate
	##############################
	#Make a copy of data
	dat1 <- 	Index_Summary_1..#rbind(cbind(Index_Summary_1..[,c("Index_Cat")], Index_Summary_1..[,c("Population","Ped_KA_Rate","Ped_KABCO_Rate")], Index_Summary_2..[,c("Population","Ped_KA_Rate","Ped_KABCO_Rate")]))
	dat2 <- 	Index_Summary_2..
	dat <- rbind(cbind(dat1[,colnames(dat2)],Year = "Period: 2014-2018"),
		cbind(dat2,Year = "Period: 2008-2012")) %>% mutate(Ped_KA_Rate_Label = round(Ped_KA_Rate,1))
	dat <- left_join(dat, data.frame(Avg_Rate = filter(dat, Index_Cat=="Oregon Average")$Ped_KA_Rate, Year = filter(dat, Index_Cat=="Oregon Average")$Year))
	dat <- dat[dat$Index_Cat != "Oregon Average",]
	Colors. <- colorRampPalette(c("grey","blue", "red"))(4)

#	Plot <-
	ggplot(dat, aes(x = Index_Cat, y = Ped_KA_Rate)) +
	  geom_bar(stat="identity", width=.5, position = "dodge",aes(fill = Index_Cat))  +
	  geom_text(aes(x = Index_Cat, y = Ped_KA_Rate, label = Ped_KA_Rate_Label),fontface = "bold", size = 8, position = position_nudge(y = 1.0)) +
	  ylab("Injuries per 100,000 people") + xlab("Race/Ethnicity Concentration Index") +
	  ggtitle("Changes in\nPedestrian Fatal & Severe Injury Rate by\n Concentration Index\n in Oregon") +
	  scale_fill_manual( values=c(Colors.)) +
	   theme(text = element_text(size = 16)) +
	  facet_wrap(~Year, nrow = 1) +
	  #Center plot
	  theme(plot.title = element_text(hjust = 0.5)) +
	  guides(fill=guide_legend(title="Social Vulnerability Index")) +
	  theme(legend.text=element_text(size=16),legend.title=element_text(size=16)) +
	  theme(axis.text.y=element_text(size=16),axis.title.y=element_text(size=16)) +
	  theme(axis.text.x=element_text(size=16),axis.title.x=element_text(size=16)) +
	  theme(axis.title.x=element_text(size=16)) +
	  theme(strip.text.x = element_text(size = 14)) +
	  geom_hline(aes(yintercept=Avg_Rate), linetype="dashed", color = "black", size=1) +
	  #annotate("text", x = 1.1, y = Avg_Rate+1.5, label = "Oregon Average", size = 8.5)
	  geom_text(aes(x = 1.1, y = Avg_Rate + 1.5), label = "Oregon Average", size = 8.5)

	#Show just the

	#Show change in Select metrics
	##############################
	#Make a copy of data
	dat1 <- 	Index_Summary_1..
	dat2 <- 	Index_Summary_2..
	dat <- rbind(cbind(dat1[,colnames(dat2)],Year = "Period: 2014-2018"),
		cbind(dat2,Year = "Period: 2008-2012")) %>% mutate(Ped_KA_Rate_Label = round(Ped_KA_Rate,1))

	dat <- rbind(dplyr::select(cbind(dat[,c("Index_Cat","Poverty_Prop","Year")],Measure = "Poverty %",Type = "Social Vulnerability Factors") %>% mutate(Value = Poverty_Prop),c(-Poverty_Prop)),
		dplyr::select(cbind(dat[,c("Index_Cat","Bipoc_Prop","Year")],Measure = "Black, Indigenous & People of Color %",Type = "BIPOC %")%>% mutate(Value = Bipoc_Prop),c(-Bipoc_Prop)),
		dplyr::select(cbind(dat[,c("Index_Cat","Ped_KA_Rate","Year")],Measure = "Pedestrian\nFatal & Severe Injuries Rate",Type = "Pedestrian Injury")%>% mutate(Value = Ped_KA_Rate),c(-Ped_KA_Rate)),
		dplyr::select(cbind(dat[,c("Index_Cat","Ped_KABCO_Rate","Year")],Measure = "Pedestrian\nAll Injuries Rate",Type = "Pedestrian Injury")%>% mutate(Value =Ped_KABCO_Rate),c(-Ped_KABCO_Rate)),
		dplyr::select(cbind(dat[,c("Index_Cat","Non_Drive_Prop","Year")],Measure = "Walk + Transit + Bike Commute %",Type = "Non_Vehicle Commuting")%>% mutate(Value = Non_Drive_Prop),c(-Non_Drive_Prop)),
		dplyr::select(cbind(dat[,c("Index_Cat","Vehicle_0_Prop","Year")],Measure = "% Households with No Vehicle",Type = "Vehicle Qwnership")%>% mutate(Value = Vehicle_0_Prop),c(-Vehicle_0_Prop)),
		dplyr::select(cbind(dat[,c("Index_Cat","Vmt_All_Arterial","Year")],Measure = "VMT on Arterials Density (Millions per Sqmi)",Type = "Vehicle Exposure")%>% mutate(Value = Vmt_All_Arterial),c(-Vmt_All_Arterial)),
		dplyr::select(cbind(dat[,c("Index_Cat","Mean_Transit_Stops","Year")],Measure = "Transit Stops per Sqmi",Type = "Transit")%>% mutate(Value = Mean_Transit_Stops),c(-Mean_Transit_Stops)),
		dplyr::select(cbind(dat[,c("Index_Cat","Miles_Non_Int_45_Plus_Density","Year")],Measure = "High Speed (45 mph +) Roadway Density\nNon-Freeway/Highway",Type = "Speed")%>% mutate(Value = Miles_Non_Int_45_Plus_Density),c(-Miles_Non_Int_45_Plus_Density)))
	dat <- dat[dat$Index_Cat != "Oregon Average",]

	Colors. <- colorRampPalette(c("grey","blue", "red"))(4)
	#SHow just the rate changes
	dat1 <-filter(dat, Measure%in%c("Pedestrian\nFatal & Severe Injuries Rate","Pedestrian\nAll Injuries Rate"))
	dat1$Measure <- factor(dat1$Measure,levels =  c("Pedestrian\nFatal & Severe Injuries Rate","Pedestrian\nAll Injuries Rate"))

	ggplot(dat1, aes(x = Index_Cat, y = Value)) +
	  geom_bar(stat="identity", width=.5, position = "dodge",aes(fill = Year)) +
		ylab("Pedestrian Injury Rate per 100,000") + xlab("Social Vulnerability Index") +
		ggtitle("Changes in\nPedestrian Injury Rate by Social Vulnerability Index\n in Oregon Over Time") +
		# scale_fill_manual( values=c(Colors.)) +
		theme(text = element_text(size = 16)) +
		facet_wrap(~Measure,  scales = "free", nrow = 1) +
		#scale_y_continuous(labels = scales::percent) +
		#Center plot
		theme(plot.title = element_text(hjust = 0.5)) +
		 guides(fill=FALSE) +
		theme(legend.text=element_text(size=16),legend.title=element_text(size=16)) +
		theme(axis.text.y=element_text(size=16),axis.title.y=element_text(size=16)) +
		theme(axis.text.x=element_text(size=16),axis.title.x=element_text(size=16)) +
		theme(axis.title.x=element_text(size=16)) +
		theme(strip.text.x = element_text(size = 14))

	#Percetnage measures
	dat1 <-filter(dat, Measure%in%c("Poverty %","Black, Indigenous & People of Color %", "Walk + Transit + Bike Commute %","% Households with No Vehicle"))
	dat1$Measure <- factor(dat1$Measure,levels =  c("Poverty %","Black, Indigenous & People of Color %", "Walk + Transit + Bike Commute %","% Households with No Vehicle"))
	Plot1 <-
	ggplot(dat1, aes(x = Index_Cat, y = Value)) +
	  geom_bar(stat="identity", width=.5, position = "dodge",aes(fill = Year)) +
		ylab("for Presented Measure                                        ") + xlab("Concentration Level") +
		ggtitle("Changes in\nPedestrian Fatal & Severe Injury Rate by\n Concentration Level\n in Oregon") +
		# scale_fill_manual( values=c(Colors.)) +
		theme(text = element_text(size = 16)) +
		facet_wrap(~Measure,  scales = "free", nrow = 1) +
		scale_y_continuous(labels = scales::percent) +
		#Center plot
		theme(plot.title = element_text(hjust = 0.5)) +
		 guides(fill=FALSE) +
		theme(legend.text=element_text(size=16),legend.title=element_text(size=16)) +
		theme(axis.text.y=element_text(size=16),axis.title.y=element_text(size=16)) +
		theme(axis.text.x=element_text(size=16),axis.title.x=element_text(size=16)) +
		theme(axis.title.x=element_text(size=16)) +
		theme(strip.text.x = element_text(size = 14))
	#Non percentage measures
	dat2 <-filter(dat, Measure%in%c("Pedestrian\nFatal & Severe Injuries Rate", "VMT on Arterials Density (Millions per Sqmi)","High Speed (45 mph +) Roadway Density\nNon-Freeway/Highway","Transit Stops per Sqmi"))
	dat2$Measure <- factor(dat2$Measure,levels =  c("Pedestrian\nFatal & Severe Injuries Rate", "VMT on Arterials Density (Millions per Sqmi)","High Speed (45 mph +) Roadway Density\nNon-Freeway/Highway","Transit Stops per Sqmi"))
	Plot2 <-
	ggplot(dat2, aes(x = Index_Cat, y = Value)) +
	  geom_bar(stat="identity", width=.5, position = "dodge",aes(fill = Year)) +
		ylab("                                                       Mean Tract Value") + xlab("Concentration Level") +
		ggtitle("") +
		# scale_fill_manual( values=c(Colors.)) +
		theme(text = element_text(size = 16)) +
		facet_wrap(~Measure,  scales = "free",nrow=1) +
		scale_y_continuous(labels = scales::comma) +
		#Center plot
		theme(plot.title = element_text(hjust = 0.5)) +
		theme(legend.position="bottom") +

		theme(legend.text=element_text(size=16),legend.title=element_text(size=16)) +
		theme(axis.text.y=element_text(size=16),axis.title.y=element_text(size=16)) +
		theme(axis.text.x=element_text(size=16),axis.title.x=element_text(size=16)) +
		theme(axis.title.x=element_text(size=16)) +
		theme(strip.text.x = element_text(size = 14))

	#Dual chart
	gridExtra::grid.arrange(Plot1, Plot2)

#Map data
#-----------------------------------------
	#Init projection files
	Projection_LatLong <- "+proj=longlat +zone=10 +datum=WGS84 +ellps=WGS84 +towgs84=0,0,0"
	Projection_Utm <- "+proj=utm +zone=10 +datum=WGS84 +ellps=WGS84 +towgs84=0,0,0"
	#Load spatial data
	fgdb <-    "//wpdotfill09/R_VMP3_USERS/tdb069/Data/Census/Data/Spatial/Oregon_Census_Data.gdb"
	Load_Tracts_10_Sp <-  readOGR(dsn=fgdb,layer= "Oregon_Tracts_2010")
	#Ensure proper projections
	Load_Tracts_10_Sp <- spTransform(Load_Tracts_10_Sp, CRS(Projection_Utm))
	#Rename block group names
	Load_Tracts_10_Sp@data <- mutate(Load_Tracts_10_Sp@data, Tract = GEOID,   Land_Area_Sq_Me = ALAND, Land_Area_Sq_Ft =  ALAND * 10.7639, Land_Area_Sq_Mi =  (ALAND * 10.7639) * 3.587006427915519e-8)
	#Load tracts with urban area prop calculate
	Tract_Urban_Prop_Sp <- assignLoad("//wpdotfill09/R_VMP3_USERS/tdb069/Data/Census/Data/SPR 841/Urban Proportions/Tracts_Urban_Prop_2010.RData")
	#Join
	Load_Tracts_10_Sp@data <- left_join(Load_Tracts_10_Sp@data,Tract_Urban_Prop_Sp@data[,c("Tract","Urban_Area_Prop","Urban_Area")],by = "Tract")
	#Load tract data with index
	Tracts.. <-  file = "//wpdotfill09/R_VMP3_USERS/tdb069/Crash Analysis/SPR 841/Data/Social Vulnerability Index/SVI_2014-2018.RData")

	#Load data from file
	#Summary.. <- assignLoad(file = "//wpdotfill09/R_VMP3_USERS/tdb069/Data/OLCC/Data/Processed/OLCC_Block_Groups_2000_2020.RData")
	dat <- Load_Tracts_10_Sp
	#Join summary data
	dat@data <- 	left_join(dat@data,Tracts.., by = "Tract") %>% mutate(Non_Drive_Commute_Prop = Jtw_Transit_Prop + Jtw_Walk_Prop + Jtw_Bike_Prop,
		Ped_KA_Rate = Ped_KA / Population *100000,Ped_KABCO_Rate = Ped_KABCO / Population *100000)
	#Transform
	dat <- spTransform(		dat, CRS(Projection_LatLong))
	dat <- dat[!(is.na(dat@data$Population)),]
	#Create palette
	#rc1 <- colorRampPalette(colors = c("lightblue", "red"), space = "Lab")(4)

	mypal <- colorFactor("Spectral", domain = dat@data$Index_Cat, na.color = "grey")

	Map <- leaflet() %>% addTiles() %>%
	  addPolygons(data=dat, smoothFactor = 0.2, fillOpacity = .5,	color = ~mypal(Index_Cat),
				  popup = paste("Tract ", dat@data$Tract,"<br>",
						"Index Category", dat@data$Index_Cat,"<br>",
						"Pedestrian Fatal & Severe Injury Rate", round(dat@data$Ped_KA_Rate,1),"<br>",
						"All Pedestrian Injury Rate", round(dat@data$Ped_KABCO_Rate,1),"<br>",
						"Pedestrian Fatal & Severe Injuries", round(dat@data$Ped_KA,1),"<br>",
						"All Pedestrian Injuries", round(dat@data$Ped_KABCO,1),"<br>",
						"Poverty %", round(dat@data$Poverty_Prop,3)*100,"<br>",
						"BIPOC %", round(dat@data$Non_White_Prop,3)*100,"<br>",
						"Non-Drive Commute %", round(dat@data$Non_Drive_Commute_Prop,3)*100,"<br>",
						"Arterial Vmt Density", round(dat@data$Vmt_All_Arterial_Density*1e6,0),"<br>",
						"High Speed Roads", round(dat@data$Miles_Non_Int_45_Plus*100,0),"<br>",
						"Zero Vehicle Households %", round(dat@data$Vehicle_0_Prop,3)*100,"<br>",
						"Population", dat@data$Population)) %>%
	  addLegend("bottomright",  pal = mypal, values = dat@data$Index_Cat,title = "Concentration Level",    opacity = 1)

	#Save file
	saveWidget(Map, file="//wpdotfill09/R_VMP3_USERS/tdb069/Crash Analysis/SPR 841/Reports/Dynamic Maps/Tract_Concentration_Maps_2014-2018.html", selfcontained = T)

	#Ped injury rate map
	###########################
	dat <- dat[!(is.na(dat@data$Population)),]
	dat <- dat[!(is.infinite(dat@data$Ped_KA_Rate)) ,]
	Breaks. <- c(0,7,quantile(dat@data$Ped_KA_Rate, prob = seq(0, 1, length = 21), type = 5, na.rm=T)[11:21])
	Bin_Labels. <- label_Bins(round(Breaks.,0))
	dat$Ped_KA_Rate_Cat <- cut(dat$Ped_KA_Rate, breaks = Breaks., labels = Bin_Labels.)
	rc1 <- colorRampPalette(colors = c("white","blue", "red"), space = "Lab")(10)
	#mypal <- colorFactor("Spectral", domain = dat@data$Ped_KA_Rate_Cat, na.color = "grey")
	mypal <- colorFactor(rc1, domain = dat@data$Ped_KA_Rate_Cat, na.color = "grey")
	#mypal <- colorNumeric("RdYlBu", domain = 1:12, na.color = "grey")
	#mypal <- colorNumeric(rc1, domain = dat@data$Ped_KA_Rate, na.color =  "grey")
	Map <- leaflet() %>% addTiles() %>%
	  addPolygons(data=dat, smoothFactor = 0.2, fillOpacity = .5,	color = ~mypal(Ped_KA_Rate_Cat),
				  popup = paste("Tract ", dat@data$Tract,"<br>",
						"Index Category", dat@data$Index_Cat,"<br>",
						"Pedestrian Fatal & Severe Injury Rate", round(dat@data$Ped_KA_Rate,1),"<br>",
						"All pedestrian Injury Rate", round(dat@data$Ped_KABCO_Rate,1),"<br>",
						"Poverty %", round(dat@data$Poverty_Prop,3)*100,"<br>",
						"BIPOC %", round(dat@data$Non_White_Prop,3)*100,"<br>",
						"Non-Drive Commute %", round(dat@data$Non_Drive_Commute_Prop,3)*100,"<br>",
						"Arterial Vmt Density", round(dat@data$Vmt_All_Arterial_Density*1e6,0),"<br>",
						"Zero Vehicle Households %", round(dat@data$Vehicle_0_Prop,3)*100,"<br>",
						"Population", dat@data$Population)) %>%
	  addLegend("bottomright",  pal = mypal, values = dat@data$Ped_KA_Rate_Cat,title = "Fatal and Severe Injury Rate",    opacity = 1)

	#Save file
	saveWidget(Map, file="//wpdotfill09/R_VMP3_USERS/tdb069/Crash Analysis/SPR 841/Reports/Dynamic Maps/Ped_KA_Rate_Cat_2014-2018.html", selfcontained = T)

	Tracts.. <- assignLoad("//wpdotfill09/R_VMP3_USERS/tdb069/Crash Analysis/SPR 841/Data/Social Vulnerability Index/SVI_2014-2018.RData")

	Quantile_Summary.. <- Tracts.. %>% group_by(Index_Cat) %>% summarize(Ped_KABCO_Median = median(Ped_KABCO),Ped_KA_Median = median(Ped_KA))

	#Join to tracts
	Tracts.. <- left_join(Tracts.., Quantile_Summary.., by = c("Index_Cat"))
	Tracts..  <- Tracts.. %>%
		mutate(Ped_KA_Qnt = ifelse(Ped_KA <= Ped_KA_Median, "Low","High"),
		Ped_KABCO_Qnt = ifelse(Ped_KABCO <= Ped_KABCO_Median, "Low","High"))
	#Sumamrise
	x <- Tracts.. %>% group_by(Index_Cat, Ped_KA_Qnt) %>% summarise(Ped_KA = sum(Ped_KA), Ped_KABCO = sum(Ped_KABCO), Vmt_All_Arterial_Density = mean(Vmt_All_Arterial_Density), Transit_Stops = mean(Mean_Transit_Stops),
		Tracts = length(Tract), Population = sum(Population), Bipoc_Prop = mean(Bipoc_Prop), Poverty_Prop = mean(Poverty_Prop)) %>% mutate(Ped_KA_Rate = (Ped_KA * 100000) / Population,Ped_KABCO_Rate = (Ped_KABCO * 100000) / Population)

	x =
	sum(filter(Tracts.., Index_Cat =="High" & Ped_KA_Qnt =="High")$Ped_KA)
	sum(Tracts..$Ped_KA)
	sum(filter(Tracts.., Index_Cat =="High" & Ped_KA_Qnt =="High")$Ped_KA)	/
	sum(Tracts..$Ped_KA)

	sum(filter(Tracts.., Index_Cat =="High" & Ped_KABCO_Qnt =="High")$Ped_KABCO)	/
	sum(Tracts..$Ped_KABCO)

	nrow(filter(Tracts.., Index_Cat =="High" & Ped_KABCO_Qnt =="High"))

	#Ped injury rate map
	###########################
	dat <- Load_Tracts_10_Sp
	#Join summary data
	dat@data <- 	left_join(dat@data,Tracts.., by = "Tract") %>% mutate(Non_Drive_Commute_Prop = Jtw_Transit_Prop + Jtw_Walk_Prop + Jtw_Bike_Prop, Ped_KA
		Ped_KA_Qnt_Index = paste(Index_Cat, Ped_KA_Qnt, sep="-"))
	dat@data$Ped_KA_Qnt_Index <- factor(dat@data$Ped_KA_Qnt_Index, levels = rev(c("High-High","High-Low","Moderate-High","Moderate-Low","Low-High","Low-Low","Lowest-High","Lowest-Low")))

	#Transform
	dat <- spTransform(		dat, CRS(Projection_LatLong))
	dat <- dat[!(is.na(dat@data$Population)),]
#	dat <- dat[!(is.infinite(dat@data$Ped_KA_Rate)) ,]
	Breaks. <- c(0,7,quantile(dat@data$Ped_KA_Rate, prob = seq(0, 1, length = 21), type = 5, na.rm=T)[11:21])
	Bin_Labels. <- label_Bins(round(Breaks.,0))
	#dat$Ped_KA_Rate_Cat <- cut(dat$Ped_KA_Rate, breaks = Breaks., labels = Bin_Labels.)
	rc1 <- colorRampPalette(colors = c("white","blue", "red"), space = "Lab")(10)
	#mypal <- colorFactor("Spectral", domain = dat@data$Ped_KA_Rate_Cat, na.color = "grey")
	mypal <- colorFactor(rc1, domain = dat@data$Ped_KA_Qnt_Index, na.color = "grey")
	#mypal <- colorNumeric("RdYlBu", domain = 1:12, na.color = "grey")
	#mypal <- colorNumeric(rc1, domain = dat@data$Ped_KA_Rate, na.color =  "grey")
	Map <- leaflet() %>% addTiles() %>%
	  addPolygons(data=dat, smoothFactor = 0.2, fillOpacity = .5,	color = ~mypal(Ped_KA_Qnt_Index),
				  popup = paste("Tract ", dat@data$Tract,"<br>",
						"Index Category", dat@data$Index_Cat,"<br>",
						"Median Category", dat@data$PEd_KA_Qnt,"<br>",
						"Pedestrian Fatal & Severe Injury", round(dat@data$Ped_KA),"<br>",
						"Pedestrian Injury", round(dat@data$Ped_KABCO),"<br>",
						#"All pedestrian Injury Rate", round(dat@data$Ped_KABCO_Rate,1),"<br>",
						"Poverty %", round(dat@data$Poverty_Prop,3)*100,"<br>",
						"BIPOC %", round(dat@data$Bipoc_Prop,3)*100,"<br>",
						"Non-Drive Commute %", round(dat@data$Non_Drive_Commute_Prop,3)*100,"<br>",
						"Arterial Vmt Density", round(dat@data$Vmt_All_Arterial_Density*1e6,0),"<br>",
						"Zero Vehicle Households %", round(dat@data$Vehicle_0_Prop,3)*100,"<br>",
						"Population", dat@data$Population)) %>%
	  addLegend("bottomright",  pal = mypal, values = dat@data$Ped_KA_Qnt_Index,title = "Concentration Index",    opacity = 1)

	#Save file
	saveWidget(Map, file="//wpdotfill09/R_VMP3_USERS/tdb069/Crash Analysis/SPR 841/Reports/Dynamic Maps/Index_Cat_With_Qnt_2014-2018.html", selfcontained = T)


\eqn{\sqrt{x}} % Comment


#'---
#'title: "Score models on test set"
#'author: "Denis A. Engemann, Kamalaker Dadi"
#'date: "7/18/2020"
#'output:
#'    html_document:
#'        code_folding:
#'            hide
#'    md_document:
#'        variant:
#'            markdown_github
#'---
#'
#' First execrise: Load all relevant data:
#' 1. Predictions for all targets from brain
#' 2. ... from sociodemographics
#' 3. ... from sociodemographics + brain

library(data.table)
library(future.apply)
source("../utils.r")
plan(multiprocess, workers = 4)
par_sapply <- function(...) future_sapply(..., future.seed = T)

base_path <- file.path(
    "inputs",
    'post_predictive_analysis_class_%s.csv')

get_inputs <- function(fname, input_type)
{
  DT <- fread(fname)
  # kick out unneccesary variables and average over folds (shuffle splits..).
  DT <- DT[,
    .(predicted = mean(predicted), true = true[1]),
    by = .(eid, target, evaluation)]
  DT[, `:=`(eid = factor(eid), input_type = input_type)]
  DT
}

DT <- rbind(
  get_inputs(sprintf(base_path, "non_imaging_fresh"), "social"),
  get_inputs(sprintf(base_path, "imaging_non_imaging"), "social_brain")
)

DT_brain <- fread(sprintf(base_path, "full_mri"))

DT_brain <- DT_brain[,
  .(predicted = mean(predicted), true = true[1]),
  by = .(eid, target, evaluation)]

#' Now let's set a few goals.
#'
#' What?
#' 1. brain vs non-brain models within each group of socio-demographics
#' 2. brain models vs chance.
#'
#' How?
#' - out-of-sample permutation of r2 value for brain models
#' - out-of-sample permutation of difference between 2 models
#' - same for effect-sizes using bootstrap
#'
#' Output?
#' - tables

roc_auc_score <- function(predicted, true) {
  n1 <- sum(!true)
  n2 <- sum(true)
  U  <- sum(rank(predicted)[!true]) - n1 * (n1 + 1) / 2
  return(1 - U / n1 / n2)
}

DT_inf_brain <- DT_brain[evaluation == "Generalization",
  {
    dat <- na.omit(data.frame(predicted = predicted, true = true))
    perms <- 1:10000

    # permutations
    t_obs <- roc_auc_score(true = dat$true, predicted = dat$predicted)
    perm_auc <- par_sapply(perms, function(perm){
      set.seed(perm)
      roc_auc_score(true = dat$true,
                    predicted = sample(dat$predicted, replace = F))
    })
    t_perm <- mean(perm_auc)
    p_val <- max(mean(t_obs < perm_auc), 1 / length(perms))

    # bootstrap
    boot_r2s <- par_sapply(perms, function(perm){
      set.seed(perm)
      inds <- sample.int(nrow(dat), replace = T)
      roc_auc_score(true = dat$true[inds] ,
                    predicted = dat$predicted[inds])
    })

    .(t_obs = t_obs, t_perm  = t_perm, p_val = p_val,
      CI_low = quantile(boot_r2s, 0.025),
      CI_hi = quantile(boot_r2s, 0.975))
  }, by = .(target)]

fwrite(DT_inf_brain, "brain_inference_class.csv")
knitr::kable(DT_inf_brain)
tex_out_brain <- knitr::kable(DT_inf_brain[,-c("t_perm")], format = "latex")
writeLines(tex_out_brain, "brain_inference_class.tex")

DT_aucs <- DT[evaluation == "Generalization",
    {
      dat1 <- data.frame(
      predicted_soc = .SD[input_type == "social", predicted],
      true_soc = .SD[input_type == "social", true],
      eid = .SD[input_type == "social", eid]
      )
      dat2 <- data.frame(
        predicted_soc_b = .SD[input_type == "social_brain", predicted],
        true_soc_b = .SD[input_type == "social_brain", true],
        eid = .SD[input_type == "social_brain", eid]
      )
      dat <- na.omit(merge(dat1, dat2, by = "eid"))

      out <- data.frame(
        auc_score = c(
          roc_auc_score(
            true = dat$true_soc_b, predicted = dat$predicted_soc_b),
          roc_auc_score(
            true = dat$true_soc, predicted = dat$predicted_soc)),
        imaging = c("yes", "no")
      )
      out
    },
  .(target)]

fwrite(DT_aucs, "./gen_observed_aucs.csv")

DT_inf_diff <- DT[evaluation == "Generalization",
  {
    dat1 <- data.frame(
      predicted_soc = .SD[input_type == "social", predicted],
      true_soc = .SD[input_type == "social", true],
      eid = .SD[input_type == "social", eid]
    )
    dat2 <- data.frame(
      predicted_soc_b = .SD[input_type == "social_brain", predicted],
      true_soc_b = .SD[input_type == "social_brain", true],
      eid = .SD[input_type == "social_brain", eid]
    )
    dat <- na.omit(merge(dat1, dat2, by = "eid"))

    # # permutations
    t_obs <- `-`(
      roc_auc_score(true = dat$true_soc_b, predicted = dat$predicted_soc_b),
      roc_auc_score(true = dat$true_soc, predicted = dat$predicted_soc)
    )
    perms <- 1:10000
    perm_auc <- par_sapply(perms, function(perm){
      set.seed(perm)

      cand <- cbind(dat$predicted_soc,
                    dat$predicted_soc_b)
      # flip columns in each row
      permuted <- do.call(rbind,
        lapply(
          1:nrow(cand),
          function(ind){
            sample(cand[ind, c(1, 2)], replace = F)
          })
      )

      auc_soc <- roc_auc_score(true = dat$true_soc,
                               predicted = permuted[,1])
      auc_soc_b <- roc_auc_score(true = dat$true_soc_b,
                                 predicted = permuted[,2])
      auc_soc_b - auc_soc
    })
    t_perm <- mean(perm_auc)
    p_val <- max(mean(abs(t_obs) < abs(perm_auc)), 1 / length(perms))

    # bootstrap
    boot_r2s <- par_sapply(perms, function(perm){
      set.seed(perm)
      inds <- sample.int(nrow(dat), replace = T)

      auc_soc_b <- roc_auc_score(true = dat$true_soc_b[inds],
                                 predicted = dat$predicted_soc_b[inds])

      auc_soc <- roc_auc_score(true = dat$true_soc[inds],
                               predicted = dat$predicted_soc[inds])
      auc_soc_b - auc_soc

    })

    .(t_obs = t_obs, t_perm  = t_perm, p_val = p_val,
      CI_low = quantile(boot_r2s, 0.025),
      CI_hi = quantile(boot_r2s, 0.975))
  }, by = .(target)]

setorder(DT_inf_diff, target)
fwrite(DT_inf_diff, "paired_diff_inference_class.csv")
knitr::kable(DT_inf_diff)
tex_out_diff <- knitr::kable(DT_inf_diff[,-c("t_perm")], format = "latex")
writeLines(tex_out_diff, "paired_diff_inference_class.tex")

#'Small concern: Numbers in stats look slightly higher
#'Is it because we average before computing AUC. Let's compute it fold-wise

DT_brain2 <- fread(sprintf(base_path, "full_mri"))
DT_brain_auc <- DT_brain2[
  evaluation == "Generalization",
  {
     dat <- na.omit(data.frame(true = true,
                               predicted = predicted))
     auc =  roc_auc_score(true = dat$true, predicted = dat$predicted)
    .(auc = auc)
  },
  by = .(target, fold)]

knitr::kable(DT_brain_auc[,.(auc = mean(auc)), .(target)])

#' That seems to be the case, yes!


# Ensemble gene noise for the COVID19

library(edgeR)
library(gamlss)
library(gprofiler2)
library(parallel)

################################################################################
# gamlss function to estimate ensemble gene noise from RNA-seq counts
NBI_ens_noise <- function(counts, ensemble, geneL, min.genes.n = 10, cores = 4) {

  res <- mclapply(seq_along(ensemble), function(i) {
    cat(i, "\r")
    # From RNA-seq select genes constituting gene ensemble
    idx <- rownames(counts) %in% ensemble[[i]]
    dat <- counts[idx,]
    dat <- merge(geneL, dat, by = 'row.names')
    # ofs - ofset log(transcript length)
    ofs <- log(dat$length)
    dat <- dat[,-c(1:3)]

    if(length(ofs) >=  min.genes.n) {

      sink(file="/dev/null")
      # Gamlss estimation of ensemble gene noise from RNA counts using Negative Binomial model (NBI) and ofset - log(transcript length)
      # Try different Gamlss algorithms the Cole and Green (CG) and the Rigby and Stasinopoulos (RS) if CG fails
      res <- tryCatch(
        apply(dat, 2, function(x) exp(gamlss(x ~ offset(ofs),
          data = na.omit(data.frame(x=x, ofs=ofs)), family = NBI, method = CG(), n.cyc = 100)$sigma.coefficients) ),
      warning = function(w) NULL, error = function(e) NULL)

      if(is.null(res)) {
        res <- tryCatch(
          apply(dat, 2, function(x) exp(gamlss(x ~ offset(ofs),
            data = na.omit(data.frame(x=x, ofs=ofs)), family = NBI, method = RS(), n.cyc = 100)$sigma.coefficients) ),
        warning = function(w) NULL, error = function(e) NULL)
      }

      sink()

    } else { res <- NULL }
    res
  }, mc.cores = cores)

  names(res) <- names(ensemble)
  res <- do.call(rbind, res)

}

###############################################################################
# Read CORUM and KEGG gene ensembles annotations
setwd("/media/yuri/Data/home1/GNI_data/infection/DataSciRep/")
load("org.Hs.core_paths.Rdat")

names(corum_core) <- paste0("complex:", names(corum_core))
names(kegg_path) <- paste0("kegg:", names(kegg_path))

ENS <- c(corum_core, kegg_path)
ENS <- ENS[sapply(ENS, length) >= 5]

rm(corum_core, kegg_path, org.Hs)

ENSG_to_gene <- gconvert(rownames(trxL), organism = "hsapiens", target = c("ENTREZGENE"))[,c('input', 'target')]
ENSG_to_gene <- ENSG_to_gene[ENSG_to_gene$target != "nan",]
ENSG_to_gene <- ENSG_to_gene[!duplicated(ENSG_to_gene$target), ]

trxL <- merge(trxL, ENSG_to_gene, by.x = 'row.names', by.y = 'input')
rownames(trxL) <- trxL$target
trxL <- trxL[,-c(1,4)]

################################################################################
# Read COVID19 RNA-seq counts
setwd("/media/yuri/Data/home1/GNI_data/infection/ResultsSciRep")
load("COVID19_RNAseq.Rdat")

rm(samples, samples_pData)

################################################################################
# Calculate ensemble gene noise
COVID_ENS_noise <- NBI_ens_noise(DGE_RNAcounts$counts, ensemble = ENS, geneL = trxL, min.genes.n = 5, cores = 4)

################################################################################
# Calculate significant changes in ensemble gene noise for the COVID19 mild/severe patients
COVID_ENS_noise_sig <- mclapply(seq(nrow(COVID_ENS_noise)), function(i) {

  cat(i, "\r")

  y = c(COVID_ENS_noise[i,])
  x = DGE_RNAcounts$samples$stage
  Sex = DGE_RNAcounts$samples$Sex
  age = DGE_RNAcounts$samples$age

  dat <- data.frame(y = y, x = x, Sex = Sex, age = age)
  dat$age[is.na(dat$age)] <- median(dat$age[!is.na(dat$age)])
  # boxplot(y ~ x, dat)

  sink("/dev/null")
  # gamlss model accounting for Sex and age as random effects and COVID19 mild vs sever as fixed effect factor
  # Try different Gamlss algorithms the Cole and Green (CG) and the Rigby and Stasinopoulos (RS) if CG fails
  m0 <-  tryCatch(
    gamlss::gamlss(y ~ x +  re(random = ~ 1|Sex) + re(random = ~ 1|pb(age)), data = dat, n.cyc = 1000),
    error = function(e) NULL, warning = function(w) NULL)

  if(is.null(m0)) {
    m0 <-  tryCatch(
      gamlss::gamlss(y ~ x +  re(random = ~ 1|Sex) + re(random = ~ 1|pb(age)), data = dat, method = CG(), n.cyc = 1000),
      error = function(e) NULL, warning = function(w) NULL)
  }
  # If both RS and CG fail drop random effects
  if(is.null(m0)) {
    m0 <-  tryCatch(
      gamlss::gamlss(y ~ x, data = dat, n.cyc = 1000),
      error = function(e) NULL, warning = function(w) NULL)
  }

  if(!is.null(m0)) {
    m0s <-  summary(m0, method = "vcov", save = TRUE)
    res <-  t(as.data.frame(m0s$coef.table[2,3:4]))
    colnames(res) <- c("t", "p")
    rownames(res) <- NULL
  } else {
    res <- data.frame(t = NA, p = NA)
  }

  sink()

  res

}, mc.cores = 6)

COVID_ENS_noise_sig <- do.call(rbind, COVID_ENS_noise_sig)
rownames(COVID_ENS_noise_sig) <- rownames(COVID_ENS_noise)
COVID_ENS_noise_sig <- as.data.frame(COVID_ENS_noise_sig)

setwd("/media/yuri/Data/home1/GNI_data/infection/ResultsSciRep")
save.image("COVID19_Ensemble_noise.RDat")

################################################################################


library(shiny)
library(data.table)
library(plotly)
library(ggplot2)
library(dplyr)
library(timetk)
library(tidyquant)
library(tidyverse)
library(dplyr)
library(quantmod)
library(reticulate)
library(shinycssloaders)
library(Rtsne)
library(shinybusy)
library(corrplot)
library(DT)
library(shinyjs)

use_virtualenv("r-reticulate")
sklearn <- import("sklearn")
#Source python scripts
source_python('python_scripts/find_cointegrated_pairs.py')
base_data <- readRDS("data/crypto.RDS")
source("r_functions/pairs_sim3.R")

wide_data <- base_data %>%
  select(date,symbol,close) %>%
  pivot_wider(names_from = symbol, values_from = close)
wide_data <- wide_data[ , colSums(is.na(wide_data)) == 0]

base_data <- subset(base_data, symbol %in% colnames(wide_data))

crypto_names <- unique(base_data$symbol)

ui <- fluidPage(
useShinyjs(),
navbarPage("Stock Analysis",
  # Sidebar layout with a input and output definitions ----
  navbarMenu("Modeling",
             tabPanel("Heat Map",
  #TSNE Page ----
  sidebarLayout(
    sidebarPanel(
      br(),
      sliderInput("TSNE_daterange",
                  "Date Range:",
                  min = as.Date("2000-01-01","%Y-%m-%d"),
                  max = as.Date(Sys.Date(),"%Y-%m-%d"),
                  value=as.Date(c(Sys.Date()-2*365,Sys.Date())),
                  timeFormat="%Y-%m-%d"),
      br(),
      sliderInput("perplexity","TSNE Perplexity",0,100,30),
      br()
    ),
    mainPanel(
      fluidRow(
        fluidRow(
          withSpinner(
            column(6,
                   plotOutput("coint_heatmap")
            )
          ),
          column(6,
                 DT::dataTableOutput("pairs_table"),
          )
        )
      )
    )
  )
  ),
  tabPanel("Simulation",
           sidebarLayout(

             sidebarPanel(
               br(),
               fluidRow(
                 column(6,
                        dateInput("pairs_start_date","Start Date",value = Sys.Date() - 2 * 365)
                 ),
                 column(6,
                        numericInput("pairs_start_cash","Starting Cash",1000)
                 )
               ),
               br(),
               fluidRow(
                 column(6,
                        numericInput("pairs_lookback_window","Lookback Window",30)
                 ),
                 column(6,
                        numericInput("pairs_z_window","Z Window",30)
                 )
               ),
               br(),
               fluidRow(
                 column(6,
                        # sliderInput("pairs_n_pairs","Number of Pairs",1,20,3)
                        fluidRow(
                          column(6,
                                 actionButton("pairs_add","Add")
                          ),
                          column(6,
                                 actionButton("pairs_delete","Delete")
                          )
                        )
                 ),
                 column(6,align = "center",
                        actionButton("pairs_start","Start Simulation")
                 )

               ),
               br(),
               fluidRow(
                 column(12,align = "center",
                        actionButton("import_pairs","Import Pairs")
                 )
               ),
               fluidRow(
                 column(6,
                        uiOutput("pairs_pairs_1")
                 ),
                 column(6,
                        uiOutput("pairs_pairs_2")
                 ),
               )
             ),
             mainPanel(
               fluidRow(
                 column(12,
                        plotlyOutput("pairs_simulation_output"),
                        plotlyOutput("pairs_simulation_weight_output"),
                        )
               )
             )
           )
           )
           ),
  tabPanel("Price",
           sidebarLayout(
             sidebarPanel(),
             mainPanel(
               plotlyOutput("crypto_prices")
             )
           )
           )
  )
)

server <- function(input, output) {

  #TSNE Returns -----
  #story generated TSNE data
  TSNE_data <- reactiveVal()
  selected_pairs <- reactiveVal()

  output$coint_heatmap <- renderPlot({

    log_returns <- base_data %>%
      select(date,symbol,close) %>%
      group_by(symbol) %>%                         # We are grouping the stocks by the stock symbol
      tq_transmute(select = close,
                   mutate_fun = periodReturn,
                   period = 'daily',
                   type = "log",
                   col_rename = 'returns')%>%
      pivot_wider(names_from = symbol, values_from = returns)

    log_returns <- subset(log_returns,date >= input$TSNE_daterange[1] & date <= input$TSNE_daterange[2])
    log_returns <-log_returns[ , colSums(is.na(log_returns)) == 0]

    results <- find_cointegrated_pairs(log_returns[-1])

    pairs <- (results[[3]])
    pairs <- sapply(pairs, paste, collapse=",")
    pairs <- paste(pairs,collapse="\n")

    output$pairs_table <- DT::renderDataTable({

      pairs <- read.csv(text=pairs,header = F)
      colnames(pairs) <- c("pair1","pair2")
      selected_pairs(pairs)

      data <- data.frame(
        pair1 = pairs[1],
        pair2 = pairs[2],
        add_sim = shinyInput(actionButton, nrow(pairs), 'button_', label = "Add", onclick = 'Shiny.onInputChange(\"select_button\",  this.id)' ),
        stringsAsFactors = FALSE
      )

      data
    },server = FALSE, escape = FALSE, selection = 'none')

    p_vals <- as.matrix(results[[2]])
    colnames(p_vals) <- names(log_returns[-1])
    rownames(p_vals) <- names(log_returns[-1])

    p_vals[p_vals > 0.05] <- 1

    p_vals <- 1 - p_vals

    corrplot(p_vals,type = "upper",method = "color")

  })

  #Pairs Simulation ---
  output$pairs_simulation_output <- renderPlotly({
    req(simulation_outcome())

    pairs_outcome <- simulation_outcome()[[1]]

    plot1 <- plot_ly(pairs_outcome, x = ~date, y = ~total_value, type = 'scatter', mode = 'lines',colors = "Set1")
  })

  output$pairs_simulation_weight_output <-  renderPlotly({
    req(simulation_outcome())

    pairs_outcome <- simulation_outcome()[[1]] %>%
      select(-total_value)

    pairs_outcome_scaled <- pairs_outcome %>%
      select(-date)
    pairs_outcome_scaled <- pairs_outcome_scaled / rowSums(pairs_outcome_scaled)
    pairs_outcome_scaled$date <- pairs_outcome$date
    pairs_outcome_scaled <- gather(pairs_outcome_scaled, "symbol", "price", -date)
    pairs_outcome_scaled <- na_if(pairs_outcome_scaled,0) %>%
      drop_na()

    plot1 <- plot_ly(pairs_outcome_scaled, x = ~date, y = ~price,color = ~symbol, type = 'scatter',colors = "Set1")

    plot1
  })

  shinyInput <- function(FUN, len, id, ...) {
    inputs <- character(len)
    for (i in seq_len(len)) {
      inputs[i] <- as.character(FUN(paste0(id, i), ...))
    }
    inputs
  }

  observeEvent(input$select_button, {
    selectedRow <- as.numeric(strsplit(input$select_button, "_")[[1]][2])

    pair_data <- selected_pairs()[selectedRow,]

    add_pairs(pair_data)
  })

  simulation_outcome <- reactiveVal(NULL)
  n_pairs <- reactiveVal(0)
  pairs <- reactiveVal(NULL)

  observeEvent(input$pairs_add,{
    n_pairs(n_pairs() + 1)
    pair <- data.frame(
      pair1 = "",
      pair2 = "",
      stringsAsFactors = F
    )
    pairs(
      rbind(pairs(),pair)
    )
    })

  observeEvent(input$pairs_delete,{
    n_pairs(n_pairs() - 1)

    data <- pairs()

    data <- data[-nrow(data),]
    pairs(data)
  })

  output$pairs_pairs_1 <- renderUI({
    if (n_pairs() <= 0){
      return()
    }

    pair_data <- pairs() %>%
      select(pair1)

    numIndividuals <- as.integer(n_pairs())
    lapply(1:numIndividuals, function(i) {
      selectizeInput(paste0("pair1_",i),"",crypto_names,selected = as.character(pair_data[i,]))
    })
  })

  output$pairs_pairs_2 <- renderUI({
    if (n_pairs() <= 0){
      return()
    }

    pair_data <- pairs() %>%
      select(pair2)

    names_data <- data.frame(
      crypto_names = crypto_names,
      pair2 = gsub(".*/ ","",crypto_names)
    )

    pair_data <- merge(names_data,pair_data)

    numIndividuals <- as.integer(n_pairs())
    lapply(1:numIndividuals, function(i) {
      selectizeInput(paste0("pair2_",i),"",crypto_names,selected = pair_data$crypto_names[i])
    })
  })

  to_add_pairs <- reactiveVal()
  add_pairs <- function(pairs){

    pair1 <- pairs[1]
    pair2 <- pairs[2]

    data <- data.frame(
      pair1 = pair1,
      pair2 = pair2,
      stringsAsFactors = F
    )

    to_add_pairs(rbind(
      to_add_pairs(),data
    ))

  }

  observeEvent(input$import_pairs,{
    req(to_add_pairs())
    n <- nrow(to_add_pairs())
    n_pairs(n_pairs()+n)

    pairs(
      rbind(pairs(),to_add_pairs())
    )

    to_add_pairs(NULL)

  })

  observeEvent(input$pairs_start, {
    show_modal_spinner()
    #Build pairs dataframes

    num <- as.integer(n_pairs())

    pair1 <- sapply(1:num, function(i) { input[[paste0("pair1_",i)]] })
    pair1 <-  gsub(".*/ ","",pair1)

    #Set up pairs
    pair2 <- sapply(1:num, function(i) { input[[paste0("pair2_",i)]] })
    pair2 <-  gsub(".*/ ","",pair2)

    pair_data <- data.frame(
      pair1  = pair1,
      pair2 = pair2,
      stringsAsFactors = F
    )
    pair_data$p1 <- F
    pair_data$p2 <- F

    meta_data <- base_data %>%
      select(date,symbol,close) %>%
      rename(adjusted = close)

    outcome <- pairs_simulation(pair_data,meta_data,input$pairs_start_date,input$pairs_lookback_window,input$pairs_z_window,input$pairs_start_cash)
    remove_modal_spinner()

    simulation_outcome(outcome)

  })

  #Prices Pages----

  output$crypto_prices <- renderPlotly({
    p <- plot_ly(base_data, x = ~date, y = ~close, color = ~symbol)
  })

}

shinyApp(ui, server)


library(ggplot2)

ld <- listdown(package = "ggplot2")

iris_cc <- list(
    iris = iris,
     Sepal.Length = list(
          Sepal.Width =
            ggplot(iris, aes(x = Sepal.Length, y = Sepal.Width)) +
              geom_point(),
          Petal.Length =
            ggplot(iris, aes(x = Sepal.Length, y = Sepal.Width)) +
              geom_point(),
     Colored = list(
          Sepal.Width =
            ggplot(iris, aes(x = Sepal.Length, y = Sepal.Width,
                   color = Species)) +
              geom_point(),
          Petal.Length =
            ggplot(iris, aes(x = Sepal.Length, y = Petal.Length,
                   color = Species)) +
              geom_point())))

header <- ld_rmarkdown_header("Iris", author = "Some Dude", date = "2020")

iris_page <- ld_bundle_doc(iris_cc, header, ld)

anscombe_cc <- list(
  Linear =
    ggplot(anscombe, aes(x = x1, y = y1)) +
      geom_point() +
      theme_bw(),
  `Non Linear` =
    ggplot(anscombe, aes(x = x2, y = y2)) +
      geom_point() +
      theme_bw(),
  `Outlier Vertical`=
    ggplot(anscombe, aes(x = x3, y = y3)) +
      geom_point() +
      theme_bw(),
  `Outlier Horizontal` =
    ggplot(anscombe, aes(x = x4, y = y4)) +
      geom_point() +
      theme_bw())

header <- ld_rmarkdown_header("Anscombe", author = "Anscombe", date = "2020")

anscombe_page <- ld_bundle_doc(anscombe_cc, header, ld)

pages <- list(Anscombe = anscombe_page, Iris = iris_page)

test_that("Site can be built.", {
  site_yaml <-
    ld_site_yaml(
      "Test Site",
      tab_name = names(pages),
      rmd_name = c("index.rmd", "iris.rmd"))

  site_path <- ld_build_html_site(
    pages,
    site_yaml,
    view = TRUE,
    quiet = TRUE)

  expect_equal(basename(site_path), "index.html")
})


#' Data Generation From DDM Parameters
#'
#' A wrapper around the function \code{\link{drift_simuls}} which simulates as many data sets as
#' data frames with parameters are provided in a list. This is a convenience function and
#' the function \code{\link{drift_simuls}} can also be used directly on just one set on parameters.
#' @export
#' @param parameter_data_frames A list of data frames that contain DDM parameters in
#' the format returned by the 'makeFakeParams' function: 1 column per parameter
#' and as many rows as subjects. Can also be applied to just one data frame!
#' The rows can be named (in a data frame, in tibbles it is deprecated).
#' @return Returns a list of Data Frames with simulated data. Or alternatively, a list of 1
#' data frame.
#' @examples
#'
#' parameters_1 #parameters extracted from a fitting procedure
#' parameters_2 #simulated parameters
#'
#' sims <- simulDat(list(parameters_1, parameters_2))
#'
#' sim_1 <- sims[[1]]
#' sim_2 <- sims[[2]]
simulDat <- function(..., n = 1000){

    x <- list(...)

    simul <- function(params, .samples = n){
        sims <- split(params, seq(nrow(params))) %>%
            map(., ~drift_simuls(.x, samples = .samples))

        names(sims) <- rownames(params)

        rts <- sims %>% map('rt') %>% data.table::melt()

        cor <- sims %>% map('response') %>% data.table::melt()

        sims <- data.frame('suj'=as.factor(rts$L1), 'rt'=rts$value, 'cor'= as.factor(cor$value), 'cond'='Sim')

        onsiders <- sims %>%
            group_by(suj) %>% summarise(mean =
                                            mean(as.numeric(as.character(cor)))) %>%
            filter(mean == 0 | mean == 1) %>%
            rownames() %>% length()

        if(onsiders > 0){
            warning('\n\nOne or more subjects in the provided data only features one type of responses
(only 0s or 1s). This data set will not be able to be processed by "experimental_data_processing"
and cannot be fit.\n')
        }

        list(params=params, data=sims)
    }

    map(x, simul)

}


library(readr)
library(data.table)
# @param
# actual is vector, pred is data.frame
# mlogloss(actual,pred)
mlogloss <- function(actual,pred){
	actual <- as.integer(as.factor(actual))
	probs <- rep(0,length(actual))
	for(i in 1:length(actual)) { probs[i] <- pred[i,actual[i]]}
	probs <- as.numeric(probs)
	probs[which(probs>1-1e-15)] <- 1-1e-15
	probs[which(probs<1e-15)] <- 1e-15
	return(-(1/length(actual))*sum(log(probs)))
}

path <- "../Data/"
raw_train <- fread(paste0(path,"train.csv"))
raw_train <- as.data.frame(raw_train)
trainId <- raw_train$id
#
xgb_train <- fread(paste0(path,"xgb_retrain.csv"))
xgb_train <- as.data.frame(xgb_train)
xgb_train$id <- NULL
colnames(xgb_train) <- gsub('Class_','',colnames(xgb_train))
colnames(xgb_train) <- paste0('xgb_',colnames(xgb_train))
rf_train <- fread(paste0(path,"rf_retrain.csv"))
rf_train <- as.data.frame(rf_train)
rf_train$id <- NULL
colnames(rf_train) <- gsub('Class_','',colnames(rf_train))
colnames(rf_train) <- paste0('rf_',colnames(rf_train))
ET_train <- fread(paste0(path,"extraTree_retrain.csv"))
ET_train <- as.data.frame(ET_train)
ET_train$id <- NULL
colnames(ET_train) <- gsub('Class_','',colnames(ET_train))
colnames(ET_train) <- paste0('ET_',colnames(ET_train))
svm_train <- fread(paste0(path,"svm_retrain.csv"))
svm_train <- as.data.frame(svm_train)
svm_train$id <- NULL
colnames(svm_train) <- gsub('Class_','',colnames(svm_train))
colnames(svm_train) <- paste0('svm_',colnames(svm_train))
NN4_train <- fread(paste0(path,"kerasNN4_retrain.csv"))
NN4_train <- as.data.frame(NN4_train)
NN4_train$id <- NULL
colnames(NN4_train) <- gsub('Class_','',colnames(NN4_train))
colnames(NN4_train) <- paste0('kerasNN4_',colnames(NN4_train))
NN3_train <- fread(paste0(path,"kerasNN3_retrain.csv"))
NN3_train <- as.data.frame(NN3_train)
NN3_train$id <- NULL
colnames(NN3_train) <- gsub('Class_','',colnames(NN3_train))
colnames(NN3_train) <- paste0('kerasNN3_',colnames(NN3_train))
NN2_train <- fread(paste0(path,"kerasNN2_retrain.csv"))
NN2_train <- as.data.frame(NN2_train)
NN2_train$id <- NULL
colnames(NN2_train) <- gsub('Class_','',colnames(NN2_train))
colnames(NN2_train) <- paste0('kerasNN2_',colnames(NN2_train))
knn1_train <- fread(paste0(path,"knn1_retrain.csv"))
knn1_train <- as.data.frame(knn1_train)
knn1_train$id <- NULL
colnames(knn1_train) <- gsub('Class_','',colnames(knn1_train))
colnames(knn1_train) <- paste0('knn1_',colnames(knn1_train))
knn2_train <- fread(paste0(path,"knn2_retrain.csv"))
knn2_train <- as.data.frame(knn2_train)
knn2_train$id <- NULL
colnames(knn2_train) <- gsub('Class_','',colnames(knn2_train))
colnames(knn2_train) <- paste0('knn2_',colnames(knn2_train))
knn3_train <- fread(paste0(path,"knn3_retrain.csv"))
knn3_train <- as.data.frame(knn3_train)
knn3_train$id <- NULL
colnames(knn3_train) <- gsub('Class_','',colnames(knn3_train))
colnames(knn3_train) <- paste0('knn3_',colnames(knn3_train))
knn4_train <- fread(paste0(path,"knn4_retrain.csv"))
knn4_train <- as.data.frame(knn4_train)
knn4_train$id <- NULL
colnames(knn4_train) <- gsub('Class_','',colnames(knn4_train))
colnames(knn4_train) <- paste0('knn4_',colnames(knn4_train))
knn5_train <- fread(paste0(path,"knn5_retrain.csv"))
knn5_train <- as.data.frame(knn5_train)
knn5_train$id <- NULL
colnames(knn5_train) <- gsub('Class_','',colnames(knn5_train))
colnames(knn5_train) <- paste0('knn5_',colnames(knn5_train))
knn6_train <- fread(paste0(path,"knn6_retrain.csv"))
knn6_train <- as.data.frame(knn6_train)
knn6_train$id <- NULL
colnames(knn6_train) <- gsub('Class_','',colnames(knn6_train))
colnames(knn6_train) <- paste0('knn6_',colnames(knn6_train))
knn7_train <- fread(paste0(path,"knn7_retrain.csv"))
knn7_train <- as.data.frame(knn7_train)
knn7_train$id <- NULL
colnames(knn7_train) <- gsub('Class_','',colnames(knn7_train))
colnames(knn7_train) <- paste0('knn7_',colnames(knn7_train))
knn8_train <- fread(paste0(path,"knn8_retrain.csv"))
knn8_train <- as.data.frame(knn8_train)
knn8_train$id <- NULL
colnames(knn8_train) <- gsub('Class_','',colnames(knn8_train))
colnames(knn8_train) <- paste0('knn8_',colnames(knn8_train))
knn9_train <- fread(paste0(path,"knn9_retrain.csv"))
knn9_train <- as.data.frame(knn9_train)
knn9_train$id <- NULL
colnames(knn9_train) <- gsub('Class_','',colnames(knn9_train))
colnames(knn9_train) <- paste0('knn9_',colnames(knn9_train))
knn10_train <- fread(paste0(path,"knn10_retrain.csv"))
knn10_train <- as.data.frame(knn10_train)
knn10_train$id <- NULL
colnames(knn10_train) <- gsub('Class_','',colnames(knn10_train))
colnames(knn10_train) <- paste0('knn10_',colnames(knn10_train))
knn11_train <- fread(paste0(path,"knn11_retrain.csv"))
knn11_train <- as.data.frame(knn11_train)
knn11_train$id <- NULL
colnames(knn11_train) <- gsub('Class_','',colnames(knn11_train))
colnames(knn11_train) <- paste0('knn11_',colnames(knn11_train))

# tfidf space
xgb_tfidf_train <- fread(paste0(path,"xgb_tfidf_retrain.csv"))
xgb_tfidf_train <- as.data.frame(xgb_tfidf_train)
xgb_tfidf_train$id <- NULL
colnames(xgb_tfidf_train) <- gsub('Class_','',colnames(xgb_tfidf_train))
colnames(xgb_tfidf_train) <- paste0('xgb_tfidf_',colnames(xgb_tfidf_train))
rf_tfidf_train <- fread(paste0(path,"rf_tfidf_retrain.csv"))
rf_tfidf_train <- as.data.frame(rf_tfidf_train)
rf_tfidf_train$id <- NULL
colnames(rf_tfidf_train) <- gsub('Class_','',colnames(rf_tfidf_train))
colnames(rf_tfidf_train) <- paste0('rf_tfidf_',colnames(rf_tfidf_train))
ET_tfidf_train <- fread(paste0(path,"extraTree_tfidf_retrain.csv"))
ET_tfidf_train <- as.data.frame(ET_tfidf_train)
ET_tfidf_train$id <- NULL
colnames(ET_tfidf_train) <- gsub('Class_','',colnames(ET_tfidf_train))
colnames(ET_tfidf_train) <- paste0('ET_tfidf_',colnames(ET_tfidf_train))
svm_tfidf_train <- fread(paste0(path,"svm_tfidf_retrain.csv"))
svm_tfidf_train <- as.data.frame(svm_tfidf_train)
svm_tfidf_train$id <- NULL
colnames(svm_tfidf_train) <- gsub('Class_','',colnames(svm_tfidf_train))
colnames(svm_tfidf_train) <- paste0('svm_tfidf_',colnames(svm_tfidf_train))
NN4_tfidf_train <- fread(paste0(path,"kerasNN4_tfidf_retrain.csv"))
NN4_tfidf_train <- as.data.frame(NN4_tfidf_train)
NN4_tfidf_train$id <- NULL
colnames(NN4_tfidf_train) <- gsub('Class_','',colnames(NN4_tfidf_train))
colnames(NN4_tfidf_train) <- paste0('kerasNN4_tfidf_',colnames(NN4_tfidf_train))
NN3_tfidf_train <- fread(paste0(path,"kerasNN3_tfidf_retrain.csv"))
NN3_tfidf_train <- as.data.frame(NN3_tfidf_train)
NN3_tfidf_train$id <- NULL
colnames(NN3_tfidf_train) <- gsub('Class_','',colnames(NN3_tfidf_train))
colnames(NN3_tfidf_train) <- paste0('kerasNN3_tfidf_',colnames(NN3_tfidf_train))
NN2_tfidf_train <- fread(paste0(path,"kerasNN2_tfidf_retrain.csv"))
NN2_tfidf_train <- as.data.frame(NN2_tfidf_train)
NN2_tfidf_train$id <- NULL
colnames(NN2_tfidf_train) <- gsub('Class_','',colnames(NN2_tfidf_train))
colnames(NN2_tfidf_train) <- paste0('kerasNN2_tfidf_',colnames(NN2_tfidf_train))
knn1_tfidf_train <- fread(paste0(path,"knn1_tfidf_retrain.csv"))
knn1_tfidf_train <- as.data.frame(knn1_tfidf_train)
knn1_tfidf_train$id <- NULL
colnames(knn1_tfidf_train) <- gsub('Class_','',colnames(knn1_tfidf_train))
colnames(knn1_tfidf_train) <- paste0('knn1_tfidf_',colnames(knn1_tfidf_train))
knn2_tfidf_train <- fread(paste0(path,"knn2_tfidf_retrain.csv"))
knn2_tfidf_train <- as.data.frame(knn2_tfidf_train)
knn2_tfidf_train$id <- NULL
colnames(knn2_tfidf_train) <- gsub('Class_','',colnames(knn2_tfidf_train))
colnames(knn2_tfidf_train) <- paste0('knn2_tfidf_',colnames(knn2_tfidf_train))
knn3_tfidf_train <- fread(paste0(path,"knn3_tfidf_retrain.csv"))
knn3_tfidf_train <- as.data.frame(knn3_tfidf_train)
knn3_tfidf_train$id <- NULL
colnames(knn3_tfidf_train) <- gsub('Class_','',colnames(knn3_tfidf_train))
colnames(knn3_tfidf_train) <- paste0('knn3_tfidf_',colnames(knn3_tfidf_train))
knn4_tfidf_train <- fread(paste0(path,"knn4_tfidf_retrain.csv"))
knn4_tfidf_train <- as.data.frame(knn4_tfidf_train)
knn4_tfidf_train$id <- NULL
colnames(knn4_tfidf_train) <- gsub('Class_','',colnames(knn4_tfidf_train))
colnames(knn4_tfidf_train) <- paste0('knn4_tfidf_',colnames(knn4_tfidf_train))
knn5_tfidf_train <- fread(paste0(path,"knn5_tfidf_retrain.csv"))
knn5_tfidf_train <- as.data.frame(knn5_tfidf_train)
knn5_tfidf_train$id <- NULL
colnames(knn5_tfidf_train) <- gsub('Class_','',colnames(knn5_tfidf_train))
colnames(knn5_tfidf_train) <- paste0('knn5_tfidf_',colnames(knn5_tfidf_train))
knn6_tfidf_train <- fread(paste0(path,"knn6_tfidf_retrain.csv"))
knn6_tfidf_train <- as.data.frame(knn6_tfidf_train)
knn6_tfidf_train$id <- NULL
colnames(knn6_tfidf_train) <- gsub('Class_','',colnames(knn6_tfidf_train))
colnames(knn6_tfidf_train) <- paste0('knn6_tfidf_',colnames(knn6_tfidf_train))
knn7_tfidf_train <- fread(paste0(path,"knn7_tfidf_retrain.csv"))
knn7_tfidf_train <- as.data.frame(knn7_tfidf_train)
knn7_tfidf_train$id <- NULL
colnames(knn7_tfidf_train) <- gsub('Class_','',colnames(knn7_tfidf_train))
colnames(knn7_tfidf_train) <- paste0('knn7_tfidf_',colnames(knn7_tfidf_train))
knn8_tfidf_train <- fread(paste0(path,"knn8_tfidf_retrain.csv"))
knn8_tfidf_train <- as.data.frame(knn8_tfidf_train)
knn8_tfidf_train$id <- NULL
colnames(knn8_tfidf_train) <- gsub('Class_','',colnames(knn8_tfidf_train))
colnames(knn8_tfidf_train) <- paste0('knn8_tfidf_',colnames(knn8_tfidf_train))
knn9_tfidf_train <- fread(paste0(path,"knn9_tfidf_retrain.csv"))
knn9_tfidf_train <- as.data.frame(knn9_tfidf_train)
knn9_tfidf_train$id <- NULL
colnames(knn9_tfidf_train) <- gsub('Class_','',colnames(knn9_tfidf_train))
colnames(knn9_tfidf_train) <- paste0('knn9_tfidf_',colnames(knn9_tfidf_train))
knn10_tfidf_train <- fread(paste0(path,"knn10_tfidf_retrain.csv"))
knn10_tfidf_train <- as.data.frame(knn10_tfidf_train)
knn10_tfidf_train$id <- NULL
colnames(knn10_tfidf_train) <- gsub('Class_','',colnames(knn10_tfidf_train))
colnames(knn10_tfidf_train) <- paste0('knn10_tfidf_',colnames(knn10_tfidf_train))
knn11_tfidf_train <- fread(paste0(path,"knn11_tfidf_retrain.csv"))
knn11_tfidf_train <- as.data.frame(knn11_tfidf_train)
knn11_tfidf_train$id <- NULL
colnames(knn11_tfidf_train) <- gsub('Class_','',colnames(knn11_tfidf_train))
colnames(knn11_tfidf_train) <- paste0('knn11_tfidf_',colnames(knn11_tfidf_train))

train <- cbind(target=raw_train$target,xgb_train)
train <- cbind(train,rf_train)
train <- cbind(train,ET_train)
train <- cbind(train,svm_train)
train <- cbind(train,NN4_train)
train <- cbind(train,NN3_train)
train <- cbind(train,NN2_train)
train <- cbind(train,knn1_train)
train <- cbind(train,knn2_train)
train <- cbind(train,knn3_train)
train <- cbind(train,knn4_train)
train <- cbind(train,knn5_train)
train <- cbind(train,knn6_train)
train <- cbind(train,knn7_train)
train <- cbind(train,knn8_train)
train <- cbind(train,knn9_train)
train <- cbind(train,knn10_train)
train <- cbind(train,knn11_train)
train <- cbind(train,xgb_tfidf_train)
train <- cbind(train,rf_tfidf_train)
train <- cbind(train,ET_tfidf_train)
train <- cbind(train,svm_tfidf_train)
train <- cbind(train,NN4_tfidf_train)
train <- cbind(train,NN3_tfidf_train)
train <- cbind(train,NN2_tfidf_train)
train <- cbind(train,knn1_tfidf_train)
train <- cbind(train,knn2_tfidf_train)
train <- cbind(train,knn3_tfidf_train)
train <- cbind(train,knn4_tfidf_train)
train <- cbind(train,knn5_tfidf_train)
train <- cbind(train,knn6_tfidf_train)
train <- cbind(train,knn7_tfidf_train)
train <- cbind(train,knn8_tfidf_train)
train <- cbind(train,knn9_tfidf_train)
train <- cbind(train,knn10_tfidf_train)
train <- cbind(train,knn11_tfidf_train)

tmp <- train$target
train$target <- NULL
train$target <- tmp

train <- cbind(id=trainId,train)
for(i in 1:ncol(train)) { train[,i] <- as.character(train[,i])}
write_csv(train,paste0(path,"train_2nd.csv"))

# make test data
raw_test <- fread(paste0(path,"test.csv"))
raw_test <- as.data.frame(raw_test)
id <- raw_test$id
#
xgb_test <- fread(paste0(path,"xgb.csv"))
xgb_test <- as.data.frame(xgb_test)
xgb_test$id <- NULL
colnames(xgb_test) <- gsub('Class_','',colnames(xgb_test))
colnames(xgb_test) <- paste0('xgb_',colnames(xgb_test))
rf_test <- fread(paste0(path,"rf.csv"))
rf_test <- as.data.frame(rf_test)
rf_test$id <- NULL
colnames(rf_test) <- gsub('Class_','',colnames(rf_test))
colnames(rf_test) <- paste0('rf_',colnames(rf_test))
ET_test <- fread(paste0(path,"extraTree.csv"))
ET_test <- as.data.frame(ET_test)
ET_test$id <- NULL
colnames(ET_test) <- gsub('Class_','',colnames(ET_test))
colnames(ET_test) <- paste0('ET_',colnames(ET_test))
svm_test <- fread(paste0(path,"svm.csv"))
svm_test <- as.data.frame(svm_test)
svm_test$id <- NULL
colnames(svm_test) <- gsub('Class_','',colnames(svm_test))
colnames(svm_test) <- paste0('svm_',colnames(svm_test))
NN4_test <- fread(paste0(path,"kerasNN4.csv"))
NN4_test <- as.data.frame(NN4_test)
NN4_test$id <- NULL
colnames(NN4_test) <- gsub('Class_','',colnames(NN4_test))
colnames(NN4_test) <- paste0('kerasNN4_',colnames(NN4_test))
NN3_test <- fread(paste0(path,"kerasNN3.csv"))
NN3_test <- as.data.frame(NN3_test)
NN3_test$id <- NULL
colnames(NN3_test) <- gsub('Class_','',colnames(NN3_test))
colnames(NN3_test) <- paste0('kerasNN3_',colnames(NN3_test))
NN2_test <- fread(paste0(path,"kerasNN2.csv"))
NN2_test <- as.data.frame(NN2_test)
NN2_test$id <- NULL
colnames(NN2_test) <- gsub('Class_','',colnames(NN2_test))
colnames(NN2_test) <- paste0('kerasNN2_',colnames(NN2_test))
knn1_test <- fread(paste0(path,"knn1.csv"))
knn1_test <- as.data.frame(knn1_test)
knn1_test$id <- NULL
colnames(knn1_test) <- gsub('Class_','',colnames(knn1_test))
colnames(knn1_test) <- paste0('knn1_',colnames(knn1_test))
knn2_test <- fread(paste0(path,"knn2.csv"))
knn2_test <- as.data.frame(knn2_test)
knn2_test$id <- NULL
colnames(knn2_test) <- gsub('Class_','',colnames(knn2_test))
colnames(knn2_test) <- paste0('knn2_',colnames(knn2_test))
knn3_test <- fread(paste0(path,"knn3.csv"))
knn3_test <- as.data.frame(knn3_test)
knn3_test$id <- NULL
colnames(knn3_test) <- gsub('Class_','',colnames(knn3_test))
colnames(knn3_test) <- paste0('knn3_',colnames(knn3_test))
knn4_test <- fread(paste0(path,"knn4.csv"))
knn4_test <- as.data.frame(knn4_test)
knn4_test$id <- NULL
colnames(knn4_test) <- gsub('Class_','',colnames(knn4_test))
colnames(knn4_test) <- paste0('knn4_',colnames(knn4_test))
knn5_test <- fread(paste0(path,"knn5.csv"))
knn5_test <- as.data.frame(knn5_test)
knn5_test$id <- NULL
colnames(knn5_test) <- gsub('Class_','',colnames(knn5_test))
colnames(knn5_test) <- paste0('knn5_',colnames(knn5_test))
knn6_test <- fread(paste0(path,"knn6.csv"))
knn6_test <- as.data.frame(knn6_test)
knn6_test$id <- NULL
colnames(knn6_test) <- gsub('Class_','',colnames(knn6_test))
colnames(knn6_test) <- paste0('knn6_',colnames(knn6_test))
knn7_test <- fread(paste0(path,"knn7.csv"))
knn7_test <- as.data.frame(knn7_test)
knn7_test$id <- NULL
colnames(knn7_test) <- gsub('Class_','',colnames(knn7_test))
colnames(knn7_test) <- paste0('knn7_',colnames(knn7_test))
knn8_test <- fread(paste0(path,"knn8.csv"))
knn8_test <- as.data.frame(knn8_test)
knn8_test$id <- NULL
colnames(knn8_test) <- gsub('Class_','',colnames(knn8_test))
colnames(knn8_test) <- paste0('knn8_',colnames(knn8_test))
knn9_test <- fread(paste0(path,"knn9.csv"))
knn9_test <- as.data.frame(knn9_test)
knn9_test$id <- NULL
colnames(knn9_test) <- gsub('Class_','',colnames(knn9_test))
colnames(knn9_test) <- paste0('knn9_',colnames(knn9_test))
knn10_test <- fread(paste0(path,"knn10.csv"))
knn10_test <- as.data.frame(knn10_test)
knn10_test$id <- NULL
colnames(knn10_test) <- gsub('Class_','',colnames(knn10_test))
colnames(knn10_test) <- paste0('knn10_',colnames(knn10_test))
knn11_test <- fread(paste0(path,"knn11.csv"))
knn11_test <- as.data.frame(knn11_test)
knn11_test$id <- NULL
colnames(knn11_test) <- gsub('Class_','',colnames(knn11_test))
colnames(knn11_test) <- paste0('knn11_',colnames(knn11_test))

# tfidf space
xgb_tfidf_test <- fread(paste0(path,"xgb_tfidf.csv"))
xgb_tfidf_test <- as.data.frame(xgb_tfidf_test)
xgb_tfidf_test$id <- NULL
colnames(xgb_tfidf_test) <- gsub('Class_','',colnames(xgb_tfidf_test))
colnames(xgb_tfidf_test) <- paste0('xgb_tfidf_',colnames(xgb_tfidf_test))
rf_tfidf_test <- fread(paste0(path,"rf_tfidf.csv"))
rf_tfidf_test <- as.data.frame(rf_tfidf_test)
rf_tfidf_test$id <- NULL
colnames(rf_tfidf_test) <- gsub('Class_','',colnames(rf_tfidf_test))
colnames(rf_tfidf_test) <- paste0('rf_tfidf_',colnames(rf_tfidf_test))
ET_tfidf_test <- fread(paste0(path,"extraTree_tfidf.csv"))
ET_tfidf_test <- as.data.frame(ET_tfidf_test)
ET_tfidf_test$id <- NULL
colnames(ET_tfidf_test) <- gsub('Class_','',colnames(ET_tfidf_test))
colnames(ET_tfidf_test) <- paste0('ET_tfidf_',colnames(ET_tfidf_test))
svm_tfidf_test <- fread(paste0(path,"svm_tfidf.csv"))
svm_tfidf_test <- as.data.frame(svm_tfidf_test)
svm_tfidf_test$id <- NULL
colnames(svm_tfidf_test) <- gsub('Class_','',colnames(svm_tfidf_test))
colnames(svm_tfidf_test) <- paste0('svm_tfidf_',colnames(svm_tfidf_test))
NN4_tfidf_test <- fread(paste0(path,"kerasNN4_tfidf.csv"))
NN4_tfidf_test <- as.data.frame(NN4_tfidf_test)
NN4_tfidf_test$id <- NULL
colnames(NN4_tfidf_test) <- gsub('Class_','',colnames(NN4_tfidf_test))
colnames(NN4_tfidf_test) <- paste0('kerasNN4_tfidf_',colnames(NN4_tfidf_test))
NN3_tfidf_test <- fread(paste0(path,"kerasNN3_tfidf.csv"))
NN3_tfidf_test <- as.data.frame(NN3_tfidf_test)
NN3_tfidf_test$id <- NULL
colnames(NN3_tfidf_test) <- gsub('Class_','',colnames(NN3_tfidf_test))
colnames(NN3_tfidf_test) <- paste0('kerasNN3_tfidf_',colnames(NN3_tfidf_test))
NN2_tfidf_test <- fread(paste0(path,"kerasNN2_tfidf.csv"))
NN2_tfidf_test <- as.data.frame(NN2_tfidf_test)
NN2_tfidf_test$id <- NULL
colnames(NN2_tfidf_test) <- gsub('Class_','',colnames(NN2_tfidf_test))
colnames(NN2_tfidf_test) <- paste0('kerasNN2_tfidf_',colnames(NN2_tfidf_test))
knn1_tfidf_test <- fread(paste0(path,"knn1_tfidf.csv"))
knn1_tfidf_test <- as.data.frame(knn1_tfidf_test)
knn1_tfidf_test$id <- NULL
colnames(knn1_tfidf_test) <- gsub('Class_','',colnames(knn1_tfidf_test))
colnames(knn1_tfidf_test) <- paste0('knn1_tfidf_',colnames(knn1_tfidf_test))
knn2_tfidf_test <- fread(paste0(path,"knn2_tfidf.csv"))
knn2_tfidf_test <- as.data.frame(knn2_tfidf_test)
knn2_tfidf_test$id <- NULL
colnames(knn2_tfidf_test) <- gsub('Class_','',colnames(knn2_tfidf_test))
colnames(knn2_tfidf_test) <- paste0('knn2_tfidf_',colnames(knn2_tfidf_test))
knn3_tfidf_test <- fread(paste0(path,"knn3_tfidf.csv"))
knn3_tfidf_test <- as.data.frame(knn3_tfidf_test)
knn3_tfidf_test$id <- NULL
colnames(knn3_tfidf_test) <- gsub('Class_','',colnames(knn3_tfidf_test))
colnames(knn3_tfidf_test) <- paste0('knn3_tfidf_',colnames(knn3_tfidf_test))
knn4_tfidf_test <- fread(paste0(path,"knn4_tfidf.csv"))
knn4_tfidf_test <- as.data.frame(knn4_tfidf_test)
knn4_tfidf_test$id <- NULL
colnames(knn4_tfidf_test) <- gsub('Class_','',colnames(knn4_tfidf_test))
colnames(knn4_tfidf_test) <- paste0('knn4_tfidf_',colnames(knn4_tfidf_test))
knn5_tfidf_test <- fread(paste0(path,"knn5_tfidf.csv"))
knn5_tfidf_test <- as.data.frame(knn5_tfidf_test)
knn5_tfidf_test$id <- NULL
colnames(knn5_tfidf_test) <- gsub('Class_','',colnames(knn5_tfidf_test))
colnames(knn5_tfidf_test) <- paste0('knn5_tfidf_',colnames(knn5_tfidf_test))
knn6_tfidf_test <- fread(paste0(path,"knn6_tfidf.csv"))
knn6_tfidf_test <- as.data.frame(knn6_tfidf_test)
knn6_tfidf_test$id <- NULL
colnames(knn6_tfidf_test) <- gsub('Class_','',colnames(knn6_tfidf_test))
colnames(knn6_tfidf_test) <- paste0('knn6_tfidf_',colnames(knn6_tfidf_test))
knn7_tfidf_test <- fread(paste0(path,"knn7_tfidf.csv"))
knn7_tfidf_test <- as.data.frame(knn7_tfidf_test)
knn7_tfidf_test$id <- NULL
colnames(knn7_tfidf_test) <- gsub('Class_','',colnames(knn7_tfidf_test))
colnames(knn7_tfidf_test) <- paste0('knn7_tfidf_',colnames(knn7_tfidf_test))
knn8_tfidf_test <- fread(paste0(path,"knn8_tfidf.csv"))
knn8_tfidf_test <- as.data.frame(knn8_tfidf_test)
knn8_tfidf_test$id <- NULL
colnames(knn8_tfidf_test) <- gsub('Class_','',colnames(knn8_tfidf_test))
colnames(knn8_tfidf_test) <- paste0('knn8_tfidf_',colnames(knn8_tfidf_test))
knn9_tfidf_test <- fread(paste0(path,"knn9_tfidf.csv"))
knn9_tfidf_test <- as.data.frame(knn9_tfidf_test)
knn9_tfidf_test$id <- NULL
colnames(knn9_tfidf_test) <- gsub('Class_','',colnames(knn9_tfidf_test))
colnames(knn9_tfidf_test) <- paste0('knn9_tfidf_',colnames(knn9_tfidf_test))
knn10_tfidf_test <- fread(paste0(path,"knn10_tfidf.csv"))
knn10_tfidf_test <- as.data.frame(knn10_tfidf_test)
knn10_tfidf_test$id <- NULL
colnames(knn10_tfidf_test) <- gsub('Class_','',colnames(knn10_tfidf_test))
colnames(knn10_tfidf_test) <- paste0('knn10_tfidf_',colnames(knn10_tfidf_test))
knn11_tfidf_test <- fread(paste0(path,"knn11_tfidf.csv"))
knn11_tfidf_test <- as.data.frame(knn11_tfidf_test)
knn11_tfidf_test$id <- NULL
colnames(knn11_tfidf_test) <- gsub('Class_','',colnames(knn11_tfidf_test))
colnames(knn11_tfidf_test) <- paste0('knn11_tfidf_',colnames(knn11_tfidf_test))

test <- cbind(xgb_test,rf_test)
test <- cbind(test,ET_test)
test <- cbind(test,svm_test)
test <- cbind(test,NN4_test)
test <- cbind(test,NN3_test)
test <- cbind(test,NN2_test)
test <- cbind(test,knn1_test)
test <- cbind(test,knn2_test)
test <- cbind(test,knn3_test)
test <- cbind(test,knn4_test)
test <- cbind(test,knn5_test)
test <- cbind(test,knn6_test)
test <- cbind(test,knn7_test)
test <- cbind(test,knn8_test)
test <- cbind(test,knn9_test)
test <- cbind(test,knn10_test)
test <- cbind(test,knn11_test)
test <- cbind(test,xgb_tfidf_test)
test <- cbind(test,rf_tfidf_test)
test <- cbind(test,ET_tfidf_test)
test <- cbind(test,svm_tfidf_test)
test <- cbind(test,NN4_tfidf_test)
test <- cbind(test,NN3_tfidf_test)
test <- cbind(test,NN2_tfidf_test)
test <- cbind(test,knn1_tfidf_test)
test <- cbind(test,knn2_tfidf_test)
test <- cbind(test,knn3_tfidf_test)
test <- cbind(test,knn4_tfidf_test)
test <- cbind(test,knn5_tfidf_test)
test <- cbind(test,knn6_tfidf_test)
test <- cbind(test,knn7_tfidf_test)
test <- cbind(test,knn8_tfidf_test)
test <- cbind(test,knn9_tfidf_test)
test <- cbind(test,knn10_tfidf_test)
test <- cbind(test,knn11_tfidf_test)

test <- cbind(id,test)
for(i in 1:ncol(test)) { test[,i] <- as.character(test[,i])}

write_csv(test,paste0(path,"test_2nd.csv"))


context("coord_polar")

test_that("polar distance is calculated correctly", {
  dat <- data_frame(
    theta = c(0, 2*pi,   2,   6, 6, 1,    1,  0),
    r     = c(0,    0, 0.5, 0.5, 1, 1, 0.75, .5))

  scales <- list(
    x = scale_x_continuous(limits = c(0, 2*pi)),
    y = scale_y_continuous(limits = c(0, 1))
  )
  coord <- coord_polar()
  panel_params <- coord$setup_panel_params(scales$x, scales$y)
  dists <- coord$distance(dat$theta, dat$r, panel_params)

  # dists is normalized by dividing by this value, so we'll add it back
  # The maximum length of a spiral arc, from (t,r) = (0,0) to (2*pi,1)
  maxlen <- spiral_arc_length(1 / (2 * pi), 0, 2 * pi)

  # These are the expected lengths. I think they're correct...
  expect_equal(dists,
    c(0, -1.225737494, -2, -0.5, -5, -0.25, -0.6736885011) / maxlen)

  # The picture can be visualized with:
  # ggplot(dat, aes(x=theta, y=r)) + geom_path() +
  #   geom_point(alpha=0.3) + coord_polar()
})

test_that("polar distance calculation ignores NA's", {

  # These are r and theta values; we'll swap them around for testing
  x1 <- c(0, 0.5, 0.5, NA, 1)
  x2 <- c(0,   1,   2, 0,  1)

  dists <- dist_polar(x1, x2)
  expect_equal(is.na(dists), c(FALSE, FALSE, TRUE, TRUE))
  dists <- dist_polar(x2, x1)
  expect_equal(is.na(dists), c(FALSE, FALSE, TRUE, TRUE))

  # NA on the end
  x1 <- c(0, 0.5, 0.5, 1, NA)
  x2 <- c(0,   1,   2, 0,  1)
  dists <- dist_polar(x1, x2)
  expect_equal(is.na(dists), c(FALSE, FALSE, FALSE, TRUE))
  dists <- dist_polar(x2, x1)
  expect_equal(is.na(dists), c(FALSE, FALSE, FALSE, TRUE))

  # NAs in each vector - also have NaN
  x1 <- c(0, 0.5, 0.5,  1, NA)
  x2 <- c(NaN,   1,   2, NA,  1)
  dists <- dist_polar(x1, x2)
  expect_equal(is.na(dists), c(TRUE, FALSE, TRUE, TRUE))
  dists <- dist_polar(x2, x1)
  expect_equal(is.na(dists), c(TRUE, FALSE, TRUE, TRUE))
})

test_that("clipping can be turned off and on", {
  # clip can be turned on and off
  p <- ggplot() + coord_polar()
  coord <- ggplot_build(p)$layout$coord
  expect_equal(coord$clip, "on")

  p <- ggplot() + coord_polar(clip = "off")
  coord <- ggplot_build(p)$layout$coord
  expect_equal(coord$clip, "off")
})

test_that("Inf is squished to range", {
  d <- cdata(
    ggplot(data_frame(x = "a", y = 1), aes(x, y)) +
      geom_col() +
      coord_polar() +
      annotate("text", Inf, Inf, label = "Top-Center") +
      annotate("text", -Inf, -Inf, label = "Center-Center")
  )

  # 0.4 is the upper limit of radius hardcoded in r_rescale()
  expect_equal(d[[2]]$r, 0.4)
  expect_equal(d[[2]]$theta, new_mapped_discrete(0))
  expect_equal(d[[3]]$r, 0)
  expect_equal(d[[3]]$theta, new_mapped_discrete(0))
})

# Visual tests ------------------------------------------------------------

test_that("polar coordinates draw correctly", {
  theme <- theme_test() +
    theme(
      axis.text.y = element_blank(),
      axis.title = element_blank(),
      panel.grid.major = element_line(colour = "grey90")
    )
  dat <- data_frame(x = rep(0:1, 4), y = rep(c(1, 10, 40, 80), each = 2))

  expect_doppelganger("three-concentric-circles",
    ggplot(dat, aes(x, y, group = factor(y))) +
      geom_path() +
      coord_polar() +
      theme
  )

  dat <- data_frame(
    theta = c(0, 2*pi,   2,   6, 6, 1,    1,  0),
    r     = c(0,    0, 0.5, 0.5, 1, 1, 0.75, .5),
    g     = 1:8
  )
  expect_doppelganger("Rays, circular arcs, and spiral arcs",
    ggplot(dat, aes(theta, r, colour = g)) +
      geom_path(show.legend = FALSE) +
      geom_point(colour = "black") +
      coord_polar() +
      theme
  )

  dat <- data_frame(x = LETTERS[1:3], y = 1:3)
  expect_doppelganger("rose plot with has equal spacing",
    ggplot(dat, aes(x, y)) +
      geom_bar(stat = "identity") +
      coord_polar() +
      theme
  )
  expect_doppelganger("racetrack plot: closed and no center hole",
    ggplot(dat, aes(x, y)) +
      geom_bar(stat = "identity") +
      coord_polar(theta = "y") +
      theme
  )
  expect_doppelganger("racetrack plot: closed and has center hole",
    ggplot(dat, aes(x, y)) +
      geom_bar(stat = "identity") +
      coord_polar(theta = "y") +
      scale_x_discrete(expand = c(0, 0.6)) +
      theme
  )
  expect_doppelganger("secondary axis ticks and labels",
    ggplot(dat, aes(x, y, group = factor(y))) +
      geom_blank() +
      scale_y_continuous(sec.axis = sec_axis(~. * 0.1, name = "sec y")) +
      coord_polar() +
      theme_test() +
      theme(axis.text.x = element_blank())
  )
})


# Exercise 2
#
# Time: 5 minutes

# 1) Create the following:
#
#  a) a variable containing the word "chicken"
#  b) a numeric vector with the number 2, 4, 6, and 8
#  c) a 3 X 3 matrix of nine numbers (these can be sequential)
#
#  Now create a list that contains the three data structures

# 2) Find the average number of green shapes in the 'shapes' matrix