#  James Rekow

piusTreatmentTest  = function(M = 40, numSubgroups = 1, N = 20, iStrength = 1, univ = 1,
                              sigmaMax = 0.1, thresholdMult = 10 ^ (-1), maxSteps = 10 ^ 4,
                              tStep = 10 ^ (-2), intTime = 1, interSmplMult = 0.01, lambda = 0,
                              returnParams = FALSE, conGraph = NULL, rollRange = 0.025, numClust = NULL,
                              returnNumSubgroupsComputed = FALSE){

  #  ARGS:
  #
  #  RETURNS:

  source("subgroupsAbdListCreator.r")
  source("computeSubgroupVec.r")
  source("pius.r")
  source("countSubgroupVecDiff.r")

  #  create abundance list using treatment input parameters
  abdList = subgroupsAbdListCreator(M = M, numSubgroups = numSubgroups, N = N, iStrength = iStrength,
                                    univ = univ, sigmaMax = sigmaMax, thresholdMult = thresholdMult,
                                    maxSteps = maxSteps, tStep = tStep, intTime = intTime,
                                    interSmplMult = interSmplMult, lambda = lambda,
                                    returnParams = returnParams, conGraph = conGraph)

  #  compute default subgroup vector
  subgroupsActual = computeSubgroupVec(M = M, numSubgroups = numSubgroups)

  #  create reordering to randomize subgroup structure (to randomly reorder samples in cohort and perform
  #  the same reordering on the default subgroup vector)
  reordering = sample(M)

  #  perform randomization
  abdList = abdList[reordering]
  subgroupsActual = subgroupsActual[reordering]

  #  compute algorithm's guess at subgroup vector
  subgroupsComputed = pius(abdList, rollRange = rollRange, numClust = numClust)

  #  compute the number of differences between actual and computed subgroup membership
  numDiff = countSubgroupVecDiff(subgroupVec1 = subgroupsActual, subgroupVec2 = subgroupsComputed)

  #  compute percent error of algorithms computed subgroup membership vector
  percentError = 100 * numDiff / M

  #  if returnNumSubgroupsComputed is set to TRUE, return a list with the percent error and the number of
  #  subgroups (clusters) identified by the pius algorithm
  if(returnNumSubgroupsComputed){

    numSubgroupsComputed = length(unique(subgroupsComputed))

    returnVec = c(percentError = percentError, numSubgroupsComputed = numSubgroupsComputed)

    return(returnVec)

  } #  end if

  return(percentError)

} #  end  piusTreatmentTest function


library(readstata13)

## 1950 - 2005 panel data from Burke&Emrick ##
thepanel <- read.dta("us_panel.dta")

thepanel$logcornyield <- log(thepanel$cornyield)
thepanel$lower   = thepanel$dday0C
thepanel$higher  = thepanel$dday29C

# specify the study region
usepanel <- thepanel[which(  thepanel$longitude>-100
                             & thepanel$longitude<=-82.5
                             & thepanel$latitude>36),]

columnkeep <- c("fips","year","longitude","latitude","logcornyield","lower","higher","prec",
                "dday0C","dday5C","dday8C","dday10C","dday12C","dday15C","dday20C",
                "dday25C","dday29C","dday30C","dday31C","dday32C","dday33C","dday34C")

usepanel <- na.omit(usepanel[,which(colnames(usepanel) %in% columnkeep)])

## convert data into numeric values
indx <- sapply(usepanel, is.factor)
usepanel[indx] <- lapply(usepanel[indx],
                         function(x) as.numeric(as.character(x)))

## drop missing values to create a complete panel
fullspan <- expand.grid(unique(usepanel$year),unique(usepanel$fips))
colnames(fullspan)=c("year","fips")
usepanel2 <- merge(fullspan,usepanel,by=c("fips","year"),all.x=TRUE)

missing.at.least.one <- unique(usepanel2$fips[!complete.cases(usepanel2)])
usepanel3 <- usepanel2[!(usepanel2$fips %in% missing.at.least.one),]

## 2.2 add 2006-2015 new data
#  2.2.1 Climate data pre-generated from PRISM weather data set.

datasub1 <- read.dta13("ddayByYearandFips_cropAreaWeighted1_22.dta")
datasub2 <- read.dta13("ddayByYearandFips_cropAreaWeighted23_56.dta")
data <- rbind(datasub1,datasub2)

data$lower <- data$dday0C
data$higher <- data$dday29C

data_cc <- data[,which(colnames(data) %in% columnkeep)]

# 2.2.2 Crop yield data downloaded from USDA

yield <- read.csv("corn_yield.csv",header = TRUE)
neededcounties <- read.table("oldallcounties.txt",header = TRUE)
names(neededcounties) <- "fips"
neededcounties_year <- expand.grid(neededcounties$fips,2006:2015)
names(neededcounties_year) <- c("fips","year")

yield2 <- merge(yield,neededcounties_year,
                by=c("fips","year"),all.y = TRUE)

missed =!complete.cases(yield2)
missedata <- yield2[missed,]
notmisseddata <- yield2[!missed,]

for (i in 1:sum(missed)){
  thefips <- missedata[i,1]
  theyear <- missedata[i,2]
  thestate <- floor(missedata[i,1]/1000)

  thecode <- notmisseddata[which(notmisseddata$fips == thefips)[1],11]

  therow <- which(yield$year==theyear &
                    yield$statefips == thestate &
                    yield$Ag.District.Code == thecode &
                    yield$countyfips == 999)

  yield2$yield[which(missed==TRUE)[i]]=yield[therow,10]
}

# 3.2.3. Combine yield with climate

data0615 <- merge(yield2,data_cc,by=c("fips","year"),all.x = TRUE)

data0615$logcornyield <- log(data0615$yield)

# read in coords
coords <- read.table("coords.txt",header = TRUE)
data0615_f <- merge(data0615, coords, by="fips",all.x = TRUE)

data0615_f <- data0615_f[,which(colnames(data0615_f) %in% columnkeep)];head(data0615_f)
#data0615_f <- data0615_f[,c(1,2,3,7,8,6,4,5)]

newdata <- data0615_f
newdata$prec <- newdata$prec/10; head(newdata)

## 3.3 merge and add few new

dim(usepanel3);dim(newdata)
usepanel3<-usepanel3[,columnkeep]
newdata<-newdata[,columnkeep]
if(sum(names(newdata) != names(usepanel3))>0) stop("colunm names not consistent")
allPanel <- rbind(usepanel3,newdata)

summary(allPanel)
years<-as.numeric(as.character(allPanel$year))
allPanel$t <- (years-mean(years))
allPanel$t2 <- allPanel$t^2
allPanel$precsq <- (allPanel$prec)^2

write.csv(allPanel,"Paneldata.csv")


suppressPackageStartupMessages(library(combinat))

context("ipermutations iterator")

test_that("ipermutations matches the output from combinat::permn", {
  permn_out <- combinat::permn(letters[1:4])
  it <- ipermutations(letters[1:4])

  # The ordering of the permutations from ipermutations does not match
  # that of combinat::permn. Consequently, we create a matrix from
  # each method and then sort them before the test comparison is made.
  permn_rbind <- do.call(rbind, permn_out)
  ipermutations_rbind <- do.call(rbind, as.list(it))

  permn_order <- order(permn_rbind[, 1],
                       permn_rbind[, 2],
                       permn_rbind[, 3],
                       permn_rbind[, 4])
  permn_rbind <- permn_rbind[permn_order, ]

  ipermutations_order <- order(ipermutations_rbind[, 1],
                               ipermutations_rbind[, 2],
                               ipermutations_rbind[, 3],
                               ipermutations_rbind[, 4])
  ipermutations_rbind <- ipermutations_rbind[ipermutations_order, ]

  expect_equal(ipermutations_rbind, permn_rbind)
})

test_that("ipermutations generates m-length permutations properly", {
  it <- ipermutations(letters[1:4], m=2)

  expect_equal(iterators::nextElem(it), c('a', 'b'))
  expect_equal(iterators::nextElem(it), c('a', 'c'))
  expect_equal(iterators::nextElem(it), c('a', 'd'))
  expect_equal(iterators::nextElem(it), c('b', 'a'))
  expect_equal(iterators::nextElem(it), c('b', 'c'))
  expect_equal(iterators::nextElem(it), c('b', 'd'))
  expect_equal(iterators::nextElem(it), c('c', 'a'))
  expect_equal(iterators::nextElem(it), c('c', 'b'))
  expect_equal(iterators::nextElem(it), c('c', 'd'))
  expect_equal(iterators::nextElem(it), c('d', 'a'))
  expect_equal(iterators::nextElem(it), c('d', 'b'))
  expect_equal(iterators::nextElem(it), c('d', 'c'))

  expect_error(iterators::nextElem(it), "StopIteration")
})


g1 <- apply(AudiByMarkets,1,function(y) y[1])
g1 <- ag1[!is.na(g1)]

pdf("slike/Audi_trgi.pdf")

g_range <- range(0)
izbrani <- c(1, 4, 5, 6, 12, 13)
barve <- c("blue", "red", "pink", "green", "brown", "black")
for (i in izbrani ) {
  row <- as.numeric(as.vector(AudiByMarkets[i,]))
  row[is.na(row)] = 0
  row <- row / 1000
  g_range <- range(g_range, row)
}

row <- as.numeric(as.vector(AudiByMarkets[izbrani[1],]))
row[is.na(row)] = 0
row <- row / 1000
plot(row, type="o", col=barve[1], ylim=g_range,
     axes=FALSE, ann=FALSE)
for (k in 2:length(izbrani) ) {
  i <- izbrani[k]
  row <- as.numeric(as.vector(AudiByMarkets[i,]))
  row[is.na(row)] = 0
  row <- row / 1000
  # Graph trucks with red dashed line and square points
  lines(row, type="o", col=barve[k])
}

# Make x axis
axis(1, at=1:11, lab=c(1996:2006), cex.lab=0.8)

# Make y axis with horizontal labels that display ticks at
# every 4 marks. 4*0:g_range[2] is equivalent to c(0,4,8,12).
axis(2, las=1, at=ceiling(seq(g_range[1], g_range[2],length=8)))

# Create box around plot
box()

# Create a title with a red, bold/italic font
title(main="Prodaja avtomobilov", col.main="black", font.main=4)

# Label the x and y axes
title(xlab="Leta")
title(ylab="Število prodanih Audijev v tisočih")

# Create a legend at (1, g_range[2]) that is slightly smaller
# (cex) and uses the same line colors and points used by
# the actual plots
legend(1, 221, row.names(AudiByMarkets)[izbrani], cex=0.8,
       col=barve, lty=1:1);

#STOLPIČNI DIAGRAM

m <- as.matrix(AudiByMarkets[-15,])/1000
barplot(as.matrix(AudiByMarkets[-15,])/1000, beside = TRUE,
        las=2, names.arg=1996:2006,
        col=rainbow(14), cex.names=0.6, ylim = c(0, 400))
legend("topleft", legend = row.names(AudiByMarkets)[1:14], cex=0.6,
       fill=rainbow(14))
)
axis(2, las=1, at=ceiling(seq(g_range[1], g_range[2],length=8)))
box()
title(main="Prodaja avtomobilov - stoplični diagram", col.main="black", font.main=4)

title(xlab="Leta")
title(ylab="Število prodanih Audijev v tisočih")

#AUDI TOVARNE

g_range <- range(0)
izbrani <- c(4, 11, 18, 22, 25, 31)
barve <- c("blue", "red", 116, "brown", "black", "purple",)
for (i in izbrani ) {
  row <- as.numeric(as.vector(AudiProduction[i,]))
  row[is.na(row)] = 0
  row <- row / 1000
  g_range <- range(g_range, row)
}

row <- as.numeric(as.vector(AudiProduction[izbrani[1],]))
row[is.na(row)] = 0
row <- row / 1000
plot(row, type="o", col=barve[1], ylim=g_range,
     axes=FALSE, ann=FALSE)
for (k in 2:length(izbrani) ) {
  i <- izbrani[k]
  row <- as.numeric(as.vector(AudiProduction[i,]))
  row[is.na(row)] = 0
  row <- row / 1000
  # Graph trucks with red dashed line and square points
  lines(row, type="o", col=barve[k])
}

# Make x axis using Mon-Fri labels
axis(1, at=1:11, lab=names(AudiProduction))

# Make y axis with horizontal labels that display ticks at
# every 4 marks. 4*0:g_range[2] is equivalent to c(0,4,8,12).
axis(2, las=1, at=ceiling(seq(g_range[1], g_range[2],length=8)))

# Create box around plot
box()

# Create a title with a red, bold/italic font
title(main="Audi po modelih", font.main=4)

# Label the x and y axes
title(xlab="Leta")
title(ylab="Število proizvedenih avtomobilov v tisočih")

# Create a legend at (1, g_range[2]) that is slightly smaller
# (cex) and uses the same line colors and points used by
# the actual plots
legend(8.5, 305, row.names(AudiProduction)[izbrani], cex=0.6,
       col=barve, lty=1:1);

dev.off()


# This tool presents a new method to identify the vent location of tephra fall deposits
# based on thickness or maximum clast size measurements.
# It is temporarily named "svl", which is short for Source Vent Locator.
# This file includes the associated R functions and their notations.

###
# Since the presented method gives estimate on the vent location and prevailing wind
# direction, it can be used to produce the input for our method to model the thickness
# or maximum clast size distribution of
# tephra fall deposits (Yang and Bursik, 2016; https://vhub.org/resources/3957).
###
# Author: Qingyuan Yang, Marcus Bursik, and E. Bruce Pitman.
###
# License: GPL. Use at your own risk.
###
# The work was supported by National Science Foundation Hazard SEES grant number 1521855 to
# G. Valentine, M. Bursik, E.B. Pitman and A.K. Patra, and National Science Foundation
# DMS grant number 1621853 to A.K. Patra, M. Bursik, and E.B. Pitman.
###
# We appreciate your comments, suggestions, and feedback.
# Please feel free to contact us through vhub or email: qyang5@buffalo.edu
# Notes:
#	The functions below are the version of the method that is coupled with the semi-
#	empirical model proposed by Yang and Bursik (2016).

###### Functions ######
#################################Intermediate functions#################################
#################### Function name: sp_par_cal ####################
# Function to calculate downwind and cross wind distance of the input sample sites given known
# source vent and wind direction.
# The name "sp_par_cal" is short for "spatial parameter calculation".
# Input:
	# obs:
	#	n-by-3 matrix of x, y, z, indicating coordinates and measured thickness
	#	or maximum clast size of each sample site. x and y should be in utm coordinates,
	#	and z should be in millimeter with a minimum value of 1 mm.
	# sv:
	#	a vector of two elements (utm coordinates) indicating the assumed vent location.
	# wind_dir
	# 	a numeric value of assumed wind direction (from north clockwise).
# Output:
	# an n-by-7 matrix,
	# The 1st and 2nd columns:
	#	original coordinates of sample sites;
	# The 3-5th columns:
	#	total distance (dist), downwind (dd), and crosswind (cd) distance
	# 	with respect to the source vent (sv).
	# The 6th column:
	#	difference between total distance and downwind distance.
	# The 7th column:
	#	thickness or grain size measurement at each sample site.
	###### Brief description ######
	# This function uses basic vector/matrix multiplication in R to prepare the data for
	# calculating and fitting the objective function, GIVEN ASSUMED FIXED source
	# vent location and wind direction.
sp_par_cal <- function(obs, sv, wind_dir){
	sv = as.vector(sv)
	zr <- obs[,3]
	xy <- as.matrix(obs[,c(1,2)])
	nr <- nrow(obs)
	sv_matrix <- matrix(ncol=2, nrow=nr)
	sv_matrix[,1] <- rep(sv[1], nr)
	sv_matrix[,2] <- rep(sv[2], nr)
	unit_vector <- as.matrix(c(sin(wind_dir*pi/180),cos(wind_dir*pi/180)))
	rel_xy <- xy - sv_matrix
	dist <- (rel_xy[,1]^2 + rel_xy[,2]^2)^0.5
	dd <- (rel_xy) %*% (unit_vector)
	cd <- (dist^2 - dd^2)^0.5
	output <- matrix(nrow = nr, ncol=7)
	output[,1:2] <- xy
	output[,3:5] <- cbind(dist, dd, cd)
	output[,6] <- dist - dd
	output[,7] <- zr
	return(output)
}

#################### Function name: fi ####################
# Function to calculate the sum of squared residuals (calculated under log-scale)
# GIVEN FIXED source vent location and wind direction.
# The name "fi" is short for "fitting".
# Input:
	# obs, sv, and wind_dir:
	#	inputs for function "sp_par_cal".
	###### Output ######
	# ssr:
	#	a numeric value which is the sum of squared residuals (ssr) from the fitting.
	# Note:
	#	The method uses the semi-empirical model of Yang and Bursik (2016).
	#	Note the line with "***" on the right, which is used for the
	#	semi-empirical model proposed by Gonzalez-Mellado and De la Cruz-Reyna
	# 	(2010). It is not used here.
fi <- function(obs, sv, wind_dir){
	td <- as.data.frame(sp_par_cal(obs, sv, wind_dir))
		# Call the "sp_par_cal" function, and turn the output to data.frame.
	colnames(td) <- c("x","y","dist","dd","cd", "dif","zr")
		# Name the columns.
	td$z = log10(td$zr)
		# Transform the thickness into log-scale.
	## Fitting and calculate the ssr
#       fit.res <- lm(z~dif+log(dist),data=td)		# *** Case 1: power-law model, not used here.
        fit.res <- lm(z~dist+dd,data=td)		# Case 2: exponential model.
      	ssr <- sum(fit.res$residuals^2)			# Calculate the ssr.
	return(ssr)
}

#################### Function name: fi2 ####################
# This function is basically identical to the function "fi".
# The only difference is the output.
# It is called when the vent position is found.
# In addition to "ssr" in function "fi", it also returns the fitted coefficients
# of the semi-empirical model and the associated r-square value.
# With these values, we could have a better understanding on the predicted result.
# Input
	# Identical to the inputs for function "fi"
# Output
	# a vector with five elements including:
	# ssr: sum of squared residuals;
	# fit.res$coefficients: fitted coefficients (three values) of the semi-empirical model given
	# 	fixed vent location and wind direction;
	# summary(fit.res)$r.squared): r-squared value of the fitted result given
	#	fixed vent location and wind direction (a numeric value).
fi2 <- function(obs, sv, wind_dir){
	td <- as.data.frame(sp_par_cal(obs, sv, wind_dir))
	colnames(td) <- c("x","y","dist","dd","cd", "dif","zr")
	td$z = log10(td$zr)
	## Fitting and measure the ssr
#      	fit.res <- lm(z~dif+log(dist),data=td)		# Case 1: power-law model, not used here.
       	fit.res <- lm(z~dist+dd,data=td)		# Case 2: exponential model.
      	ssr <- sum(fit.res$residuals^2)
	return(c(ssr, fit.res$coefficients, summary(fit.res)$r.squared))
}

#################### Function name: cg ####################
# Function to generate points (in the x-y plane) around a given point. This given point
# is the proposed vent location from the previous iteration.
#
# The generated points are proposed such that the following function compares if
# one of them or the proposed vent location from the previous iteration is closer to the true vent location.
# The generated points are located in the four cardinal directions with respect to the proposed vent location
# from the previous iteration.
# The function name is short for "Circle Generator".
# Input:
	# sv:
	#	the proposed vent location from previous iteration.
	#	Its form is identical to "sv" in "sp_par_cal".
	# h:
	#	a numeric value (search radius), indicating how far the four generated points are
	#	from the previous proposed vent location.

# Output
	#	a 4-by-2 matrix containing the coordinates of the four generated points.
cg <- function(sv, h){
	output  = cbind(c(rep(sv[,1],4)+sin(0:3*90*pi/180)*h),
		    c(rep(sv[,2],4)+cos(0:3*90*pi/180)*h))
	return(output)
}

#################### Function name: baf_pre ####################
# This function prepares for the function "baf" below. It is designed
# to avoid local minima in estimating the wind direction.
# The name "baf_pre" is short for "best-fitted angle finder_prepare".
# Input
	# sv and obs:
	#	inputs required for function "sp_par_cal"
	# nlps:
	#	A numeric value indicating the number of iterations
	# 	used to estimate the prevailing wind direction.
	# 	It is not used here, but is necessary for the ongoing functions.
# Output
	# A vector containing two or three values:
	# 	If the first element is 1,
	# 		no local minima occur. The 2nd element is a rough estimate
	#		on the prevailing wind direction.
	#	If the first element is 2,
	# 		local minima are present. The next two elements are rough estimates
	#		on the global and local minima of wind direction. Both of them will be applied to ongoing
	#		functions.
baf_pre <- function(sv, obs, nlps){
	pot_ang <- as.data.frame((1:36)*10)
	pot_ssr <- apply(pot_ang, MARGIN = 1, FUN=fi, obs = obs, sv = sv)
	#lowest_rank = which(rank(pot_ssr)==1)			# Power-law ***
	#next_lowest_rank = which(rank(pot_ssr)==2)		# Power-law ***
	lowest_rank = min(which(rank(pot_ssr)<2))				#exponential
	next_lowest_rank = min(which(rank(pot_ssr)<4 & rank(pot_ssr)>2))	#exponential
	if(abs(lowest_rank - next_lowest_rank)==1 || abs(lowest_rank - next_lowest_rank)==35){
		return(c(1, pot_ang[lowest_rank,1]))
	}else{
		return(c(2, pot_ang[lowest_rank,1], pot_ang[next_lowest_rank, 1]))
	}
}

#################### Function name: baf_processor ####################
# Function to estimate the prevailing wind direction with an assumed and
# fixed vent location. It uses a standard one-dimensional gradient descent method.
# The name "baf_processor" is short for "best-angle finder_processor".
# Input
	# sv and obs: inputs for the function "sp_par_cal".
	# nlps: number of loops for the 1d gradient descent method.
	# 	It is sufficient to set its value to 20.
	# proposed_winddir: the proposed wind direction from the function "baf_pre".
	# This function uses the output from function "baf_pre" as
	# the initial guess on wind direction.
# Output
	# a 1-by-2 matrix containing:
	#	the predicted wind direction;
	#	the corresponding sum of squared residuals.
baf_processor <- function(sv, obs, nlps, proposed_winddir){
	fdm <- matrix(c(-1,0,1,-1,0,1), nrow=2)
	h <- 5
	warns <- 0
	resm <- data.frame(matrix(ncol=2,nrow=2))
	gdnt <- c()
	wind_dir = proposed_winddir
	res <- fi(obs, sv, wind_dir)
	resm[1,1] <- wind_dir
	resm[1,2] <- res[1]
	wind_dir <- wind_dir + h
	res <- fi(obs, sv, wind_dir)
	resm[2,1] <- wind_dir
	resm[2,2] <- res[1]
	if(resm[1,2] >= resm[2,2]){
		lid <- 1
	}else{
		lid <- -1
	}
	r = 1
	# lid=1 -> going forward, wind_direction+ ;
	# lid=-1 -> going backward, wind_direction- ;
	# lid=0 -> going in between, the wind direction is between the last two values;
	# r=0 -> h has just been shrunk;
	# r=1 -> the h has been shrunk for the last two iterations.
	for(i in 3:nlps){
		if(lid == 1){
			wind_dir <- resm[order(resm[,2]),][1,1] + h
			lid <- 1
		}else if(lid == -1){
			wind_dir <- resm[order(resm[,2]),][1,1] - 2 * h
			lid <- -1
		}else if(lid == 0 && r == 1){
			h <- h * 0.4
			wind_dir <-resm[order(resm[,2]),][1,1] + h
			r = 0
		}else if(lid == 0 && r == 0){
			wind_dir <-resm[order(resm[,2]),][1,1] - h
			r = 1
		}

		res <- fi(obs, sv, wind_dir)
		resm[i,1] <- wind_dir
		resm[i,2] <- res[1]

		resm <- resm[order(resm[,1]),]
			if(lid == 1){
				gdnt <-  fdm %*% resm[c(i-2,i-1,i),2]
			}
			if(lid == -1){
				gdnt <- fdm %*% resm[c(1,2,3),2]
			}
			if(lid == 0 ){
				n <- which(resm[,2]==min(resm[,2]))
				gdnt <- fdm %*% resm[c(n-1,n, n+1) ,2]
			}
		if(gdnt[1]<0 && gdnt[2]>=0){lid <- 0}
		if(gdnt[1]>=0 && gdnt[2] >= 0){lid <- -1}
		if(gdnt[1]<0 && gdnt[2] <0){lid <- 1}
		if(gdnt[1] > 0 && gdnt[2] < 0){lid <- -1}

		if(h < 0.01){break}
	}
	temp <- resm[which(resm[,2]==min(resm[,2])),]
	output <- as.matrix(cbind(temp[1], temp[2]), nrow = 1)

	return(output)
}

#################### Function name: baf ####################
# As noted above, local minimum could occur for estimating the prevailing wind direciton.
# Therefore this function is designed to receive outputs from the function "baf_pre".
# It first identifies if local minima occur or not, then applies the proposed initial
# guess(es) to the function "baf_processor", and collects the output.
# If local minima occur, it compares the resultant two sum of squared residuals to
# determine which one represents the true prevailing wind direction (global minimum).
# Input
	# sv and obs:
	#	inputs required for function "sp_par_cal".
	# nlps:
	#	a numerical value required for the function "baf_processor",
	#	as described before.
# Output
	# Optimum output from function "baf_processor".
baf <- function(sv, obs, nlps){
	raw_inference <- baf_pre(sv, obs, nlps)
	if(raw_inference[1] == 1){
		output = baf_processor(sv, obs, nlps, raw_inference[2])
		return(output)
	}else{
		output_1 = baf_processor(sv, obs, nlps, raw_inference[2])
		output_2 = baf_processor(sv, obs, nlps, raw_inference[3])
		if(output_1[2]<output_2[2]){return(output_1)}else{return(output_2)}
	}
}

#################### Function name: compare ####################
# This function COMPAREs if the proposed vent location from the last iteration
# or one of the points generated from function "cg" is closer to the true vent location.
# 	If the proposed vent location from the last iteration is closer to the true vent,
# 	it passes this proposed vent location to the next iteration.
# 	If one or more points generated from function "cg" are closer
# 	to the true vent, it provides a direction (unit vector) which is used to propose
#	the vent location for the next iteration (which will lie in the direction represented
#	by the unit vector).
# Input
	# sv and obs:
	#	inputs required for function "sp_par_cal".
	# h:
	# 	input required for function "cg".
	# nlps:
	#	inputs required for functions "baf_pre", "baf_processor", and "baf".
	# h_ratio:
	#	a numeric value that can be used to further constrain the search radius in function "cg".
	#	From our experiments, it seems that to set this value to 1 is an appropriate option.
# Output
	# 	if:
	#	the proposed vent location from the last iteration is closer to the true vent:
	#		the output is a numeric value 1. We keep this point for the next iteration.
	#	else:
	#		the output is a vector of three elements. The first element is the numeric value 2.
	#		The second and third elements together form a unit vector, and the proposed
	#		vent location for the next iteration will be at that direction with respect to
	#		the current proposed vent location.
	#		The way the unit vector is determined can be thought of as a crude approximation
	#		of the divergence of the cost function.
compare <- function(sv, obs, h, nlps, h_ratio){
	rsm <- (cg(sv, h*h_ratio))
	cr <- baf(sv, obs, nlps)

	rr = t(apply(X = rsm,  MARGIN = 1, FUN = baf, obs = obs, nlps = nlps))
	first_order_grad <- rr[,2]-cr[2]

	if(min(first_order_grad>0)){
		return(1)
	}else{
		first_order_grad[first_order_grad > 0] = 0
		direction = c(1,1,-1,-1)
		grad_y = (-1*direction[c(1,3)])%*%first_order_grad[c(1,3)]
		grad_x = (-1*direction[c(2,4)])%*%first_order_grad[c(2,4)]
		grad_unit = c(grad_x/(grad_x^2+grad_y^2)^0.5, grad_y/(grad_x^2+grad_y^2)^0.5)
		return(c(2,grad_unit))
	}
}
####################End of intermediate functions#################################

#################### Function name: gd_simplified ####################
# This function integrates the above functions, implements ANOTHER gradient descent
# method in the x-y plane, and estimates the source vent location.
# See notations in the file "demo_svl_2.0.R" for the description of this
# function, and how to set values for the input parameters.
gd_simplified <- function(sv, obs, runs, h, r, nlps, h_ratio, numb){

	obs = obs[numb,]
	tcoord <- as.data.frame(matrix(ncol=2))
	dec <- c()
	hl <- c()
	ihd <- h

	ir=1
	jg <- 0

	warns <- 0
	for(i in 1:runs){
			dec <- compare(sv, obs, h, nlps, h_ratio)
			if(dec[1]!= 1 && jg ==0){
					sv <- sv + h*dec[2:3]
					tcoord[i,] <- sv
					hl[i] <- h
					jg <- 0
			}else if(dec[1] != 1 && jg == 1){
					h <- h *(1 - r)
					sv <- sv + h*dec[2:3]
					tcoord[i,] <- sv
					hl[i] <- h
					jg <- 0
			}else if(dec[1] == 1 && h/ihd >= 0.0001){
				h = h * r
				hl[i] <- h
				jg <- 1
			}
		if(h < 0.1){break}
	}
	bd <- baf(sv, obs, nlps)
	rownames(tcoord) <- NULL

	output_sv = tcoord[nrow(tcoord),]
	output_ang = bd[1]

	fitted_results= fi2(obs, as.matrix(sv), output_ang)

	return(as.matrix(cbind(sv, output_ang, h, coef = t(fitted_results[c(2,3,4)]), ssr = fitted_results[1], rsquare = fitted_results[5])))
}
########################################## End of functions #####################################################

# References:
#	Gonzalez-Mellado, A. O., and S. De la Cruz-Reyna. "A simple semi-empirical approach to model thickness of
# ash-deposits for different eruption scenarios." Natural Hazards and Earth System Sciences 10.11 (2010): 2241.
# 	Yang Q, Bursik M. A new interpolation method to model thickness, isopachs, extent, and volume of tephra fall
# deposits. Bulletin of Volcanology, 2016, 78(10): 68.


# Machine Learning - Regressão
# Prevendo Notas de Matemática dos Participantes do ENEM

# Configurando o diretório de trabalho
setwd("~/pCloudDrive/Profissional/ciencia-de-dados/codenation.dev/desafio_nota_do_enem")
getwd()

library(dplyr) # Filtragens
#library(tidyr)
library(psych) # Scatterplot Matrix
library(e1071) # SVM
library(rpart) # RANDON FOREST
library(readr) # GERAR CSV

# ****************************************************
# ***                   DADOS                      ***
# ***                                              ***
# ****************************************************
# Etapa 1 - Coletando os dados
nota <- read.csv("train.csv")
notateste <- read.csv("test.csv")
nomes <- names(notateste)

# ****************************************************
# ***                   TREINO                     ***
# ***                                              ***
# ****************************************************
# Segmentando apenas os dados que temos no teste
nota = nota[c(nomes, "NU_NOTA_MT")]
treinando = nota %>% drop_na()
treinando$Q027 = NULL
treinando$TP_DEPENDENCIA_ADM_ESC = NULL
treinando$TP_ENSINO = NULL
any(is.na(treinando))
# ****************************************************
# ***                Padronizados                  ***
# ****************************************************
glimpse(treinando)
#Transformar para numérico
treinando$SG_UF_RESIDENCIA = as.numeric(treinando$SG_UF_RESIDENCIA)
treinando$TP_SEXO = as.numeric(treinando$TP_SEXO)
treinando$Q001 = as.numeric(treinando$Q001)
treinando$Q002 = as.numeric(treinando$Q002)
treinando$Q006 = as.numeric(treinando$Q006)
treinando$Q024 = as.numeric(treinando$Q024)
treinando$Q025 = as.numeric(treinando$Q025)
treinando$Q026 = as.numeric(treinando$Q026)
treinando$Q047 = as.numeric(treinando$Q047)
treinando$CO_PROVA_CN = as.numeric(treinando$CO_PROVA_CN)
treinando$CO_PROVA_CH = as.numeric(treinando$CO_PROVA_CH)
treinando$CO_PROVA_LC = as.numeric(treinando$CO_PROVA_LC)
treinando$CO_PROVA_MT = as.numeric(treinando$CO_PROVA_MT)
nota = treinando
treinando = treinando[c(-1)]

glimpse(treinando)

# ****************************************************
# ***                   TESTE                      ***
# ***                                              ***
# ****************************************************

# Criar variável de segurança
testando = notateste
testando$Q027 = NULL
testando$TP_DEPENDENCIA_ADM_ESC = NULL
testando$TP_ENSINO = NULL

## LIMPEZA Retirando valores NA da tabela
testando = testando %>% drop_na()
any(is.na(testando))

# Transformar variaveis em numeric
testando$SG_UF_RESIDENCIA = as.numeric(testando$SG_UF_RESIDENCIA)
testando$TP_SEXO = as.numeric(testando$TP_SEXO)
testando$Q001 = as.numeric(testando$Q001)
testando$Q002 = as.numeric(testando$Q002)
testando$Q006 = as.numeric(testando$Q006)
testando$Q024 = as.numeric(testando$Q024)
testando$Q025 = as.numeric(testando$Q025)
testando$Q026 = as.numeric(testando$Q026)
testando$Q047 = as.numeric(testando$Q047)
testando$CO_PROVA_CN = as.numeric(testando$CO_PROVA_CN)
testando$CO_PROVA_CH = as.numeric(testando$CO_PROVA_CH)
testando$CO_PROVA_LC = as.numeric(testando$CO_PROVA_LC)
testando$CO_PROVA_MT = as.numeric(testando$CO_PROVA_MT)
notateste = testando
testando = testando[c(-1)]

# Vizualizar se os dados estão em estado numérico para envolver no algoritmo
glimpse(testando)

# ****************************************************
# ***               MODELOS DE ML                  ***
# ***                                              ***
# ****************************************************

##Regressão linear multipla
# Etapa 3: Treinando o Modelo (usando os dados de treino)
modelo <- lm(NU_NOTA_MT ~ ., data = treinando)

# Visualizando os coeficientes
modelo

previsao1 <- predict(modelo)
View(previsao1)
#treinando$Prev = previsao1

# Etapa 4: Avaliando a Performance do Modelo
# Mais detalhes sobre o modelo
summary(modelo)
####### -> 48%

# Lembre-se que correlação não implica causalidade

#### RANDONFOREST (Arvores de decisão) ####
trainset = treinando
testset = testando

modelo_rf_v1 = rpart(NU_NOTA_MT ~ ., data = trainset, control = rpart.control(cp = .0005))
summary(modelo_rf_v1)
# Previsões nos dados de teste
tree_pred = predict(modelo_rf_v1, testset)

enviotree = notateste[1]
enviotree$NU_NOTA_MT = tree_pred

write.csv(enviotree, "answer.csv", row.names = FALSE)
### 92,65 %


#!/usr/bin/Rscript

##
# Calculate the mean-pairwise gsi for groups "B" and "C" for every migration
# simulation.
#
# Note: the 'main' function relies on filenames to identify the tree files to
# read and the paramater values for each simulation (so, if you change
# 'make_samples.py' you'll need to change the main function too )
##

library(stringr)
library(plyr)
library(genealogicalSorting)

permute_gsi <- function(observed_value, tr, imap, nperm=1000){
    one_rep <- function(){
      tr$tip.label <- sample(tr$tip.label)
      assigns <- imap[tr$tip.label,2]
      return(mean(gsi(tr, 0, assigns)$gsi))
    }
    distr <- replicate(nperm, one_rep())
    return(mean(distr > observed_value))
}

pwgsi <- function(tr, imap, nperm=1000){
    assigns <- imap[tr$tip.label,2]
    pw_gsi <- mean(gsi(tr, 0, assigns)$gsi)
    p_val <- permute_gsi(pw_gsi, tr, imap,nperm)
    return(c(pwgsi=pw_gsi, P=p_val))
}

per_tree <- function(tr, imap, nperm=1000){
    dropped_tr <- drop.tip(tr, as.character(1:10))
    res <- pwgsi(dropped_tr, imap=imap)
    return(res)
}

is_mig <- function(fname) {
    str_split(fname, "_")[[1]][1] == "migration"
}

main <- function(){

    tfiles <- paste("trees/", Filter(is_mig, list.files("trees/")), sep="")
    m_rate <- as.numeric(sapply(tfiles, str_extract,  "\\d+(\\.\\d{1,2})?"))
    nfiles <- length(tfiles)

    message(paste("loading data from", nfiles, "tree files..."))
    all_trees <- do.call("c", lapply(tfiles, read.tree))
    n <- length(all_trees)

    sp_map <- read.table("sample.imap")
    message("calcuating gsi...\n")
    res <- laply(all_trees, per_tree, sp_map, .progress="text")

    message("writing data... \n")
    df0 <- data.frame(res,  m = rep(m_rate, each=n/nfiles))
    write.csv(df0, "data/gsi_migration.csv", row.names=FALSE)
}

if(!interactive()){
    main()
}


library("ggplot2")
library("ggdendro")
library("pheatmap")
library("RColorBrewer")
library("R.utils")

wd = "~/work/abe516/project3"
setwd(wd)
full.df = read.table("dist.txt", header = T, check.names = F)
colors = colorRampPalette(rev(brewer.pal(9, "Blues")) )(255)
pheatmap(full.df, col = colors, filename = file.path(wd, "full-heatmap.png"))

# Subsample full dataset
num.samples = 50
num.iter = 10
for (i in 1:num.iter) {
  print(paste("Sample", i))
  sample.cols = sample(nrow(full.df), num.samples)
  df = full.df[sample.cols, sample.cols]
  fit = hclust(as.dist(df), method = "ward.D2")
  dg = ggdendro::ggdendrogram(fit, rotate=F)
  ggsave(file = file.path(wd, paste0("sample", i, ".png")),
         limitsize = FALSE, width = 10, height = 5, plot = dg)
}

# HOT
hot.df = read.table("hot-dist.txt", header = T, check.names = F)
hot.fit = hclust(as.dist(hot.df), method = "ward.D2")
dg = ggdendro::ggdendrogram(hot.fit, rotate=F)
ggsave(file = file.path(wd, "hot.png"),
       limitsize = FALSE, width = 10, height = 5, plot = dg)
pheatmap(hot.df,
         col = colors,
         cutree_rows = 2,
         cutree_cols = 2,
         filename = file.path(wd, "hot-heatmap.png"))

# ICU
icu.full = read.table("icu-dist.txt", header = T, check.names = F)
icu.samples = sample(nrow(icu.full), 50)
icu.df = icu.full[icu.samples, icu.samples]
icu.fit = hclust(as.dist(icu.df), method = "ward.D2")
dg = ggdendro::ggdendrogram(icu.fit, rotate=F)
ggsave(file = file.path(wd, "icu.png"),
       limitsize = FALSE, width = 10, height = 5, plot = dg)
pheatmap(icu.df,
         col = colors,
         filename = file.path(wd, "icu-heatmap.png"))


#######################
# R script for the Treeweb       #
# cross-community analysis       #
# analysis reported in main text #
#######################################

# load libraries
library(spdep)
library(ade4)
library(adespatial)
library(plyr)
library(vegan)
library(dplyr)
library(tidyr)
library(DHARMa)
library(ggplot2)
library(gridExtra)

# set working directory
setwd("~/PostDoc_Ghent/Synthesis_3/treeweb_community/")

# load plot data
plot_info <- read.csv("data/synthesis_expldata_raw.csv", stringsAsFactors = FALSE)
plot_xy <- read.csv("data/plot_xy.csv")

# load community data
comms <- c("bird", "bat", "spider", "opiliones", "carabid", "isopods", "diplopod", "herb", "vegetation")
comm_l <- lapply(comms, function(x) read.csv(paste0("data/treeweb_", x, "_format.csv")))
names(comm_l) <- comms

# remove the species with no record in the bird table
comm_l$bird <- comm_l$bird[,-which(colSums(comm_l$bird) == 0)]
# divide herbivore by sampling effort
comm_l$herb <- cbind(comm_l$herb[,1], comm_l$herb[,-1] / plot_info$specrich)
# remove genus level id in isopods
comm_l$isopods <- comm_l$isopods[,-ncol(comm_l$isopods)]

# define spatial neighbors based on distance and fragment ID
xx <- dnearneigh(as.matrix(plot_xy[,c("X", "Y")]), d1 = 0, d2 = 450)
xx[[45]] <- as.integer(c(36, 37)) # plot 45 is in the same fragment than plots 36 and 37

# distance between neighbors
dist_xx <- nbdists(xx, as.matrix(plot_xy[,c("X", "Y")]))
# weight the neighbors by their distance relative to the maximum distance
fdist <- lapply(dist_xx, function(x) 1 - x/max(dist(as.matrix(plot_xy[,c("X", "Y")]))))

# generate listw
listw_xx <- nb2listw(xx, glist = fdist, zero.policy = TRUE)

######### Part 1: co-inertia analysis #######

############## define helper functions
### this first function compute the percent
### of variation explained by the first two
### co-inertia axis, arguments are:
# @pair: a character string of the pair of taxa, like: "bird_bat"
# @nf_1, nf_2, nf_coia : an integer, the number of axis to keep in the PCAs and for the coinertia
# @std : a logical, whether to hellinger-standardize the community data
get_percent_explained <- function(pair, nf_1 = 2, nf_2 = 2, nf_coia = 2, std = TRUE){
  # get names of the two taxa
  taxa_1 <- strsplit(pair, "_")[[1]][1]
  taxa_2 <- strsplit(pair, "_")[[1]][2]
  # get community matrices from the list of communities
  comm1 <- comm_l[[taxa_1]][,-1]
  comm2 <- comm_l[[taxa_2]][,-1]
  # if needed standardize the matrices
  if(std){
    comm1 <- decostand(comm1, method = "hellinger")
    comm2 <- decostand(comm2, method = "hellinger")
  }
  # run the PCA
  dudi_1 <- dudi.pca(comm1, scannf = FALSE, nf = nf_1)
  dudi_2 <- dudi.pca(comm2, scannf = FALSE, nf = nf_2)
  # run the co-inertia
  coia <- coinertia(dudi_1, dudi_2, scannf = FALSE, nf = nf_coia)
  # % of explained dev in the first two axis
  eigs <- coia$eig
  percent <- sum(eigs[1:2]) / sum(eigs)

  return(percent)

}

### a function to get the RV metric together with p-value generated via spatial null model
### arguments to the function are:
# @pair: a character, the pair of taxa like: "bird_bat"
# @nf_1, nf_2, nf_coia: an integer, the number of axis to keep for the PCAs and the co-inertia
# @std: a logical, whether to hellinger-standardize the community
# @repet: the number of spatially null communities to generate
get_coia_rv <- function(pair, nf_1 = 2, nf_2 = 2, nf_coia = 2, std = TRUE, nrepet = 99){

  taxa_1 <- strsplit(pair, "_")[[1]][1]
  taxa_2 <- strsplit(pair, "_")[[1]][2]

  comm1 <- comm_l[[taxa_1]][,-1]
  comm2 <- comm_l[[taxa_2]][,-1]

  if(std){
    comm1 <- decostand(comm1, method = "hellinger")
    comm2 <- decostand(comm2, method = "hellinger")
  }

  dudi_1 <- dudi.pca(comm1, scannf = FALSE, nf = nf_1)
  dudi_2 <- dudi.pca(comm2, scannf = FALSE, nf = nf_2)

  coia <- coinertia(dudi_1, dudi_2, scannf = FALSE, nf = nf_coia)
  # get a vector of RV values from null communities
  rv_null <- get_null_coia_rv(pair, nf_1, nf_2, nf_coia, nrepet)
  # compute the p value, which is the proportion of simulation with RV values larger than the observed one
  pval_null <- 1 - (sum(coia$RV >= rv_null) / nrepet)

  out <- data.frame(rv = coia$RV, pval = pval_null, col = ifelse(pval_null < 0.05, "red", "black"))

  return(out)
}

# function to get nrepet null RV values based on moran spectral randomization
get_null_coia_rv <- function(pair, nf_1 = 2, nf_2 = 2, nf_coia = 2, nrepet = 99){

  taxa_1 <- strsplit(pair, "_")[[1]][1]
  taxa_2 <- strsplit(pair, "_")[[1]][2]

  comm1 <- comm_l[[taxa_1]][,-1]
  comm2 <- comm_l[[taxa_2]][,-1]
  # compute moran spectral randomization on the community based on listw object
  comm_n1 <- msr(comm1, listw_xx, method = "singleton", nrepet = nrepet)
  comm_n2 <- msr(comm2, listw_xx, method = "singleton", nrepet = nrepet)
  # run the PCA and co-inertia analysis on these MSR generated communities
  dudi_n1 <- lapply(comm_n1, function(x) dudi.pca(x, scannf = FALSE, nf = 2))
  dudi_n2 <- lapply(comm_n2, function(x) dudi.pca(x, scannf = FALSE, nf = 2))

  coia_n <- mapply(function(x, y) coinertia(x, y, scannf = FALSE, nf = 2), x = dudi_n1, y = dudi_n2, SIMPLIFY = FALSE)
  # output the RV value
  rv_null <- ldply(coia_n, function(x) x$RV)

  return(rv_null$V1)
}

########## end of helper function definition

# all potential pairs of communities
pairs <- outer(comms, comms, paste, sep = "_")
pairs_u <- pairs[upper.tri(pairs)]

# define the trophic levels
tl <- data.frame(taxa = comms,
                 tl = c(4, 4, 3, 3, 3, 2, 2, 2, 1))

# put all pairs in a data frame together with their trophic distance
pairs_d <- data.frame(pairs = pairs_u, stringsAsFactors = FALSE)
pairs_d <- separate(pairs_d, "pairs", c("from", "to"), sep = "_", remove = FALSE)

pairs_d <- merge(pairs_d, tl, by.x = "from", by.y = "taxa", sort = FALSE)
pairs_d <- merge(pairs_d, tl, by.x = "to", by.y = "taxa", sort=FALSE)
pairs_d$dist <- with(pairs_d, sqrt((tl.x - tl.y)**2))

## get percent explained variation of the first two axis in the coinertia
tt <- sapply(pairs_u, function(x) get_percent_explained(x))

# RV value between each comms
rv_all <- sapply(pairs_u, function(x) get_coia_rv(x, nrepet = 9999), simplify = FALSE) # this can take time to run depending on the number of repetitions
# some data wraggling to put te results in a plotable format
rv_all <- rbind.fill(rv_all)
rv_all$pair <- pairs_u
rv_all <- merge(rv_all, pairs_d, by.x = "pair", by.y = "pairs")
rv_all <- arrange(rv_all, dist, pair)
# some re-coding for nicer plots
rv_all$to <- recode(rv_all$to, bat = "bats", herb = "herbivores", diplopod = "millipedes",
                    carabid = "carabids", opiliones = "harvestmen", spider = "spiders",
                    isopods = "woodlice", vegetation = "vegetation")

rv_all$from <- recode(rv_all$from, bat = "bats", herb = "herbivores", diplopod = "millipedes",
                      carabid = "carabids", opiliones = "harvestmen", spider = "spiders",
                      isopods = "woodlice", vegetation = "vegetation")

rv_all <- unite(rv_all, "pair", c(to, from), sep =":")
rv_all$pair <- factor(rv_all$pair)
rv_all$x <- 1:36

# the plot (figure X in the manuscript)
gg_rv <- ggplot(rv_all, aes(x=x, y=rv, fill=col)) +
  geom_bar(stat = "identity", width = 0.75) +
  scale_fill_brewer(type = "qual",palette = "Set1",
                    labels = c("no sig. relation", "sig. relation"),
                    name = "RV permutation\ntest:") +
  geom_vline(xintercept = c(7.5, 25.5, 34.5), linetype = "dashed") +
  annotate("text", 2.75, y = 0.6, label = "Trophic\ndistance: 0") +
  annotate("text", 18.75, y = 0.6, label = "Trophic\ndistance: 1") +
  annotate("text", 27.75, y = 0.6, label = "Trophic\ndistance: 2") +
  annotate("text", 35.5, 0.6, label = "3") +
  scale_x_continuous(breaks = 1:36, labels = rv_all$pair, expand = c(0, 0)) +
  scale_y_continuous(limits = c(0, 0.67), expand = c(0, 0)) +
  coord_flip() +
  theme(axis.text.x = element_text(hjust = 0),
        axis.text.y = element_text(vjust = 0.25)) +
  labs(x = "Pairwise community comparison",
       y = "RV value") +
  theme_bw()

ggsave("figures/coin_rv.png", gg_rv)

################# Part 2: multiple co-inertia analysis ########

# an helper function to run the mcoa
# the arguments are:
# @web: a character, the web of interaction to quantify like "bird_bat_spider"
# @nf: an integer, the number of axis to keep
# @option: a character, the weighing used, see ?mcoa for the different options
# @std: a logical, whether to hellinger-standardize the data
mcoa_run <- function(web, nf = 2, option = "inertia", std = TRUE){
  comm_name <- strsplit(web, "_")[[1]]

  comms <- lapply(comm_name, function(x) comm_l[[x]])

  if(std){
    comms <- lapply(comms, function(comm) decostand(comm[,-1], "hellinger"))
  }

  # grab number of columns
  nb_col <- sapply(comms, function(x) ncol(x))

  # put all together
  comms_all <- do.call(cbind, comms)
  # create ktab object
  kt <- ktab.data.frame(comms_all, nb_col,
                        tabnames = comm_name)

  # run mcoa
  m <- mcoa(kt, option = option, nf = nf, scannf = FALSE)

  return(m)
}

## first web of interaction: all groups except for the bats:
web_1 <- "bird_spider_opiliones_carabid_isopods_diplopod_herb_vegetation"
m_1 <- mcoa_run(web_1)

## compute the distance of each group from the plot synthetic scores
plot_info$x <- plot_xy$X
plot_info$y <- plot_xy$Y
vhb_xy <- m_1$Tl1
vhb_xy$id_plot <- rep(1:53, length(web_1))
vhb_xy$ref_x <- m_1$SynVar[rep(1:53, length(web_1)),1]
vhb_xy$ref_y <- m_1$SynVar[rep(1:53, length(web_1)),2]
vhb_xy$d <- with(vhb_xy, sqrt((Axis1-ref_x) ** 2 + (Axis2-ref_y) ** 2))
vhb_xy %>%
  group_by(id_plot) %>%
  summarise(d = sum(d)) %>%
  left_join(plot_info[,c(1,13,14,15, 16, 17)], by = "id_plot") -> vhb_dd

# fit a glm to this
m_vhb <- glm(d ~ fragm_std * speccomb, vhb_dd, family = Gamma(link="log"), contrasts = list(speccomb = "contr.sum"))

## look at residuals
ss <- simulateResiduals(m_vhb)
plot(ss) # good
testSpatialAutocorrelation(ss, x = plot_info$x, y = plot_info$y) # no spatial autocorrelation

## anova
anova(m_vhb, test = "Chisq")

## plot the composition effects
### a new data frame to derive the model predictions
newdat <- expand.grid(speccomb = unique(plot_info$speccomb), fragm_std = 0)

# augment per diversification path
newdat2 <- newdat[c(2, 5, 3, 4, 7, 5, 1, 4, 6, 3, 1, 4),]
newdat2$tree <- rep(c("fsyl", "qrob", "qrub"), each = 4)
# compute the model predictions
newdat2$pred <- predict(m_vhb, newdata = newdat2, type = "response")
newdat2$se <- predict(m_vhb, newdata = newdat2, type = "response", se.fit = TRUE)$se.fit

# some refinments for ordering the species somposition as we want them
newdat2$speccomb <- factor(newdat2$speccomb, levels = c("fsyl","qrob","qrub","fsyl_qrob","fsyl_qrub","qrob_qrub","all"))
vhb_dd$speccomb <- factor(vhb_dd$speccomb, levels = c("fsyl","qrob","qrub","fsyl_qrob","fsyl_qrub","qrob_qrub","all"))

# the plots
gg_syl <- ggplot(subset(vhb_dd, speccomb %in% c("fsyl", "fsyl_qrob", "fsyl_qrub", "all"))) +
  geom_jitter(aes(x=speccomb, y = d), width = 0.1) +
  geom_point(data=subset(newdat2, tree == "fsyl"), aes(x=speccomb, y=pred), color="red", size = 2.5) +
  geom_linerange(data = subset(newdat2, tree == "fsyl"), aes(x=speccomb, ymin = pred-2*se, ymax=pred+2*se), color="red") +
  geom_hline(yintercept = exp(coef(m_vhb)[1]), linetype = "dashed", color = "red") +
  scale_x_discrete(labels = c("beech", "beech +\nped. oak", "beech +\nred oak", "all")) +
  labs(x = "", y = "", title = "(a)") +
  ylim(c(2.25, 8.55))

gg_rob <- ggplot(subset(vhb_dd, speccomb %in% c("qrob", "fsyl_qrob", "qrob_qrub", "all"))) +
  geom_jitter(aes(x=speccomb, y = d), width = 0.1) +
  geom_point(data=subset(newdat2, tree == "qrob"), aes(x=speccomb, y=pred), color="red", size = 2.5) +
  geom_linerange(data = subset(newdat2, tree == "qrob"), aes(x=speccomb, ymin = pred-2*se, ymax=pred+2*se), color="red") +
  geom_hline(yintercept = exp(coef(m_vhb)[1]), linetype = "dashed", color = "red") +
  scale_x_discrete(labels = c("ped. oak", "beech +\nped. oak", "ped. oak +\nred oak", "all")) +
  labs(x = "", y = "", title = "(b)") +
  ylim(c(2.25, 8.55))

gg_rub <- ggplot(subset(vhb_dd, speccomb %in% c("qrub", "fsyl_qrub", "qrob_qrub", "all"))) +
  geom_jitter(aes(x=speccomb, y = d), width = 0.1) +
  geom_point(data=subset(newdat2, tree == "qrub"), aes(x=speccomb, y=pred), color="red", size = 2.5) +
  geom_linerange(data = subset(newdat2, tree == "qrub"), aes(x=speccomb, ymin = pred-2*se, ymax=pred+2*se), color="red") +
  geom_hline(yintercept = exp(coef(m_vhb)[1]), linetype = "dashed", color = "red") +
  labs(x = "", y = "", title = "(c)") +
  scale_x_discrete(labels = c("red oak", "beech +\nred oak", "ped. oak +\nred oak", "all")) +
  ylim(c(2.25, 8.55))

gg_all <- grid.arrange(gg_syl, gg_rob, gg_rub, nrow = 3, bottom = "Tree species composition", left = "Community distance")

ggsave("figures/mcoa_composition_2.png", gg_all, width = 4, height = 8)

# supporting information graph displaying
# the distance of all taxa from the plot centroid scores
# this will be done separately for all diversification pathways

## for fsyl paths
vhb_syl <- subset(vhb_xy, id_plot %in% id_fsyl)
vhb_syl <- arrange(vhb_syl, id_plot)

vhb_syl <- merge(vhb_syl, plot_info, by = "id_plot")
vhb_syl$speccomb <- factor(vhb_syl$speccomb, levels = c("fsyl", "fsyl_qrob", "fsyl_qrub", "all"))

gg_syl <- ggplot(vhb_syl, aes(x=ref_x, y=ref_y, group=id_plot, color = fragm_std)) +
  geom_point(aes(x = Axis1, y = Axis2), size = 0.5) +
  geom_segment(aes(xend=Axis1, yend=Axis2)) +
  geom_point() +
  facet_wrap(~ speccomb, ncol = 4) +
  scale_color_viridis(name = "Fragm.\nintensity", option = "C",
                      limits = c(-1.7, 2.45)) +
  labs(x="", y = "", title = "(a)") +
  xlim(c(-1.4, 0.5)) +
  ylim(c(-2.3,2.5))

## now for qrob
vhb_rob <- subset(vhb_xy, id_plot %in% id_qrob)
vhb_rob <- arrange(vhb_rob, id_plot)

vhb_rob <- merge(vhb_rob, plot_info, by = "id_plot")
vhb_rob$speccomb <- factor(vhb_rob$speccomb, levels = c("qrob", "fsyl_qrob", "qrob_qrub", "all"))

gg_rob <- ggplot(vhb_rob, aes(x=ref_x, y=ref_y, group=id_plot, color = fragm_std)) +
  geom_point(aes(x = Axis1, y = Axis2), size = 0.5) +
  geom_segment(aes(xend=Axis1, yend=Axis2)) +
  geom_point() +
  facet_wrap(~ speccomb, ncol = 4) +
  scale_color_viridis(name = "Fragm.\nintensity", option = "C",
                      limits = c(-1.7, 2.45)) +
  labs(x="", y = "", title = "(b)")  +
  xlim(c(-1.4, 0.5)) +
  ylim(c(-2.3,2.5))

## now for qrub
vhb_rub <- subset(vhb_xy, id_plot %in% id_qrub)
vhb_rub <- arrange(vhb_rub, id_plot)

vhb_rub <- merge(vhb_rub, plot_info, by = "id_plot")
vhb_rub$speccomb <- factor(vhb_rub$speccomb, levels = c("qrub", "fsyl_qrub", "qrob_qrub", "all"))

gg_rub <- ggplot(vhb_rub, aes(x=ref_x, y=ref_y, group=id_plot, color = fragm_std)) +
  geom_point(aes(x = Axis1, y = Axis2), size = 0.5) +
  geom_segment(aes(xend=Axis1, yend=Axis2)) +
  geom_point() +
  facet_wrap(~ speccomb, ncol = 4) +
  scale_color_viridis(name = "Fragm.\nintensity", option = "C",
                      limits = c(-1.7, 2.45)) +
  labs(x="", y = "", title = "(c)")  +
  xlim(c(-1.4, 0.5)) +
  ylim(c(-2.3,2.5))

# tweaking to get common legend
g_legend<-function(a.gplot){
  tmp <- ggplot_gtable(ggplot_build(a.gplot))
  leg <- which(sapply(tmp$grobs, function(x) x$name) == "guide-box")
  legend <- tmp$grobs[[leg]]
  return(legend)}

mylegend<-g_legend(gg_rob)

# the plot
gg_all <- grid.arrange(arrangeGrob(gg_syl + theme(legend.position = "none"),
                                   gg_rob + theme(legend.position = "none"),
                                   gg_rub + theme(legend.position = "none"), nrow = 3),
                       mylegend, ncol = 2, widths = c(9, 2),
                       bottom = "MCOA axis 1", left = "MCOA axis 2")

ggsave("figures/mcoa_plot.png", gg_all, width = 8, height = 8)

########## end of the main script ############


#' Covariance and Correlation
#'
#' Covariance and (pearson) correlation.
#'
#' @section Communication:
#' The operation is completely local except for forming the crossproduct, which
#' is an \code{allreduce()} call, quadratic on the number of columns.
#'
#' @param x
#' A shaq.
#' @param y
#' At this time, this must be \code{NULL}.
#' @param use
#' NA handling rules, as with R's cov/cor functions.  At this time, only
#' "everything" is supported.
#' @param method
#' The cov/cor method. Currently only "pearson" is available.
#'
#' @return
#' A regular matrix.
#'
#' @examples
#' \dontrun{
#' library(kazaam)
#' x = ranshaq(runif, 10, 3)
#'
#' cov(x)
#' cor(x)
#'
#' finalize()
#' }
#'
#' @name cov
#' @rdname cov
NULL

covcor.check.y = function(y)
{
  if (!is.null(y))
    comm.stop("only supported when argument 'y' is NULL")
}

cov.shaq = function (x, y=NULL, use="everything", method="pearson")
{
  covcor.check.y(y)

  crossprod(scale(x, TRUE, FALSE)) / (nrow(x) - 1)
}

cor.shaq = function (x, y=NULL, use="everything", method="pearson")
{
  covcor.check.y(y)

  crossprod(scale(x, TRUE, TRUE)) / (nrow(x) - 1)
}

#' @rdname cov
#' @export
setMethod("cov", signature(x="shaq"), cov.shaq)

#' @rdname cov
#' @export
setMethod("cor", signature(x="shaq"), cor.shaq)


 ZGTSV Example Program Results

 Solution
 (  1.0000,  1.0000) (  3.0000, -1.0000) (  4.0000,  5.0000) ( -1.0000, -2.0000)
 (  1.0000, -1.0000)


#' @export
NiarPredictionAtt <- function(data,NiarTreeModel){
  Results = list()
  for(i in 1:nrow(data)){
    Results[i] <- FindTheBest(data[i,],NiarTreeModel)
  }

  #  root <- NiarTreeModel[[1]]
  # rootL <- NiarTreeModel$SonL
  # rootR <- NiarTreeModel$SonR
  # rootcase <- root$root
  # DiscValue <- rootcase[root$AttDiscriminant]
  # CasePrediction <- rootcase[nrow(rootcase)]
  #
  return(Results)
  #return(lapply(X=CaseToCheck, FindTheBest,NiarTreeModel))
}

#' @export
FindTheBest <- function(CaseToCheck,NiarTreeModel){
  root <- NiarTreeModel[[1]]
  rootcase <- root$root
  rootL <- NiarTreeModel$SonL
  rootR <- NiarTreeModel$SonR
  if (CaseToCheck[root$AttDiscriminant] <= rootcase[root$AttDiscriminant])
  {
    if(CaseToCheck[root$AttDiscriminant] == rootcase[root$AttDiscriminant])
    {
      c1 <- CaseToCheck[1:ncol(CaseToCheck)-1]
      c2 <- rootcase[1:ncol(rootcase)-1]
      if(DEuclidean1x1(c1,c2) == 0.0){
        return(rootcase[ncol(rootcase)])
      }else{
        if (is.null(rootL$SonL) == FALSE)
          root <- FindTheBest(CaseToCheck,rootL)
        else
          return(rootcase[ncol(rootcase)])
      }
    }
    else{
      if (is.null(rootL$SonL) == FALSE)
        root <- FindTheBest(CaseToCheck,rootL)
      else
        return(rootcase[ncol(rootcase)])
    }
  }
  else
  {
    if (is.null(rootR$SonR) == FALSE)
      root <- FindTheBest(CaseToCheck,rootR)
    else
      return(rootcase[ncol(rootcase)])
  }
}


# Compare Fst, LD change, Tajima's D change, pi change across populations. Identify regions with substantial change in multiple populations.
# set up for 50k windows

require(data.table)
require(vioplot)

################################
# read in data
################################

# fst: sliding window fst from ANGSD (GATK nodam2 sites)
dat1 <- fread('analysis/Can_40.Can_14.gatk.slide', col.names = c('region', 'CHROM', 'midPos', 'nloci', 'fst'), skip = 1) # output by angsd_fst.sh. skip headers.
dat2 <- fread('analysis/Lof_07.Lof_11.gatk.slide', col.names = c('region', 'CHROM', 'midPos', 'nloci', 'fst'), skip = 1)
dat3 <- fread('analysis/Lof_07.Lof_14.gatk.slide', col.names = c('region', 'CHROM', 'midPos', 'nloci', 'fst'), skip = 1)
dat4 <- fread('analysis/Lof_11.Lof_14.gatk.slide', col.names = c('region', 'CHROM', 'midPos', 'nloci', 'fst'), skip = 1)

dat1[, pop := 'can']
dat2[, pop := 'lof0711']
dat3[, pop := 'lof0714']
dat4[, pop := 'lof1114']

fst <- rbind(dat1, dat2, dat3, dat4)
fst[, region := NULL]
setnames(fst, c('midPos', 'CHROM'), c('WinCenter', 'chr'))
fst[, WinCenter := WinCenter - 1] # adjust to match the others

# fst: sliding window fst from ANGSD (GATK nodam2 unlinked sites)
fst.unl <- fread('output/fst_siteshuffle.angsd.gatk.csv.gz') # output by angsd_fst_siteshuffle_null_stats.r
setnames(fst.unl, c('CHROM', 'midPos', 'fst', 'nloci', 'p'), c('chr', 'WinCenter', 'fst.unl', 'nloci.unl', 'fst.p'))

# change in ld
ldwide <- fread('analysis/ld_change_region_5e4_ngsLD.gatk.csv.gz') # from ngsLD_region_change.r
ld <- rbind(ldwide[, .(pop = 'can', chr, WinCenter = pos1mid1, ld_diff = ld_diff_Can)], # reformat to wide
            ldwide[, .(pop = 'lof0711', chr, WinCenter = pos1mid1, ld_diff = ld_diff_Lof0711)],
            ldwide[, .(pop = 'lof0714', chr, WinCenter = pos1mid1, ld_diff = ld_diff_Lof0714)],
            ldwide[, .(pop = 'lof1114', chr, WinCenter = pos1mid1, ld_diff = ld_diff_Lof1114)])

# change in pi and D: sliding window pi from ANGSD (GATK nodam2 unlinked sites)
dat1 <- fread('analysis/theta_change_region_50000.Can_40.Can_14.gatk.unlinked.csv.gz', drop = 1) # from angsd_theta_siteshuffle_null.r
dat2 <- fread('analysis/theta_change_region_50000.Lof_07.Lof_11.gatk.unlinked.csv.gz', drop = 1)
dat3 <- fread('analysis/theta_change_region_50000.Lof_07.Lof_14.gatk.unlinked.csv.gz', drop = 1)
dat4 <- fread('analysis/theta_change_region_50000.Lof_11.Lof_14.gatk.unlinked.csv.gz', drop = 1)

dat1[, pop := 'can']
dat2[, pop := 'lof0711']
dat3[, pop := 'lof0714']
dat4[, pop := 'lof1114']

piD <- rbind(dat1, dat2, dat3, dat4)
piD[, ':='(tW1 = NULL, tP1 = NULL, tD1 = NULL, tW2 = NULL, tP2 = NULL, tD2 = NULL, tWd = NULL)]
setnames(piD, c('Chromo'), c('chr'))

# pi and Tajima's D p-values
piD.p <- fread('analysis/theta_siteshuffle.angsd.gatk.csv.gz') # output by angsd_theta_siteshuffle_null_stats.r
piD.p <- piD.p[, .(chr = Chromo, WinCenter, tPd.p, tDd.p, pop)]

# merge
bins <- merge(fst, fst.unl, by=c('chr', 'WinCenter', 'pop'), all=TRUE)
bins <- merge(bins, ld, by=c('chr', 'WinCenter', 'pop'), all=TRUE)
bins <- merge(bins, piD, by=c('chr', 'WinCenter', 'pop'), all=TRUE)
bins <- merge(bins, piD.p, by=c('chr', 'WinCenter', 'pop'), all=TRUE)

nrow(bins)
nrow(fst)
nrow(fst.unl)
nrow(ld)
nrow(piD)
nrow(piD.p)

###################################################################
## prep across populations
## trim to non-overlapping windows, reshape, and calc percentiles
###################################################################
# fst and fst unlinked
binswidefst <- dcast(bins[(WinCenter %% 25000) == 0, .(chr, WinCenter, pop, nloci, nloci.unl, fst, fst.unl, fst.p)], chr + WinCenter ~ pop, value.var = c('fst', 'fst.unl', 'fst.p', 'nloci', 'nloci.unl'))
nrow(binswidefst)
binswidefst[, fstperc.can := ecdf(fst_can)(fst_can)]
binswidefst[, fstperc.lof0711 := ecdf(fst_lof0711)(fst_lof0711)]
binswidefst[, fstperc.lof0714 := ecdf(fst_lof0714)(fst_lof0714)]
binswidefst[, fstperc.lof1114 := ecdf(fst_lof1114)(fst_lof1114)]

binswidefst[, fstunlperc.can := ecdf(fst.unl_can)(fst.unl_can)]
binswidefst[, fstunlperc.lof0711 := ecdf(fst.unl_lof0711)(fst.unl_lof0711)]
binswidefst[, fstunlperc.lof0714 := ecdf(fst.unl_lof0714)(fst.unl_lof0714)]
binswidefst[, fstunlperc.lof1114 := ecdf(fst.unl_lof1114)(fst.unl_lof1114)]

# pi and theta change
binswidepiD <- dcast(bins[(WinCenter %% 25000) == 0, .(chr, WinCenter, pop, nloci.unl, tPd, tDd, tPd.p, tDd.p)], chr + WinCenter ~ pop, value.var = c('tPd', 'tDd', 'tPd.p', 'tDd.p'))
nrow(binswidepiD)
binswidepiD[, tPdperc.can := ecdf(tPd_can)(tPd_can)]
binswidepiD[, tPdperc.lof0711 := ecdf(tPd_lof0711)(tPd_lof0711)]
binswidepiD[, tPdperc.lof0714 := ecdf(tPd_lof0714)(tPd_lof0714)]
binswidepiD[, tPdperc.lof1114 := ecdf(tPd_lof1114)(tPd_lof1114)]

binswidepiD[, tDdperc.can := ecdf(tDd_can)(tDd_can)]
binswidepiD[, tDdperc.lof0711 := ecdf(tDd_lof0711)(tDd_lof0711)]
binswidepiD[, tDdperc.lof0714 := ecdf(tDd_lof0714)(tDd_lof0714)]
binswidepiD[, tDdperc.lof1114 := ecdf(tDd_lof1114)(tDd_lof1114)]

# ld change
# pi and theta
binswideld <- dcast(bins[(WinCenter %% 25000) == 0, .(chr, WinCenter, pop, nloci.unl, ld_diff)], chr + WinCenter ~ pop, value.var = c('ld_diff'))
setnames(binswideld, c('can', 'lof0711', 'lof0714', 'lof1114'), c('ld_diff_can', 'ld_diff_lof0711', 'ld_diff_lof0714', 'ld_diff_lof1114'))
nrow(binswideld)
binswideld[, ld_diffperc.can := ecdf(ld_diff_can)(ld_diff_can)]
binswideld[, ld_diffperc.lof0711 := ecdf(ld_diff_lof0711)(ld_diff_lof0711)]
binswideld[, ld_diffperc.lof0714 := ecdf(ld_diff_lof0714)(ld_diff_lof0714)]
binswideld[, ld_diffperc.lof1114 := ecdf(ld_diff_lof1114)(ld_diff_lof1114)]

# combine all together
binswide <- merge(binswidefst, binswidepiD, by = c('chr', 'WinCenter'), all = TRUE)
binswide <- merge(binswide, binswideld, by = c('chr', 'WinCenter'), all = TRUE)

nrow(binswide)
nrow(binswidefst)
nrow(binswidepiD)
nrow(binswideld)

######################
## Biplots of change
## Within same kind of metric, across populations
######################

# make plots of shared outliers
cols <- c('grey', 'purple', 'red', 'black')

#quartz(height=6, width=6)
outfile=paste('figures/region_change_across_pops_5e4.png', sep='')
outfile
png(height=6, width=6, units='in', res=300, file=outfile)
par(mfrow=c(4, 3), las=1, mai=c(0.5, 0.6, 0.1, 0.1), tcl=-0.2, mgp=c(1.5,0.4,0), cex.axis=0.7)

# fst
binswide[, plot(fst.unl_can, fst.unl_lof0711, cex=0.2, col=cols[1], pch=16)]
binswide[fstunlperc.can > 0.99 & fstunlperc.lof0711 > 0.99, points(fst.unl_can, fst.unl_lof0711, pch=16, cex=0.4, col = cols[2])]
binswide[fstunlperc.can > 0.99 & fstunlperc.lof0711 > 0.99 & fstunlperc.lof0714 > 0.99, points(fst.unl_can, fst.unl_lof0711, pch=16, cex=0.4, col = cols[3])]
binswide[fstunlperc.lof1114 > 0.99, points(fst.unl_can, fst.unl_lof0711, pch=16, cex=0.4, col = cols[4])]

legend('bottomright', col=cols, pch=16, legend=c('Locus', '1% outlier in both comparisons', '1% outlier in 3 comparisons', '1% outlier in lof1114'), cex = 0.3)

binswide[, plot(fst.unl_can, fst.unl_lof0714, cex=0.2, col=cols[1], pch=16)]
binswide[fstunlperc.can > 0.99 & fstunlperc.lof0714 > 0.99, points(fst.unl_can, fst.unl_lof0714, pch=16, cex=0.4, col = cols[2])]
binswide[fstunlperc.can > 0.99 & fstunlperc.lof0711 > 0.99 & fstunlperc.lof0714 > 0.99, points(fst.unl_can, fst.unl_lof0714, pch=16, cex=0.4, col = cols[3])]
binswide[fstunlperc.lof1114 > 0.99, points(fst.unl_can, fst.unl_lof0711, pch=16, cex=0.4, col = cols[4])]

binswide[, plot(fst.unl_lof0711, fst.unl_lof0714, cex=0.2, col=cols[1], pch=16)]
binswide[fstunlperc.lof0711 > 0.99 & fstunlperc.lof0714 > 0.99, points(fst.unl_lof0711, fst.unl_lof0714, pch=16, cex=0.4, col = cols[2])]
binswide[fstunlperc.can > 0.99 & fstunlperc.lof0711 > 0.99 & fstunlperc.lof0714 > 0.99, points(fst.unl_lof0711, fst.unl_lof0714, pch=16, cex=0.4, col = cols[3])]
binswide[fstunlperc.lof1114 > 0.99, points(fst.unl_lof0711, fst.unl_lof0714, pch=16, cex=0.4, col = cols[4])]

# pi change
binswide[, plot(tPd_can, tPd_lof0711, cex=0.2, col=cols[1], pch=16)]
binswide[(tPdperc.can > 0.995 & tPdperc.lof0711 > 0.995) | (tPdperc.can < 0.005 & tPdperc.lof0711 < 0.005),
            points(tPd_can, tPd_lof0711, pch=16, cex=0.4, col = cols[2])]
binswide[(tPdperc.can > 0.995 & tPdperc.lof0711 > 0.995 & tPdperc.lof0714 > 0.995) | (tPdperc.can < 0.005 & tPdperc.lof0711 < 0.005 & tPdperc.lof0714 < 0.005),
            points(tPd_can, tPd_lof0711, pch=16, cex=0.4, col = cols[3])]
binswide[tPdperc.lof1114 > 0.995 | tPdperc.lof1114 < 0.005, points(tPd_can, tPd_lof0711, pch=16, cex=0.4, col = cols[4])]

binswide[, plot(tPd_can, tPd_lof0714, cex=0.2, col=cols[1], pch=16)]
binswide[(tPdperc.can > 0.995 & tPdperc.lof0714 > 0.995) | (tPdperc.can < 0.005 & tPdperc.lof0714 < 0.005),
            points(tPd_can, tPd_lof0714, pch=16, cex=0.4, col = cols[2])]
binswide[(tPdperc.can > 0.995 & tPdperc.lof0711 > 0.995 & tPdperc.lof0714 > 0.995) | (tPdperc.can < 0.005 & tPdperc.lof0711 < 0.005 & tPdperc.lof0714 < 0.005),
            points(tPd_can, tPd_lof0714, pch=16, cex=0.4, col = cols[3])]
binswide[tPdperc.lof1114 > 0.995 | tPdperc.lof1114 < 0.005, points(tPd_can, tPd_lof0711, pch=16, cex=0.4, col = cols[4])]

binswide[, plot(tPd_lof0711, tPd_lof0714, cex=0.2, col=cols[1], pch=16)]
binswide[(tPdperc.lof0711 > 0.995 & tPdperc.lof0714 > 0.995) | (tPdperc.lof0711 < 0.005 & tPdperc.lof0714 < 0.005), points(tPd_lof0711, tPd_lof0714, pch=16, cex=0.4, col = cols[2])]
binswide[(tPdperc.can > 0.995 & tPdperc.lof0711 > 0.995 & tPdperc.lof0714 > 0.995) | (tPdperc.can < 0.005 & tPdperc.lof0711 < 0.005 & tPdperc.lof0714 < 0.005),
            points(tPd_lof0711, tPd_lof0714, pch=16, cex=0.4, col = cols[3])]
binswide[tPdperc.lof1114 > 0.995 | tPdperc.lof1114 < 0.005, points(tPd_lof0711, tPd_lof0714, pch=16, cex=0.4, col = cols[4])]

# tajd change
binswide[, plot(tDd_can, tDd_lof0711, cex=0.2, col=cols[1], pch=16)]
binswide[(tDdperc.can > 0.995 & tDdperc.lof0711 > 0.995) | (tDdperc.can < 0.005 & tDdperc.lof0711 < 0.005),
            points(tDd_can, tDd_lof0711, pch=16, cex=0.4, col = cols[2])]
binswide[(tDdperc.can > 0.995 & tDdperc.lof0711 > 0.995 & tDdperc.lof0714 > 0.995) | (tDdperc.can < 0.005 & tDdperc.lof0711 < 0.005 & tDdperc.lof0714 < 0.005),
            points(tDd_can, tDd_lof0711, pch=16, cex=0.4, col = cols[3])]
binswide[tDdperc.lof1114 > 0.995 | tDdperc.lof1114 < 0.005, points(tDd_can, tDd_lof0711, pch=16, cex=0.4, col = cols[4])]

binswide[, plot(tDd_can, tDd_lof0714, cex=0.2, col=cols[1], pch=16)]
binswide[(tDdperc.can > 0.995 & tDdperc.lof0714 > 0.995) | (tDdperc.can < 0.005 & tDdperc.lof0714 < 0.005),
            points(tDd_can, tDd_lof0714, pch=16, cex=0.4, col = cols[2])]
binswide[(tDdperc.can > 0.995 & tDdperc.lof0711 > 0.995 & tDdperc.lof0714 > 0.995) | (tDdperc.can < 0.005 & tDdperc.lof0711 < 0.005 & tDdperc.lof0714 < 0.005),
            points(tDd_can, tDd_lof0714, pch=16, cex=0.4, col = cols[3])]
binswide[tDdperc.lof1114 > 0.995 | tDdperc.lof1114 < 0.005, points(tDd_can, tDd_lof0711, pch=16, cex=0.4, col = cols[4])]

binswide[, plot(tDd_lof0711, tDd_lof0714, cex=0.2, col=cols[1], pch=16)]
binswide[(tDdperc.lof0711 > 0.995 & tDdperc.lof0714 > 0.995) | (tDdperc.lof0711 < 0.005 & tDdperc.lof0714 < 0.005),
            points(tDd_lof0711, tDd_lof0714, pch=16, cex=0.4, col = cols[2])]
binswide[(tDdperc.can > 0.995 & tDdperc.lof0711 > 0.995 & tDdperc.lof0714 > 0.995) | (tDdperc.can < 0.005 & tDdperc.lof0711 < 0.005 & tDdperc.lof0714 < 0.005),
            points(tDd_lof0711, tDd_lof0714, pch=16, cex=0.4, col = cols[3])]
binswide[tDdperc.lof1114 > 0.995 | tDdperc.lof1114 < 0.005, points(tDd_lof0711, tDd_lof0714, pch=16, cex=0.4, col = cols[4])]

# LD change
binswide[, plot(ld_diff_can, ld_diff_lof0711, cex=0.2, col=cols[1], pch=16)]
binswide[ld_diffperc.can > 0.99 & ld_diffperc.lof0711 > 0.99, points(ld_diff_can, ld_diff_lof0711, pch=16, cex=0.4, col = cols[2])]
binswide[ld_diffperc.can > 0.99 & ld_diffperc.lof0711 > 0.99 & ld_diffperc.lof0714 > 0.99, points(ld_diff_can, ld_diff_lof0711, pch=16, cex=0.4, col = cols[3])]
binswide[ld_diffperc.lof1114 > 0.99, points(ld_diff_can, ld_diff_lof0711, pch=16, cex=0.4, col = cols[4])]

binswide[, plot(ld_diff_can, ld_diff_lof0714, cex=0.2, col=cols[1], pch=16)]
binswide[ld_diffperc.can > 0.99 & ld_diffperc.lof0714 > 0.99, points(ld_diff_can, ld_diff_lof0714, pch=16, cex=0.4, col = cols[2])]
binswide[ld_diffperc.can > 0.99 & ld_diffperc.lof0711 > 0.99 & ld_diffperc.lof0714 > 0.99, points(ld_diff_can, ld_diff_lof0714, pch=16, cex=0.4, col = cols[3])]
binswide[ld_diffperc.lof1114 > 0.99, points(ld_diff_can, ld_diff_lof0711, pch=16, cex=0.4, col = cols[4])]

binswide[, plot(ld_diff_lof0711, ld_diff_lof0714, cex=0.2, col=cols[1], pch=16)]
binswide[ld_diffperc.lof0711 > 0.99 & ld_diffperc.lof0714 > 0.99, points(ld_diff_lof0711, ld_diff_lof0714, pch=16, cex=0.4, col = cols[2])]
binswide[ld_diffperc.can > 0.99 & ld_diffperc.lof0711 > 0.99 & ld_diffperc.lof0714 > 0.99, points(ld_diff_lof0711, ld_diff_lof0714, pch=16, cex=0.4, col = cols[3])]
binswide[ld_diffperc.lof1114 > 0.99, points(ld_diff_lof0711, ld_diff_lof0714, pch=16, cex=0.4, col = cols[4])]

dev.off()

##########################################
## Examine and output genomic regions
## with shared changes across populations
##########################################

## fst
# check outlier regions
binswide[fstunlperc.can > 0.99 & fstunlperc.lof0711 > 0.99 & fstunlperc.lof0714 > 0.99 & (fstunlperc.lof1114 < 0.99 | is.na(fstunlperc.lof1114)),
            .(chr, WinCenter, nloci.unl_can, nloci.unl_lof0711, fst.unl_can, fst.unl_lof0711, fst.unl_lof0714, fst.unl_lof1114, fst.p_can, fst.p_lof0711, fst.p_lof0714, fst.p_lof1114)]

# binomial test for shared outlier regions
binswide[fstunlperc.can > 0.99 & fstunlperc.lof0711 > 0.99 & (fstunlperc.lof1114 < 0.99 | is.na(fstunlperc.lof1114)), .(chr, WinCenter, nloci_can, nloci_lof0711)] # shared outliers can 0711
binswide[fstunlperc.can > 0.99 & fstunlperc.lof0714 > 0.99 & (fstunlperc.lof1114 < 0.99 | is.na(fstunlperc.lof1114)), .(chr, WinCenter, nloci_can, nloci_lof0711)] # shared outliers can 0714

nrow(binswide)
n12 <- binswide[!is.na(fstunlperc.can) & !is.na(fstunlperc.lof0711), .N] # number of evaluated regions (can to lof0711)
n13 <- binswide[!is.na(fstunlperc.can) & !is.na(fstunlperc.lof0714), .N] # number of evaluated regions (can to lof0714)
x1 <- binswide[fstunlperc.can > 0.99 & (fstunlperc.lof1114 < 0.99 | is.na(fstunlperc.lof1114)), .N] # outliers in can
x2 <- binswide[fstunlperc.lof0711 > 0.99 & (fstunlperc.lof1114 < 0.99 | is.na(fstunlperc.lof1114)), .N] # outliers in lof0711
x3 <- binswide[fstunlperc.lof0714 > 0.99 & (fstunlperc.lof1114 < 0.99 | is.na(fstunlperc.lof1114)), .N] # outliers in lof0714
x12 <- binswide[fstunlperc.can > 0.99 & fstunlperc.lof0711 > 0.99 & (fstunlperc.lof1114 < 0.99 | is.na(fstunlperc.lof1114)), .N] # shared outliers can 0711
x13 <- binswide[fstunlperc.can > 0.99 & fstunlperc.lof0714 > 0.99 & (fstunlperc.lof1114 < 0.99 | is.na(fstunlperc.lof1114)), .N] # shared outliers can 0714
x1/n12 * x2/n12 * n12 # expected number shared can 0711
x12 # number shared
binom.test(x12, n12, p = x1/n12 * x2/n12, alternative = 'two.sided')

x1/n13 * x3/n13 * n13 # expected number shared can 0714
x13 # number shared
binom.test(x13, n13, p = x1/n13 * x3/n13, alternative = 'two.sided')

## pi change
# check outlier regions
binswide[(tPdperc.can > 0.995 & tPdperc.lof0711 > 0.995 & tPdperc.lof0714 > 0.995 & (tPdperc.lof1114 < 0.995 | is.na(tPdperc.lof1114))) |
              (tPdperc.can < 0.005 & tPdperc.lof0711 < 0.005 & tPdperc.lof0714 < 0.005 & (tPdperc.lof1114 > 0.005 | is.na(tPdperc.lof1114))),
            .(chr, WinCenter, nloci.unl_can, nloci.unl_lof0711, tPd_can, tPd_lof0711, tPd_lof0714, tPd_lof1114, tPd.p_can, tPd.p_lof0711, tPd.p_lof0714, tPd.p_lof1114)]

# binomial test for shared outlier regions
nrow(binswide)
n12 <- binswide[!is.na(tPdperc.can) & !is.na(tPdperc.lof0711), .N] # number of evaluated regions (can to lof0711)
n13 <- binswide[!is.na(tPdperc.can) & !is.na(tPdperc.lof0714), .N] # number of evaluated regions (can to lof0714)
x1 <- binswide[(tPdperc.can > 0.995 & (tPdperc.lof1114 < 0.995 | is.na(tPdperc.lof1114))) |
                    tPdperc.can < 0.005 & (tPdperc.lof1114 > 0.005 | is.na(tPdperc.lof1114)), .N] # outliers in can
x2 <- binswide[(tPdperc.lof0711 > 0.995 & (tPdperc.lof1114 < 0.995 | is.na(tPdperc.lof1114))) |
                    (tPdperc.lof0711 < 0.005 & (tPdperc.lof1114 > 0.005 | is.na(tPdperc.lof1114))), .N] # outliers in lof0711
x3 <- binswide[(tPdperc.lof0714 > 0.995 & (tPdperc.lof1114 < 0.995 | is.na(tPdperc.lof1114))) |
                    (tPdperc.lof0714 < 0.005 & (tPdperc.lof1114 > 0.005 | is.na(tPdperc.lof1114))), .N] # outliers in lof0714
x12 <- binswide[(tPdperc.can > 0.995 & tPdperc.lof0711 > 0.995 & (tPdperc.lof1114 < 0.995 | is.na(tPdperc.lof1114))) |
                     (tPdperc.can < 0.005 & tPdperc.lof0711 < 0.005 & (tPdperc.lof1114 > 0.005 | is.na(tPdperc.lof1114))), .N] # shared outliers can 0711
x13 <- binswide[(tPdperc.can > 0.995 & tPdperc.lof0714 > 0.995 & (tPdperc.lof1114 < 0.995 | is.na(tPdperc.lof1114))) |
                     (tPdperc.can < 0.005 & tPdperc.lof0714 < 0.005 & (tPdperc.lof1114 > 0.005 | is.na(tPdperc.lof1114))), .N] # shared outliers can 0714
x1/n12 * x2/n12 * n12 # expected number shared can 0711
x12 # number shared
binom.test(x12, n12, p = x1/n12 * x2/n12, alternative = 'two.sided')

x1/n13 * x3/n13 * n13 # expected number shared can 0714
x13 # number shared
binom.test(x13, n13, p = x1/n13 * x3/n13, alternative = 'two.sided')

## D change
# check outlier regions
binswide[(tDdperc.can > 0.995 & tDdperc.lof0711 > 0.995 & tDdperc.lof0714 > 0.995 & (tDdperc.lof1114 < 0.995 | is.na(tDdperc.lof1114))) |
              (tDdperc.can < 0.005 & tDdperc.lof0711 < 0.005 & tDdperc.lof0714 < 0.005 & (tDdperc.lof1114 > 0.005 | is.na(tDdperc.lof1114))),
            .(chr, WinCenter, nloci.unl_can, nloci.unl_lof0711, tDd_can, tDd_lof0711, tDd_lof0714, tDd_lof1114, tDd.p_can, tDd.p_lof0711, tDd.p_lof0714, tDd.p_lof1114)]

# binomial test for shared outlier regions
nrow(binswide)
n12 <- binswide[!is.na(tDdperc.can) & !is.na(tDdperc.lof0711), .N] # number of evaluated regions (can to lof0711)
n13 <- binswide[!is.na(tDdperc.can) & !is.na(tDdperc.lof0714), .N] # number of evaluated regions (can to lof0714)
x1 <- binswide[(tDdperc.can > 0.995 & (tDdperc.lof1114 < 0.995 | is.na(tDdperc.lof1114))) |
                    tDdperc.can < 0.005 & (tDdperc.lof1114 > 0.005 | is.na(tDdperc.lof1114)), .N] # outliers in can
x2 <- binswide[(tDdperc.lof0711 > 0.995 & (tDdperc.lof1114 < 0.995 | is.na(tDdperc.lof1114))) |
                    (tDdperc.lof0711 < 0.005 & (tDdperc.lof1114 > 0.005 | is.na(tDdperc.lof1114))), .N] # outliers in lof0711
x3 <- binswide[(tDdperc.lof0714 > 0.995 & (tDdperc.lof1114 < 0.995 | is.na(tDdperc.lof1114))) |
                    (tDdperc.lof0714 < 0.005 & (tDdperc.lof1114 > 0.005 | is.na(tDdperc.lof1114))), .N] # outliers in lof0714
x12 <- binswide[(tDdperc.can > 0.995 & tDdperc.lof0711 > 0.995 & (tDdperc.lof1114 < 0.995 | is.na(tDdperc.lof1114))) |
                     (tDdperc.can < 0.005 & tDdperc.lof0711 < 0.005 & (tDdperc.lof1114 > 0.005 | is.na(tDdperc.lof1114))), .N] # shared outliers can 0711
x13 <- binswide[(tDdperc.can > 0.995 & tDdperc.lof0714 > 0.995 & (tDdperc.lof1114 < 0.995 | is.na(tDdperc.lof1114))) |
                     (tDdperc.can < 0.005 & tDdperc.lof0714 < 0.005 & (tDdperc.lof1114 > 0.005 | is.na(tDdperc.lof1114))), .N] # shared outliers can 0714
x1/n12 * x2/n12 * n12 # expected number shared can 0711
x12 # number shared
binom.test(x12, n12, p = x1/n12 * x2/n12, alternative = 'two.sided')

x1/n13 * x3/n13 * n13 # expected number shared can 0714
x13 # number shared
binom.test(x13, n13, p = x1/n13 * x3/n13, alternative = 'two.sided')

## LD Change
# check outlier regions
binswide[ld_diffperc.can > 0.99 & ld_diffperc.lof0711 > 0.99 & ld_diffperc.lof0714 > 0.99 & (ld_diffperc.lof1114 < 0.99 | is.na(ld_diffperc.lof1114)),
            .(chr, WinCenter, nloci.unl_can, nloci.unl_lof0711, ld_diff_can, ld_diff_lof0711, ld_diff_lof0714, ld_diff_lof1114)]

# binomial test for shared outlier regions
nrow(binswide)
n12 <- binswide[!is.na(ld_diffperc.can) & !is.na(ld_diffperc.lof0711), .N] # number of evaluated regions (can to lof0711)
n13 <- binswide[!is.na(ld_diffperc.can) & !is.na(ld_diffperc.lof0714), .N] # number of evaluated regions (can to lof0714)
x1 <- binswide[ld_diffperc.can > 0.99 & (ld_diffperc.lof1114 < 0.99 | is.na(ld_diffperc.lof1114)), .N] # outliers in can
x2 <- binswide[ld_diffperc.lof0711 > 0.99 & (ld_diffperc.lof1114 < 0.99 | is.na(ld_diffperc.lof1114)), .N] # outliers in lof0711
x3 <- binswide[ld_diffperc.lof0714 > 0.99 & (ld_diffperc.lof1114 < 0.99 | is.na(ld_diffperc.lof1114)), .N] # outliers in lof0714
x12 <- binswide[ld_diffperc.can > 0.99 & ld_diffperc.lof0711 > 0.99 & (ld_diffperc.lof1114 < 0.99 | is.na(ld_diffperc.lof1114)), .N] # shared outliers can 0711
x13 <- binswide[ld_diffperc.can > 0.99 & ld_diffperc.lof0714 > 0.99 & (ld_diffperc.lof1114 < 0.99 | is.na(ld_diffperc.lof1114)), .N] # shared outliers can 0714
x1/n12 * x2/n12 * n12 # expected number shared can 0711
x12 # number shared
binom.test(x12, n12, p = x1/n12 * x2/n12, alternative = 'two.sided')

x1/n13 * x3/n13 * n13 # expected number shared can 0714
x13 # number shared
binom.test(x13, n13, p = x1/n13 * x3/n13, alternative = 'two.sided')

## output FST outlier regions
out <- binswide[(fstunlperc.can > 0.99 & fstunlperc.lof0711 > 0.99 & fstunlperc.lof0714 > 0.99 & (fstunlperc.lof1114 < 0.99 | is.na(fstunlperc.lof1114))), ]

write.csv(out, file = gzfile('analysis/outlier_50kregions_shared_07-11-14_Can.csv.gz'), row.names = FALSE)

######################
## Biplots of change
## Within same population, across metrics
######################

cols <- c('grey', 'purple', 'red')

quartz(height=6, width=6)
outfile=paste('figures/region_change_across_metrics_', wdnm, '.png', sep='')
outfile
# png(height=6, width=6, units='in', res=300, file=outfile)
par(mfrow=c(4, 3), las=1, mai=c(0.5, 0.6, 0.1, 0.1), tcl=-0.2, mgp=c(2.8,0.4,0), cex.axis=0.7)
# frequency change vs. pi change
xlims <- bins[,range(freq_diff_CAN, freq_diff_0711, freq_diff_0714, na.rm=TRUE)]
ylims <- bins[,range(pi_diff_CAN, pi_diff_0711, pi_diff_0714, na.rm=TRUE)]
bins[freq_region_perc0711<=0.99 & pi_region_perc0711<=0.995 & pi_region_perc0711>=0.005, plot(freq_diff_0711, pi_diff_0711, cex=0.2, xlim=xlims, ylim=ylims, col=cols[1], pch=16, xlab='')]; title(xlab='freq_diff_0711', line=1.5)
bins[freq_region_perc0711>0.99 & pi_region_perc0711<=0.995 & pi_region_perc0711>=0.005, points(freq_diff_0711, pi_diff_0711, cex=0.2, col=cols[2], pch=16)]
bins[freq_region_perc0711<=0.99 & (pi_region_perc0711>0.995 | pi_region_perc0711<0.005), points(freq_diff_0711, pi_diff_0711, cex=0.2, col=cols[2], pch=16)]
bins[freq_region_perc0711>0.99 & (pi_region_perc0711>0.995 | pi_region_perc0711<0.005), points(freq_diff_0711, pi_diff_0711, cex=0.4, col=cols[3], pch=16)]

legend('topright', col=cols, pch=16, legend=c('Locus', '1% outlier in one metric', '1% outlier in both metrics'), cex=0.5)

bins[freq_region_perc0714<=0.99 & pi_region_perc0714<=0.995 & pi_region_perc0714>=0.005, plot(freq_diff_0714, pi_diff_0714, cex=0.2, xlim=xlims, ylim=ylims, col=cols[1], pch=16, xlab='')]; title(xlab='freq_diff_0714', line=1.5)
bins[freq_region_perc0714>0.99 & pi_region_perc0714<=0.995 & pi_region_perc0714>=0.005, points(freq_diff_0714, pi_diff_0714, cex=0.2, col=cols[2], pch=16)]
bins[freq_region_perc0714<=0.99 & (pi_region_perc0714>0.995 | pi_region_perc0714<0.005), points(freq_diff_0714, pi_diff_0714, cex=0.2, col=cols[2], pch=16)]
bins[freq_region_perc0714>0.99 & (pi_region_perc0714>0.995 | pi_region_perc0714<0.005), points(freq_diff_0714, pi_diff_0714, cex=0.4, col=cols[3], pch=16)]

bins[freq_region_percCAN<=0.99 & pi_region_percCAN<=0.995 & pi_region_percCAN>=0.005, plot(freq_diff_CAN, pi_diff_CAN, cex=0.2, xlim=xlims, ylim=ylims, col=cols[1], pch=16, xlab='')]; title(xlab='freq_diff_CAN', line=1.5)
bins[freq_region_percCAN>0.99 & pi_region_percCAN<=0.995 & pi_region_percCAN>=0.005, points(freq_diff_CAN, pi_diff_CAN, cex=0.2, col=cols[2], pch=16)]
bins[freq_region_percCAN<=0.99 & (pi_region_percCAN>0.995 | pi_region_percCAN<0.005), points(freq_diff_CAN, pi_diff_CAN, cex=0.2, col=cols[2], pch=16)]
bins[freq_region_percCAN>0.99 & (pi_region_percCAN>0.995 | pi_region_percCAN<0.005), points(freq_diff_CAN, pi_diff_CAN, cex=0.4, col=cols[3], pch=16)]

# freq vs. D
xlims <- bins[,range(freq_diff_CAN, freq_diff_0711, freq_diff_0714, na.rm=TRUE)]
ylims <- bins[,range(D_diff_CAN, D_diff_0711, D_diff_0714, na.rm=TRUE)]
bins[freq_region_perc0711<=0.99 & D_region_perc0711<=0.995 & D_region_perc0711>=0.005, plot(freq_diff_0711, D_diff_0711, cex=0.2, xlim=xlims, ylim=ylims, col=cols[1], pch=16, xlab='')]; title(xlab='freq_diff_0711', line=1.5)
bins[freq_region_perc0711>0.99 & D_region_perc0711<=0.995 & D_region_perc0711>=0.005, points(freq_diff_0711, D_diff_0711, cex=0.2, col=cols[2], pch=16)]
bins[freq_region_perc0711<=0.99 & (D_region_perc0711>0.995 | D_region_perc0711<0.005), points(freq_diff_0711, D_diff_0711, cex=0.2, col=cols[2], pch=16)]
bins[freq_region_perc0711>0.99 & (D_region_perc0711>0.995 | D_region_perc0711<0.005), points(freq_diff_0711, D_diff_0711, cex=0.4, col=cols[3], pch=16)]

legend('topright', col=cols, pch=16, legend=c('Locus', '1% outlier in one metric', '1% outlier in both metrics'), cex=0.5)

bins[freq_region_perc0714<=0.99 & D_region_perc0714<=0.995 & D_region_perc0714>=0.005, plot(freq_diff_0714, D_diff_0714, cex=0.2, xlim=xlims, ylim=ylims, col=cols[1], pch=16, xlab='')]; title(xlab='freq_diff_0714', line=1.5)
bins[freq_region_perc0714>0.99 & D_region_perc0714<=0.995 & D_region_perc0714>=0.005, points(freq_diff_0714, D_diff_0714, cex=0.2, col=cols[2], pch=16)]
bins[freq_region_perc0714<=0.99 & (D_region_perc0714>0.995 | D_region_perc0714<0.005), points(freq_diff_0714, D_diff_0714, cex=0.2, col=cols[2], pch=16)]
bins[freq_region_perc0714>0.99 & (D_region_perc0714>0.995 | D_region_perc0714<0.005), points(freq_diff_0714, D_diff_0714, cex=0.4, col=cols[3], pch=16)]

bins[freq_region_percCAN<=0.99 & D_region_percCAN<=0.995 & D_region_percCAN>=0.005, plot(freq_diff_CAN, D_diff_CAN, cex=0.2, xlim=xlims, ylim=ylims, col=cols[1], pch=16, xlab='')]; title(xlab='freq_diff_CAN', line=1.5)
bins[freq_region_percCAN>0.99 & D_region_percCAN<=0.995 & D_region_percCAN>=0.005, points(freq_diff_CAN, D_diff_CAN, cex=0.2, col=cols[2], pch=16)]
bins[freq_region_percCAN<=0.99 & (D_region_percCAN>0.995 | D_region_percCAN<0.005), points(freq_diff_CAN, D_diff_CAN, cex=0.2, col=cols[2], pch=16)]
bins[freq_region_percCAN>0.99 & (D_region_percCAN>0.995 | D_region_percCAN<0.005), points(freq_diff_CAN, D_diff_CAN, cex=0.4, col=cols[3], pch=16)]

# freq vs. ld
xlims <- bins[,range(freq_diff_CAN, freq_diff_0711, freq_diff_0714, na.rm=TRUE)]
ylims <- bins[,range(ld_diff_CAN, ld_diff_0711, ld_diff_0714, na.rm=TRUE)]
bins[freq_region_perc0711<=0.99 & ld_region_perc0711<=0.99, plot(freq_diff_0711, ld_diff_0711, cex=0.2, xlim=xlims, ylim=ylims, col=cols[1], pch=16, xlab='')]; title(xlab='freq_diff_0711', line=1.5)
bins[freq_region_perc0711>0.99 & ld_region_perc0711<=0.99, points(freq_diff_0711, ld_diff_0711, cex=0.2, col=cols[2], pch=16)]
bins[freq_region_perc0711<=0.99 & ld_region_perc0711>0.99, points(freq_diff_0711, ld_diff_0711, cex=0.2, col=cols[2], pch=16)]
bins[freq_region_perc0711>0.99 & ld_region_perc0711>0.99, points(freq_diff_0711, ld_diff_0711, cex=0.4, col=cols[3], pch=16)]

legend('topright', col=cols, pch=16, legend=c('Locus', '1% outlier in one metric', '1% outlier in both metrics'), cex=0.5)

bins[freq_region_perc0714<=0.99 & ld_region_perc0714<=0.99, plot(freq_diff_0714, ld_diff_0714, cex=0.2, xlim=xlims, ylim=ylims, col=cols[1], pch=16, xlab='')]; title(xlab='freq_diff_0714', line=1.5)
bins[freq_region_perc0714>0.99 & ld_region_perc0714<=0.99, points(freq_diff_0714, ld_diff_0714, cex=0.2, col=cols[2], pch=16)]
bins[freq_region_perc0714<=0.99 & ld_region_perc0714>0.99, points(freq_diff_0714, ld_diff_0714, cex=0.2, col=cols[2], pch=16)]
bins[freq_region_perc0714>0.99 & ld_region_perc0714>0.99, points(freq_diff_0714, ld_diff_0714, cex=0.4, col=cols[3], pch=16)]

bins[freq_region_percCAN<=0.99 & ld_region_percCAN<=0.99, plot(freq_diff_CAN, ld_diff_CAN, cex=0.2, xlim=xlims, ylim=ylims, col=cols[1], pch=16, xlab='')]; title(xlab='freq_diff_CAN', line=1.5)
bins[freq_region_percCAN>0.99 & ld_region_percCAN<=0.99, points(freq_diff_CAN, ld_diff_CAN, cex=0.2, col=cols[2], pch=16)]
bins[freq_region_percCAN<=0.99 & ld_region_percCAN>0.99, points(freq_diff_CAN, ld_diff_CAN, cex=0.2, col=cols[2], pch=16)]
bins[freq_region_percCAN>0.99 & ld_region_percCAN>0.99, points(freq_diff_CAN, ld_diff_CAN, cex=0.4, col=cols[3], pch=16)]

# ld vs. pi
xlims <- bins[,range(ld_diff_CAN, ld_diff_0711, ld_diff_0714, na.rm=TRUE)]
ylims <- bins[,range(pi_diff_CAN, pi_diff_0711, pi_diff_0714, na.rm=TRUE)]
bins[ld_region_perc0711<=0.99 & pi_region_perc0711<=0.995 & pi_region_perc0711>=0.005, plot(ld_diff_0711, pi_diff_0711, cex=0.2, xlim=xlims, ylim=ylims, col=cols[1], pch=16, xlab='')]; title(xlab='ld_diff_0711', line=1.5)
bins[ld_region_perc0711>0.99 & pi_region_perc0711<=0.995 & pi_region_perc0711>=0.005, points(ld_diff_0711, pi_diff_0711, cex=0.2, col=cols[2], pch=16)]
bins[ld_region_perc0711<=0.99 & (pi_region_perc0711>0.995 | pi_region_perc0711<0.005), points(ld_diff_0711, pi_diff_0711, cex=0.2, col=cols[2], pch=16)]
bins[ld_region_perc0711>0.99 & (pi_region_perc0711>0.995 | pi_region_perc0711<0.005), points(ld_diff_0711, pi_diff_0711, cex=0.4, col=cols[3], pch=16)]

legend('topright', col=cols, pch=16, legend=c('Locus', '1% outlier in one metric', '1% outlier in both metrics'), cex=0.5)

bins[ld_region_perc0714<=0.99 & pi_region_perc0714<=0.995 & pi_region_perc0714>=0.005, plot(ld_diff_0714, pi_diff_0714, cex=0.2, xlim=xlims, ylim=ylims, col=cols[1], pch=16, xlab='')]; title(xlab='ld_diff_0714', line=1.5)
bins[ld_region_perc0714>0.99 & pi_region_perc0714<=0.995 & pi_region_perc0714>=0.005, points(ld_diff_0714, pi_diff_0714, cex=0.2, col=cols[2], pch=16)]
bins[ld_region_perc0714<=0.99 & (pi_region_perc0714>0.995 | pi_region_perc0714<0.005), points(ld_diff_0714, pi_diff_0714, cex=0.2, col=cols[2], pch=16)]
bins[ld_region_perc0714>0.99 & (pi_region_perc0714>0.995 | pi_region_perc0714<0.005), points(ld_diff_0714, pi_diff_0714, cex=0.4, col=cols[3], pch=16)]

bins[ld_region_percCAN<=0.99 & pi_region_percCAN<=0.995 & pi_region_percCAN>=0.005, plot(ld_diff_CAN, pi_diff_CAN, cex=0.2, xlim=xlims, ylim=ylims, col=cols[1], pch=16, xlab='')]; title(xlab='ld_diff_CAN', line=1.5)
bins[ld_region_percCAN>0.99 & pi_region_percCAN<=0.995 & pi_region_percCAN>=0.005, points(ld_diff_CAN, pi_diff_CAN, cex=0.2, col=cols[2], pch=16)]
bins[ld_region_percCAN<=0.99 & (pi_region_percCAN>0.995 | pi_region_percCAN<0.005), points(ld_diff_CAN, pi_diff_CAN, cex=0.2, col=cols[2], pch=16)]
bins[ld_region_percCAN>0.99 & (pi_region_percCAN>0.995 | pi_region_percCAN<0.005), points(ld_diff_CAN, pi_diff_CAN, cex=0.4, col=cols[3], pch=16)]

dev.off()

###############################
## Plot FST in outlier regions
###############################
# read in Fsts
fstLof1 <- fread('analysis/Lof_07.Lof_11.fst.AB.gz', col.names = c('CHROM', 'POS', 'A', 'B')) # from angsd_fst.sh
fstLof2 <- fread('analysis/Lof_07.Lof_14.fst.AB.gz', col.names = c('CHROM', 'POS', 'A', 'B'))
fstCan <- fread('analysis/Can_40.Can_14.fst.AB.gz', col.names = c('CHROM', 'POS', 'A', 'B'))

# trim fsts to nodam2 loci
gatk <- fread('data_2020.05.07/GATK_filtered_SNP_no_dam2.tab', col.names = c('CHROM', 'POS', 'REF', 'ALT'))
fstLof1 <- merge(fstLof1, gatk[, .(CHROM, POS)])
fstLof2 <- merge(fstLof2, gatk[, .(CHROM, POS)])
fstCan <- merge(fstCan, gatk[, .(CHROM, POS)])

# calc fst
fstCan[, fst := A/B]
fstLof1[, fst := A/B]
fstLof2[, fst := A/B]

# list outlier 50kb regions to plot
dat <- data.table(CHROM = c('LG10', 'LG11', 'LG14', 'LG20'), POS = c( 13375000, 175000, 8425000, 16725000))

# make plot
ncol = 3
nrow = ceiling(nrow(dat)/ncol)
cols = c('black', 'blue', 'green') # can, 0711, 0714
rng <- 25000

par(mfrow = c(nrow, ncol), mai = c(0.3, 0.3, 0.4, 0.1), omi = c(0.3, 0.3, 0, 0))
for(i in 1:nrow(dat)){
  fstCan[CHROM == dat$CHROM[i] & abs(POS - dat$POS[i]) < rng, plot(POS/1e6, fst, xlab = 'Mb', ylab = 'Fst', main = dat$CHROM[i], col = cols[1])]
  fstLof1[CHROM == dat$CHROM[i] & abs(POS - dat$POS[i]) < rng, points(POS/1e6, fst, xlab = 'Mb', ylab = 'Fst', main = dat$CHROM[i], col = cols[2])]
  fstLof2[CHROM == dat$CHROM[i] & abs(POS - dat$POS[i]) < rng, points(POS/1e6, fst, xlab = 'Mb', ylab = 'Fst', main = dat$CHROM[i], col = cols[3])]
}


score <- function(input) {
    return(subroutine0(input))
}
subroutine0 <- function(input) {
    return(((0.5) + (subroutine1(input))) + (subroutine2(input)))
}
subroutine1 <- function(input) {
    if ((input[13]) >= (9.72500038)) {
        if ((input[13]) >= (16.0849991)) {
            var0 <- 1.36374998
        } else {
            var0 <- 1.96335626
        }
    } else {
        if ((input[6]) >= (6.94099998)) {
            var0 <- 3.74704218
        } else {
            var0 <- 2.48376822
        }
    }
    return(var0)
}
subroutine2 <- function(input) {
    if ((input[13]) >= (9.63000011)) {
        if ((input[13]) >= (19.2299995)) {
            var0 <- 1.05852115
        } else {
            var0 <- 1.68638802
        }
    } else {
        if ((input[6]) >= (7.43700027)) {
            var0 <- 3.95318961
        } else {
            var0 <- 2.40278864
        }
    }
    return(var0)
}


alist<-seq(100)
blist<-alist
blist[alist%%3==0]<-"Fizz"
blist[alist%%5==0]<-"Buzz"
blist[alist%%15==0]<-"FizzBuzz"
print(blist)


library(tidyverse)
library(viridis)
library(urbnmapr)

# Add data
out <- read.csv("douglas-acs-out.csv", header=TRUE, sep=",", quote="\'", colClass=c("character", "character", "numeric", "numeric"))
# Join with urbnmapr
out.data <- left_join(out, counties, by = "county_fips")

#################################################
# Pretty Breaks
pretty.breaks.out <- c(25,50,75,100)
# find min and max values of pop growth
minVal.out <- min(out.data$out_migration, na.rm = T)
maxVal.out <- max(out.data$out_migration, na.rm = T)
# compute pop growth labels
labels.out <- c()
brks.out <- c(minVal.out, pretty.breaks.out, maxVal.out)
# round the labels (actually, only the extremes)
labels <- c()
for(idx in 1:length(brks.out)){
  labels.out <- c(labels.out, paste0(round(brks.out[idx], 2),
  " – ",
  round(brks.out[idx + 1], 2)))
}
# Minus one label to remove the odd ending one
labels.out <- labels.out[1:length(labels.out)-1]

# Create new variable for fill
out.data$brks.out <- cut(out.data$out_migration,
  breaks = brks.out,
  labels = labels.out,
  include.lowest = T)

#################################################
# Out Migration Map
p <- ggplot() +
  # County Map
  geom_polygon(data = out.data, mapping = aes(x = long, y = lat, group = group,
    fill = out.data$brks.out), color = alpha("white", 1 / 2), size = 0.2) +
  # State Map
  geom_polygon(data = urbnmapr::states, mapping = aes(long, lat, group = group),
    fill = NA, color = "#7f7f7f", size = 0.25, alpha=0.5) +
  # Projection
  coord_map(projection = "polyconic") +
  scale_fill_viridis(
    option = "viridis",
    name = "ACS Out Migration, 2012-2016",
    discrete = T,
    direction = -1,
    begin=0.1,
    #end=0.9,
    guide = guide_legend(
      keyheight = unit(5, units = "mm"),
      title.position = 'top',
      reverse = F
  )) +
  # Theming
  theme_minimal(base_family = "Open Sans Condensed Light") +
  theme(
    legend.position = "bottom",
    legend.text.align = 0,
    legend.title.align = 0.5,
    plot.margin = unit(c(.5,.5,.2,.5), "cm")) +
  theme(
    axis.line = element_blank(),
    axis.text.x = element_blank(),
    axis.text.y = element_blank(),
    axis.ticks = element_blank(),
    axis.title.x = element_blank(),
    axis.title.y = element_blank(),
    panel.grid.major = element_blank(),
    panel.grid.minor = element_blank(),
    ) +
  theme(plot.title=element_text(family="Open Sans Condensed Bold", margin=margin(b=15))) +
  theme(plot.subtitle=element_text(family="Open Sans Condensed Light Italic")) +
  theme(plot.margin=unit(rep(0.5, 4), "cm")) +
  labs(x = "",
       y = "",
       title = "Douglas County loses population locally and to other metro areas",
       subtitle = "Out Migration for Douglas County, Nebraska. 2012-2016",
       caption = "Author: Chris Goodman (@cbgoodman), Data: U.S. Census Bureau American Community Survey")

ggsave(plot=p, "douglas-acs-out.png", width=(5*2), height=(4*2), units="in", dpi="retina")


#!/usr/bin/Rscript

library(ape)
library(coda)
library(ggplot2)
library(lubridate)
library(reshape2)

burnin <- 0.5
runstems <- paste0('beast/run', 1:4, '/pedv')

files <- paste(runstems, '.log', sep='')
runs <- lapply(files, read.table, header=TRUE, sep="\t")
prior <- read.table('beast/priors/pedv-priors.log', header=TRUE, sep='\t')
runsPrior <- c(runs, list(prior))

tmpf <- function(x) {
    diff(x$state[1:2])
}
thin <- sapply(runsPrior, tmpf)
all.elements.equal <- function(x) all.equal(x, rep(x[1], length.out=length(x)))
stopifnot(isTRUE(all.elements.equal(thin)))
thin <- thin[1]

tmpf <- function(x) {
    x[, 'state'] <- NULL
#    x[, 'clock.rate'] <- NULL
#    x[, 'posterior'] <- NULL
#    x[, 'coalescent'] <- NULL
#    x[, 'treeLikelihood'] <- NULL
#    x[, 'prior'] <- NULL
    x
}
runsp <- lapply(runsPrior, tmpf)

mobs <- lapply(runsp, mcmc, thin=thin)
ml <- mcmc.list(mobs[seq_along(runs)])
wstart <- burnin*end(ml)
wml <- window(ml, start=wstart)

i <- length(runs) + 1
pr <- mobs[[i]]
wstart <- burnin*end(pr)
wpr <- window(pr, start=wstart)

plotVars <- c("nonsIndel.aligned.fasta.gb.treeModel.rootHeight",
              "sIndel.aligned.fasta.gb.treeModel.rootHeight")
mml <- as.matrix(wml[, plotVars])
dpst <- data.frame(mml, Function='posterior')

mpr <- as.matrix(wpr[, plotVars])
dpr <- data.frame(mpr, Function='prior')

D <- rbind(dpst, dpr)
colnames(D) <- gsub('.aligned.fasta.gb.treeModel.rootHeight', '', colnames(D))
colnames(D) <- gsub('sIndel', 'S INDEL', colnames(D))
colnames(D) <- gsub('nonS', 'non-S', colnames(D))
M <- melt(D, id.vars='Function')

theme_set(theme_classic())

files <- c('nonsIndel-aligned.fasta-gb', 'sIndel-aligned.fasta-gb')
tmpf <- function(x){
    x <- read.dna(x, format='fasta')
    rownames(x)
}
snames <- unname(unlist(sapply(files, tmpf)))
snames <- strsplit(snames, '_')
sdates <- sapply(snames, '[[', 2)
sdates <- dmy(sdates)
tzero <- max(sdates)
xlabel <- paste("\nYears before", format(max(sdates), "%B %Y"))

firstOutbreak <- dmy("15-Apr-2013")
firstOutbreakYearsBeforeTzero <- as.duration(tzero - firstOutbreak)/dyears(1)

colScale <- c("prior"="#4477AA", "posterior"="#CC6677")

g <- ggplot(data=M, aes(x=value, color=Function))
g <- g + theme(legend.position='top')
g <- g + geom_vline(xintercept=firstOutbreakYearsBeforeTzero, col='grey')
g <- g + geom_density()
g <- g + scale_colour_manual(values=colScale)
g <- g + xlim(c(0,5))
g <- g + xlab(xlabel) + ylab('Density\n')
g <- g + facet_grid(variable~.)
ggsave('posteriors-and-priors.pdf', width=3.5)


#
# Clear
#
rm(list=ls())
setwd("/Users/ibrahimradwan/Development/InstaCartMarketBasketAnalysis/src/")

#
# Include libs
#
library(ggplot2)
library(dplyr)
library(tidyr)
library(treemap)
library(arules)
library(NbClust)
library(HSAUR)
library(cluster)
library(fpc)
library(clue)

#
# Load data files
#
aisles <- read.table("../dataset/aisles.csv", header=TRUE, sep=",", quote="\"", comment.char = "")
departments <- read.table("../dataset/departments.csv", header=TRUE, sep=",", quote="\"", comment.char = "")
orders <- read.table("../dataset/orders.csv", header=TRUE, sep=",", quote="\"", comment.char = "")
products <- read.table("../dataset/products.csv", header=TRUE, sep=",", quote="\"", comment.char = "")
order_products__prior <- read.table("../dataset/order_products__prior.csv", header=TRUE, sep=",", quote="\"", comment.char = "")
order_products__train <- read.table("../dataset/order_products__train.csv", header=TRUE, sep=",", quote="\"", comment.char = "")

test_orders <- filter(orders, eval_set=="test")
prior_orders <- filter(orders, eval_set=="prior")

reordered_products <- filter(order_products__prior, reordered==1) %>%
                      group_by(product_id) %>%
                      summarize(reorder_count=n()) %>%
                      left_join(products, by="product_id") %>%
                      arrange(desc(reorder_count))

#
# Clustering
#
prior_orders_clustring <- prior_orders %>%
                          select(order_dow, order_hour_of_day, days_since_prior_order)

levels(prior_orders_clustring$days_since_prior_order) <- c(levels(prior_orders_clustring$days_since_prior_order), -1)

prior_orders_clustring <- prior_orders_clustring %>%
                          mutate(days_since_prior_order=replace(days_since_prior_order, is.na(days_since_prior_order), -1))

clusters <- kmeans(prior_orders_clustring, 4)

prior_orders["cluster"] <- as.factor(clusters$cluster)

# predict test clusters
test_orders_clustering <- test_orders %>%
                          select(order_dow, order_hour_of_day, days_since_prior_order)
test_orders_clustering_classes <- cl_predict(clusters, test_orders_clustering)
test_orders["cluster"] <- as.factor(test_orders_clustering_classes)

prior_orders_clustring <- filter(orders, eval_set=="prior") %>%
                          select(order_dow, order_hour_of_day, days_since_prior_order) %>%
                          mutate(days_since_prior_order=replace(days_since_prior_order, is.na(days_since_prior_order), -1))

# Get top products per cluster
clusters_products <- prior_orders %>%
                     left_join(order_products__prior, by="order_id") %>%
                     group_by(cluster)

clusters_products2 <- clusters_products %>%
                      select(cluster, product_id) %>%
                      group_by(cluster, product_id) %>%
                      summarize(cluster_products_count=n())

clusters_products3 <- clusters_products %>%
                      summarize(cluster_total_products_count=n())

clusters_products <- clusters_products2 %>%
                     right_join(clusters_products3)

# User average order products count
user_avg_products_count <- filter(orders, eval_set=="prior") %>%
                           left_join(order_products__prior, by="order_id") %>%
                           group_by(user_id, order_id) %>%
                           summarize(order_products_count=n()) %>%
                           group_by(user_id) %>%
                           summarize(products_count=as.integer(mean(order_products_count, na.rm=TRUE))) %>%
                           select(user_id, products_count)

# User reorder rate for his previously ordered products
user_products_reorder_count <- filter(orders, eval_set=="prior")  %>%
                               left_join(order_products__prior, by="order_id") %>%
                               group_by(user_id, product_id) %>%
                               summarize(product_reorder_count=n(), product_add_to_cart_order_avg=as.integer(mean(add_to_cart_order, na.rm=TRUE)))

users_prior_products <- left_join(test_orders, prior_orders, by="user_id") %>%
                        left_join(user_avg_products_count, by="user_id") %>%
                        left_join(order_products__prior, by=c("order_id.y" = "order_id")) %>%
                        inner_join(user_products_reorder_count) %>%
                        left_join(clusters_products, by=c("product_id")) %>%
                        inner_join(reordered_products, by="product_id") %>%
                        mutate(days_since_prior_order.x=replace(days_since_prior_order.x,is.na(days_since_prior_order.x), 0)) %>%
                        mutate(days_since_prior_order.y=replace(days_since_prior_order.y,is.na(days_since_prior_order.y), 0)) %>%
                        mutate(reorder_count=ifelse(abs(days_since_prior_order.x - days_since_prior_order.y) <= 5, 2, 1)) %>%
                        mutate(reorder_count=as.integer(reorder_count * product_reorder_count)) %>%
                        mutate(reorder_count=reorder_count) %>%
                        mutate(reorder_count=reorder_count + 100 * cluster_products_count / cluster_total_products_count) %>%
                        select(order_id.x, product_id, reorder_count, products_count) %>%
                        rename(order_id=order_id.x) %>%
                        group_by(order_id) %>%
                        arrange(order_id, desc(reorder_count)) %>%
                        distinct(product_id, .keep_all = TRUE) %>%
                        slice(1:products_count[1]) %>%
                        select(order_id, product_id) %>%
                        mutate(product_id = paste(product_id, collapse = " ")) %>%
                        distinct(order_id, .keep_all = TRUE) %>%
                        rename(products=product_id)

users_prior_products <- users_prior_products[c("order_id", "products")]

write.csv(users_prior_products, file="../dataset/submission.csv", row.names=FALSE, quote=FALSE)