#' Generates graphs, text files, and coordinates related to a given set of river data.
#' @param filename Name of the file to be processed.
#' @param directory Path in which outputs will be generated. If non-empty, it must contain "\\\\" or "/" between directories/files, and never "\\". An empty or invalid argument will result in files being generated in a temporary location.
#' @param overwrite Flag that determines whether existing files will be overwritten. If the files already exist and this value is FALSE, the program will stop and produce an error.
#' @return None. Output files are generated in the specified (or temporary) directory: \cr \cr
#' BoundaryPoints.csv - Contains keys that map to specific points in CartesianCoordinates.csv that comprise the boundary around a river’s floodplain.\cr \cr
#' CartesianCoordinates.csv - Contains comma-separated XYZ coordinates for the synthetic river valley. A separate program such as ArcGIS can use these points to generate a 3D model.\cr \cr
#' Data.csv - Contains coefficients of variation, averages, standard deviations, channel slope, and other important information.\cr \cr
#' CenterlineCurvature.png - Displays the curvature of the channel's centerline.\cr \cr
#' CenterlineCurvature.csv - Contains coordinate data that was visualized in CenterlineCurvature.png.\cr \cr
#' ValleySection.png - Displays the cross section of the channel and floodplain at their midway point.\cr \cr
#' ValleySection.csv - Contains coordinate data that was visualized in ValleySection.png.\cr \cr
#' GCS.png - Displays the geometric covariance structures of: bankfull width and thalweg elevation; thalweg elevation and the channel meander.\cr \cr
#' GCS.csv - Contains coordinate data that was visualized in GCS.png.\cr \cr
#' LongitudinalProfile.png - Displays the side view of the river which consists of valley top, valley floor, bank top, and thalweg elevation.\cr \cr
#' LongitudinalProfile.csv - Contains coordinate data that was visualized in LongitudinalProfile.png.\cr \cr
#' Planform.png - Displays the birds eye view of the river which consists of the channel meander, channel bank, valley floor, and valley top.\cr \cr
#' Planform.csv - Contains coordinate data that was visualized in Planform.png.\cr \cr
#' @import grDevices graphics stats utils
#' @examples
#' file <- system.file("extdata", "Input.txt", package="RiverBuilder")
#' riverbuilder(file, '', TRUE)
#' @source \url{http://pasternack.ucdavis.edu/research/projects/synthetic-river-valleys/}
#' @export
riverbuilder = function(filename, directory, overwrite){

if(!file.exists(filename))
	stop("File specified was not found.")

if(directory == '' || typeof(directory) != "character" || !dir.exists(directory))
{
	print("Empty or invalid argument for the directory parameter. Writing to a temporary location.")
	directory = tempdir()
}

file_outputs = c(
	"CenterlineCurvature.png",
	"ValleySection.png",
	"GCS.png",
	"LongitudinalProfile.png",
	"Planform.png",
	"BoundaryPoints.csv",
	"Data.csv",
	"CartesianCoordinates.csv",
	"CenterlineCurvature.csv",
	"ValleySection.csv",
	"GCS.csv",
	"LongitudinalProfile.csv",
	"Planform.csv"
	)

graph_names = c(
	"Centerline Curvature",
	"Cross Section",
	"Geometric Covariance Structures",
	"Longitudinal Profile",
	"Planform"
	)

river_properties = c(
	"Meandering Centerline Function",
	"Centerline Curvature Function",
	"Bankfull Width Function",
	"Thalweg Elevation Function",
	"Left Floodplain Function",
	"Right Floodplain Function",
	"Cross-Sectional Shape"
	)

function_types = c(
	"SIN_SQ",
	"SIN",
	"COS",
	"LINE",
	"PERL"
	)

crossSectionalShapes = c(
	"SU",
	"AU",
	"TZ"
	)

for(i in seq(from=1, to=length(file_outputs), by=1))
{
	coordinate_file = paste(directory, "/", file_outputs[i], sep="")
	if(file.exists(coordinate_file))
	{
		# Remove the file from the directory to avoid appending to the previous data
		if(overwrite)
			file.remove(coordinate_file)
		# Stop program if user wishes to not overwrite files
		else
			stop(paste("One or more output files already exist(s) in '", directory, "'. Program exit.", sep=""))
	}
}

# Generate a random positive or negative value with absolute value < 1 (Perlin function)
random = function()
{
	Zr <<- (Ar * Zr + Cr) %% Mr
	return(Zr / Mr - 0.5)
}

# Return a double value that might involve the constant PI
evaluateNumerical = function(input)
{
	# If the value contains PI, store PI or simplify the expression containing it
	if(grepl("PI", input))
	{
		# The input is "PI", so store the value of pi
		if(input == "PI")
			return(pi)
		else # The input is of the form (a*)PI(/b), where a and/or b are given
		{
			# Ensure that the input is a string. If it isn't, coerce it into a string
			if(typeof(input) != "character")
				input = as.character(input)
			# Acquire the length of the input string for parsing and to avoid seg faults
			length = length(strsplit(input, "")[[1]])
			a = b = ""
			j = 1

			# a is not given
			if(substring(input, 1, 2) == "PI")
			{
				a = "1"
				j = j + 3
			}
			# a is given
			else
			{
				while(substring(input, j, j) != "*")
				{
					a = paste(a, substring(input, j, j), sep="")
					j = j + 1
				}
				j = j + 4
			}

			# b is not given
			if(j > length)
				b = "1"
			# b is given
			else
				b = paste(b, substring(input, j, length), sep="")

			return(as.double(a) * pi / as.double(b))
		}
	}
	# The value is a numerical constant, so just store it
	else
		return(as.double(input))
}

# Store the function that was assigned to a sub-reach variability parameter
storeFunction = function(variable, input)
{
	if(grepl(river_properties[1], variable))
		Mc_functions <<- rbind(Mc_functions, input)
	else if(grepl(river_properties[2], variable))
	{
		# Invalidate the first function since it's not actually used in the computation (asymmetric U)
		if(XS_shape == crossSectionalShapes[2] && nrow(Cs_functions) == 1)
		{
			if(input[1] != function_types[2])
				stop("Please provide a sine function for the AU cross-sectional shape. Program exit.")
			else
				input[1] = "NA"
		}
		Cs_functions <<- rbind(Cs_functions, input)
	}
	else if(grepl(river_properties[3], variable))
		Wbf_functions <<- rbind(Wbf_functions, input)
	else if(grepl(river_properties[4], variable))
		Zt_functions <<- rbind(Zt_functions, input)
	else if(grepl(river_properties[5], variable))
		LeftFP_functions <<- rbind(LeftFP_functions, input)
	else if(grepl(river_properties[6], variable))
		RightFP_functions <<- rbind(RightFP_functions, input)
}

# Evaluate all the functions stored in a variability parameter given independent variables and the associated key
evaluateFunctions = function(functions, ivs, key)
{
	output = 0
	for(i in seq(from=2, to=nrow(functions), by=1))
		output = output + computeFunction(functions[i,], ivs, key)
	return(output)
}

# Evaluate a particular, individual function given independent variables and the associated key
computeFunction = function(fun, iv, key)
{
	output = 0

	if(grepl(function_types[1], fun[1]))
		output = evaluateNumerical(fun[2])*(sin(evaluateNumerical(fun[3])*iv[1] + evaluateNumerical(fun[4])))**2
	else if(grepl(function_types[2], fun[1]))
		output = evaluateNumerical(fun[2])*sin(evaluateNumerical(fun[3])*iv[1] + evaluateNumerical(fun[4]))
	else if(grepl(function_types[3], fun[1]))
		output = evaluateNumerical(fun[2])*cos(evaluateNumerical(fun[3])*iv[1] + evaluateNumerical(fun[4]))
	else if(grepl(function_types[4], fun[1]))
		output = evaluateNumerical(fun[2])*iv[2] + evaluateNumerical(fun[3])
	else if(grepl(function_types[5], fun[1]))
	{
		# For producing the first Perlin point, use the initialized random values
		ra = ga
		rb = gb

		# If previous random values were saved, use them again
		if(!is.null(perlins[[key]]))
		{
			ra = perlins[[key]][1]
			rb = perlins[[key]][2]
		}

		# Create a new sub-wave to ensure randomness in the curve
		if(iv[3] %% evaluateNumerical(fun[3]) < 1)
		{
			ra = rb
			rb = random()
			output = 2*ra*evaluateNumerical(fun[2])
		}
		# Continue with the current sub-wave
		else
		{
			output = interpolate(ra, rb,
				(iv[3] %% evaluateNumerical(fun[3]))/evaluateNumerical(fun[3]))*evaluateNumerical(fun[2])*2
		}

		# Store the random values according to the river property to avoid inter-mixing
		perlins[[key]] <<- rbind(c(ra, rb))
	}

	return(output)
}

# Return whether a given input is a function
isFunction = function(input)
{
	for(i in seq(from=1, to=length(function_types), by=1))
		if(grepl(function_types[i], input))
			return(TRUE)
	return(FALSE)
}

# Return whether a user variable and its defined function are the same
isMatched = function(f1, f2)
{
	for(i in seq(from=1, to=length(function_types), by=1))
		if(grepl(function_types[i], f1) && grepl(function_types[i], f2))
			return(TRUE)
	return(FALSE)

}

# Return whether a function was defined and stored
isDefined = function(input)
{
	return(!is.null(userDefinedFunctions[[input]]))
}

# Formula for standardization (used for information in Data.csv)
standardize = function(x, m, sd)
{
	# Prevent zero-division
	if(sd == 0)
		return(0)
	else
		return( (x-m)/sd )
}

# Ensure that random points connect smoothly in a Perlin wave
interpolate = function(pa, pb, px)
{
	ft = px * pi
	f = (1 - cos(ft)) * 0.5
	return(pa * (1 - f) + pb * f)
}

crossSection = function(type, i, j)
{
	output = 0

	# Symmetric U cross section
	if(type == crossSectionalShapes[1])
		output = topsofBank[i] - bankfullDepths[i]*sqrt((1-(n_xs[i,j]/n_xs[i,1])**2))
	# Asymmetric U cross section (original)
	else if(type == crossSectionalShapes[2])
	{
		if(bankfullWidths[i] != 0)
		{
			if(centerlineCurvatures[i] > 0)
				output = topsofBank[i]-((4*bankfullDepths[i]*(((bankfullWidths[i]/2)-n_xs[i,j])/bankfullWidths[i])^k_s[i])
				* (1-(((bankfullWidths[i]/2)-n_xs[i,j])/bankfullWidths[i])^k_s[i]))
			else
				output = topsofBank[i]-((4*bankfullDepths[i]*((1-((bankfullWidths[i]/2-n_xs[i,j])/bankfullWidths[i]))^k_s[i]))
				* (1-((1-(bankfullWidths[i]/2-n_xs[i,j])/bankfullWidths[i])^k_s[i])))
		}
	}
	# Trapezoidal cross section. Can produce multiple shapes
	else if(type == crossSectionalShapes[3])
	{
		# Triangle: n = 0
		# Trapezoid: 1 <= n <= (ChannelXSPoints-2)
		# Rectangle: (ChannelXSPoints-3) <= n <= ChannelXSPoints

		if(base < 0 || base > ChannelXSPoints)
			stop("Invalid trapezoidal base length. Program exit.")

		inc = 0

		# Assign values based on if the base is even or odd
		if(base %% 2 == 0)
		{
			partition = base/2
			inc = 1
		}
		else
			partition = ceiling(base/2)

		# Endpoints are the bank tops
		if(j == 1 || j == ChannelXSPoints)
			output = topsofBank[i]
		# Produce a negatively-sloped line towards the left vertex of the base
		# or a positively-sloped line towards the right bank top
		else if((j >= 2 && j <= floor(ChannelXSPoints/2)-partition) || j > floor(ChannelXSPoints/2)+partition+inc)
		{
			deltaX = n_xs[i,j]-n_xs[i,j-1]
			deltaY = -bankfullDepths[i]/((ChannelXSPoints/2) - (base/2))
			# Positively-sloped line; switch signs
			if(j > floor(ChannelXSPoints/2)+partition+inc)
				deltaY = -deltaY
			xs_slope = deltaY/deltaX
			output = topsofBank[i] - (ChannelXSPoints/(ChannelXSPoints-base))*bankfullDepths[i] + xs_slope*(n_xs[i,j])
		}
		# Produce the base itself
		else if(j >= floor(ChannelXSPoints/2)-partition+1 && j <= floor(ChannelXSPoints/2)+partition+inc)
			output = topsofBank[i] - bankfullDepths[i]
	}
	# Invalid cross-sectional input
	else
		stop("Invalid input for cross-sectional shape. Program exit.")

	return(output)
}

#############################
#### Initialized Buffers ####
#############################

# Vector that stores every singular parameter value
parameters = c()

# Vector that stores key-value pairs of user defined functions
userDefinedFunctions = c()

# A -> user defined
# B -> calculated from Shields stress and particle size
userDefinedDepth = TRUE

# Sub-variability Function Storage
Mc_functions = data.frame(matrix(ncol=6))
Cs_functions = data.frame(matrix(ncol=6))
Wbf_functions = data.frame(matrix(ncol=6))
Zt_functions = data.frame(matrix(ncol=6))
LeftFP_functions = data.frame(matrix(ncol=6))
RightFP_functions = data.frame(matrix(ncol=6))

# Variable that keeps track of cross-sectional shape defined by the user
XS_shape = ""

# Variable that keeps track of trapezoidal base defined by user (if applicable)
base = 0

# Vector that stores random values associated with each river property (Perlin function)
perlins = c()

# Vector that stores random values associated with each river property (Ferguson, disturbed meander)
fergusons = c()

# Vector that stores powers less than abs(1) for computing points for the cross section
k1 = c()

###############################
#### Input File Processing ####
###############################

print(paste("Generating SRV files in", directory, "..."))

# Read in values from a specified text file.
inputs = read.table(filename, sep="=", header=FALSE, colClasses = c("character"))

# Store every parameter value or user-defined function
for(i in seq(from=1, to=length(inputs$V2), by=1))
{
	# Assign column values for readability
	col1 = (inputs$V1)[i]
	col2 = (inputs$V2)[i]

	input = col2
	input = strsplit(input, split="[(), ]")[[1]]
	input = input[nchar(input)>0]

	# Initialize a user-defined function to be used in future assignments, e.g. SIN#=SIN(a, f, ps)
	if(isFunction(col1))
	{
		if(isMatched(col1, col2) && !isDefined(col1) && grepl("[0-9]", col1))
			userDefinedFunctions[[col1]] = input
		else
			stop("A user-defined function has an invalid name, values, or was defined more than once. Program exit.")
	}
	# Assign a river parameter with a function (user-defined values or function)
	else if(!isFunction(col1) && isFunction(col2))
	{
		# Assign with a function followed by a user-defined set of parameter values, e.g. <PARAMETER> = SIN(a, f, ps)
		if(grepl("(,)", col2))
			storeFunction(col1, input)
		# Assign with a user-defined function, e.g. <PARAMETER>=SIN#
		else
		{
			if(isDefined(col2))
			{
				input = userDefinedFunctions[[col2]]
				storeFunction(col1, input)
			}
			else
				stop("Attempted to assign with an undefined function. Program exit.")
		}
	}
	# EX: <PARAMETER>=(0, 0, 0)
	else if(grepl("(,)", col2))
		stop("Attempted to assign with values but no specific function. Program exit.")
	# Store the cross sectional shape defined by the user
	else if(grepl(river_properties[7], col1))
	{
		if(grepl(crossSectionalShapes[3], col2))
		{
			if(length(input) != 2 || grepl("[A-z]", input[2]) || grepl("[[:punct:]]", input[2]))
				stop("Invalid input for trapezoidal cross section. Program exit.")
			XS_shape = input[1]
			base = as.double(input[2])
		}
		else
			XS_shape = col2
	}
	# Store numerical value
	else
	{
		# If B, calculate channel depth given t50 and D50
		if(grepl("Hbf", col1))
		{
			input = strsplit(col1, ",")[[1]][2]
			if(grepl("B", input))
				userDefinedDepth = FALSE
		}

		parameters = c(parameters, evaluateNumerical(col2))
	}
}

####################
#### Parameters ####
####################

# Domain Parameters
datum = parameters[1]
length = parameters[2]
XResolution = length/parameters[3]
ChannelXSPoints = parameters[4]

# Dimensionless Parameters
valleySlope = parameters[5]
criticalShieldsStress = parameters[6]

# Channel Parameters
bankfullWidth = parameters[7]
bankfullWidthMin = parameters[8]
bankfullDepth = parameters[9]
medianSedimentSize = parameters[10]

# Floodplain Parameters
FPWidth = parameters[11]
outerFPEdgeHeight = parameters[12]
terraceWidth = parameters[13]
outerTerraceEdgeHeight = parameters[14]
boundaryWidth = parameters[15]

#####################
#### Coordinates ####
#####################

# Channel Model
# Column B
increments = c()
# Column C
xrads = c()
# Column D
xms = c()
# Column E
channelMeanders = c()
# Column H
scms = c(0)
# Column I
dscms = c()
# Column J
scms_r = c()
# Column K
dxcmds = c()
# Column L
dycmds = c()
# Column N
thalwegs = c()
# Column P
thalwegsNoSlope = c()
# Column Q
topsofBank = c()
# Column R
bankfullDepths = c()
# Column S
wbf_pfs = c()
# Column T
bankfullWidths = c()
# Column U
bankfullWidths_L = c()
# Column V
bankfullWidths_R = c()
# Column W
centerlineCurvature_pfs = c()
# Column X
firstDerivatives = rep(0, XResolution)
# Column Y
secondDerivatives = rep(0, XResolution)
# Column Z
centerlineCurvatures = c()

# Floodplain Model
# Column B
yRightWaves = c()
# Column C
yLeftWaves = c()
# Column E
yRightToe = c()
# Column F
zRightToe = c()
# Column H
yRightTop = c()
# Column I
zRightTop = c()
# Column K
yLeftToe = c()
# Column L
zLeftToe = c()
# Column N
yLeftTop = c()
# Column O
zLeftTop = c()

# XS Model
# Column D
b_s = c()
# Column F
k_s = c()
# Columns I-AC
h_n = matrix(nrow=XResolution, ncol=ChannelXSPoints)
# Columns AD-AX
n_xs = matrix(nrow=XResolution, ncol=ChannelXSPoints)
# Columns AY-BS
bankPoints = matrix(nrow=XResolution, ncol=ChannelXSPoints)
# Columns BT-CN
xShifts = matrix(nrow=XResolution, ncol=ChannelXSPoints)

# Covariance
# Column B
Wbf_stds = c()
# Column D
Zt_stds = c()
# Column H
CV_WZ = c()
# Column I
CV_ZC = c()

# Meander Models
# Langbein and Leopold
# Column B
disturbedDx = c(0)
# Column C
disturbedDy = c(0)
# Column E
disturbedThetas = c()
# Column F
disturbedX = c(0)
# Column G
disturbedY = c(0)

# Ferguson
# Column E
fergusonY = c(0, 0.25)

#################################
#### Miscellaneous Variables ####
#################################

dxi = length/XResolution
dxr = (dxi/length)*2*pi
confinementRatio = bankfullWidth/(FPWidth+terraceWidth+bankfullWidth)
ks = 6.1*medianSedimentSize
n = 0.034*(ks^(1/6))
positiveGCS = 0
negativeGCS = 0
posPercentGCS = 0
negPercentGCS = 0
ki = -1
incr = 1/floor(ChannelXSPoints/2)

# Necessary values to produce a random wave (Perlin function)
Mr = 4294967296
Ar = 1664525
Cr = 1
Zr = floor(runif(1)*Mr)

# Initial random values (Perlin function)
ga = random()
gb = random()

while(ki < 1+incr)
{
	k1 = c(k1, round(ki, digits=5))
	ki = ki + incr
}

if(ChannelXSPoints %% 2 == 0)
	k1 = k1[abs(k1) > 0]

if(bankfullWidthMin > bankfullWidth)
	stop("Minimum bankfull width is greater than base bankfull width. Program exit.")

print("Computing river properties...")

# B, C, D, E, H, I, J, K, L, N, P, S, T, U, V, W, X, Y, Z (CM), B, C (FM)
for(i in seq(from=1, to=XResolution, by=1))
{
	# Computation of (mostly) x-coordinates
	increments = c(increments, i-1)
	xrads = c(xrads, (i-1)*dxr)
	xms = c(xms, (increments[i]/XResolution)*length)
	channelMeanders = c(channelMeanders, evaluateFunctions(Mc_functions, c(xrads[i], xms[i], increments[i]), "M"))
	if(i >= 2)
	{
		if(i == 2)
			dscms = c(dscms, sqrt((channelMeanders[i]-channelMeanders[i-1])**2 + (xms[i]-xms[i-1])**2))
		dscms = c(dscms, sqrt((channelMeanders[i]-channelMeanders[i-1])**2 + (xms[i]-xms[i-1])**2))
		scms = c(scms, scms[i-1] + dscms[i])
	}

	scms_r = c(scms_r, 2*pi*scms[i]/length)

	# Computation of (mostly) y-coordinates
	yRightWaves = c(yRightWaves, evaluateFunctions(RightFP_functions, c(xrads[i], xms[i], increments[i]), "R"))
	yLeftWaves = c(yLeftWaves, evaluateFunctions(LeftFP_functions, c(xrads[i], xms[i], increments[i]), "L"))
	wbf_pfs = c(wbf_pfs, evaluateFunctions(Wbf_functions, c(scms_r[i], xms[i], increments[i]), "W"))
	if(wbf_pfs[i]*bankfullWidth+bankfullWidth >= bankfullWidthMin)
		bankfullWidths = c(bankfullWidths, wbf_pfs[i]*bankfullWidth + bankfullWidth)
	else
		bankfullWidths = c(bankfullWidths, bankfullWidthMin)
	bankfullWidths_L = c(bankfullWidths_L, -bankfullWidths[i]/2)
	bankfullWidths_R = c(bankfullWidths_R, bankfullWidths[i]/2)
	centerlineCurvature_pfs = c(centerlineCurvature_pfs, evaluateFunctions(Cs_functions, c(scms_r[i], xms[i], increments[i]), "E"))

	if(XS_shape == crossSectionalShapes[2])
	{
		firstDerivatives[i] = as.double(Cs_functions[2,2])*cos(as.double(Cs_functions[2,3])*scms_r[i] + as.double(Cs_functions[2,4]))
		secondDerivatives[i] = as.double(Cs_functions[2,2])*(-sin(as.double(Cs_functions[2,3])*scms_r[i] + as.double(Cs_functions[2,4])))
	}

	if(i == 1)
	{
		centerlineCurvatures = c(centerlineCurvatures, centerlineCurvature_pfs[i])
	}
	else
	{
		if(length(dxcmds) == 0)
			dxcmds = c(dxcmds, (xms[i]-xms[i-1])/dscms[i-1])
		if(length(dycmds) == 0)
			dycmds = c(dycmds, (channelMeanders[i]-channelMeanders[i-1])/dscms[i-1])
		dxcmds = c(dxcmds, (xms[i]-xms[i-1])/dscms[i])
		dycmds = c(dycmds, (channelMeanders[i]-channelMeanders[i-1])/dscms[i])
		centerlineCurvatures = c(centerlineCurvatures, centerlineCurvature_pfs[i]+secondDerivatives[i]/((1 + (firstDerivatives[i])**2)**(3/2)))
	}
}

maxCenterlineCurvature = abs(centerlineCurvatures)[which.max(abs(centerlineCurvatures))]*1.2
disturbedAmp = 110*pi/180
disturbedMeander = scms[length(scms)]
ds = 1

# Q, R (CM), D, F, I-AC, AD-AX, AY-BS, BT-CN (XM)
for(i in seq(from=1, to=XResolution, by=1))
{
	if(centerlineCurvatures[i] < 0)
		b_s = c(b_s, (0.5*(1-((abs(centerlineCurvatures[i]))/maxCenterlineCurvature))))
	else if(centerlineCurvatures[i] > 0)
		b_s = c(b_s, (0.5*(1+((centerlineCurvatures[i])/maxCenterlineCurvature))))
	else if(centerlineCurvatures[i] == 0)
		b_s = c(b_s, 0.5)

	if(centerlineCurvatures[i] < 0)
		k_s = c(k_s, (-log(2)/log(b_s[i])))
	else
		k_s = c(k_s, (-log(2)/log(1-b_s[i])))

	disturbedThetas = c(disturbedThetas, disturbedAmp*sin(2*pi*scms[i]/disturbedMeander))

	if(i != 1)
	{
		disturbedDx = c(disturbedDx, ds*cos(disturbedThetas[i]))
		disturbedDy = c(disturbedDy, ds*sin(disturbedThetas[i]))
		disturbedX = c(disturbedX, disturbedX[i-1]+disturbedDx[i])
		disturbedY = c(disturbedY, disturbedY[i-1]+disturbedDy[i])
	}
}

sinuosity = scms[length(scms)]/xms[length(xms)]
channelSlope = ((XResolution*sum(scms*centerlineCurvatures)-sum(scms)*sum(centerlineCurvatures))/
	(XResolution*sum(scms**2)-(sum(scms))**2)) + (valleySlope/sinuosity)
channelIntercept = ((sum(centerlineCurvatures)*sum((scms**2))-sum(scms)*sum(scms*centerlineCurvatures))/
	(XResolution*sum(scms**2)-(sum(scms))**2))
disturbedY = (disturbedY - disturbedY[which.max(disturbedY)]/2)
if(!userDefinedDepth)
	bankfullDepth = (165*medianSedimentSize*criticalShieldsStress)/channelSlope

widthToDepthRatio = bankfullWidth/bankfullDepth
Wbf_a1 = as.double(Wbf_functions[2,2])
Zt_a1 = as.double(Zt_functions[2,2])
Zt_f1 = as.double(Zt_functions[2,3])
#wr = bankfullWidth*Wbf_a1+bankfullWidth
#wp = -bankfullWidth*Wbf_a1+bankfullWidth
#hres = 2*bankfullDepth*Zt_a1-(pi*bankfullWidth*valleySlope/Zt_f1)

for(i in seq(from=1, to=XResolution, by=1))
{
	thalwegs = c(thalwegs, (bankfullDepth*(evaluateFunctions(Zt_functions, c(scms_r[i], xms[i], increments[i]), "T") + bankfullDepth)) + scms[i]*channelSlope + datum)
	if(i == 1)
		thalwegsNoSlope = c(thalwegsNoSlope, thalwegs[i])
	else
		thalwegsNoSlope = c(thalwegsNoSlope, thalwegs[i]-(scms[i]-scms[1])*channelSlope)
}

for(i in seq(from=1, to=XResolution, by=1))
{
	if(i == 1)
		topsofBank = c(topsofBank, thalwegsNoSlope[which.max(thalwegsNoSlope)] + bankfullDepth)
	else
		topsofBank = c(topsofBank, topsofBank[i-1]+(scms[i]-scms[i-1])*valleySlope)

	bankfullDepths = c(bankfullDepths, topsofBank[i] - thalwegs[i])

	# Produce the bank points along the channel meander
	for(j in seq(from=1, to=ChannelXSPoints, by=1))
	{
		n_xs[i,j] = k1[j]*bankfullWidths[i]/2
		bankPoints[i,j] = channelMeanders[i] + n_xs[i,j]*dxcmds[i]
		xShifts[i,j] = xms[i] - n_xs[i,j]*dycmds[i]
		h_n[i,j] = crossSection(XS_shape, i, j)
	}
}

# Width at location where depth is at maximum
wr = bankfullWidths[which.max(bankfullDepths)]
# Width at location where depth is at minimum
wp = bankfullWidths[which.min(bankfullDepths)]
# Bed location at max depth - Bed location at min depth
hres = thalwegsNoSlope[which.max(thalwegsNoSlope)] - thalwegsNoSlope[which.min(thalwegsNoSlope)]
hcrit = hres/((wr/wp)-1)
maxLength = which(bankPoints == max(bankPoints), arr.ind = TRUE)
minLength = which(bankPoints == min(bankPoints), arr.ind = TRUE)
maxRow = maxLength[1,1]
maxCol = maxLength[1,2]
minRow = minLength[1,1]
minCol = minLength[1,2]
maxRightBank = bankPoints[maxRow, maxCol]
minLeftBank = bankPoints[minRow, minCol]
maxRightToe = yRightWaves[which.max(yRightWaves)]
minLeftToe = yLeftWaves[which.min(yLeftWaves)]
minRightToe = yRightWaves[which.min(yRightWaves)]
maxLeftToe = yLeftWaves[which.max(yLeftWaves)]

# E, F, H, I, K, L, N, O (FM)
for(i in seq(from=1, to=XResolution, by=1))
{
	yRightToe = c(yRightToe, yRightWaves[i] + FPWidth/2 + maxRightBank - minRightToe)
	yLeftToe = c(yLeftToe, -yLeftWaves[i] - FPWidth/2 + minLeftBank + minLeftToe)
	zRightToe = c(zRightToe, topsofBank[i] + outerFPEdgeHeight)
	zLeftToe = c(zLeftToe, zRightToe[i])
	yRightTop = c(yRightTop, yRightToe[i] + terraceWidth/2)
	yLeftTop = c(yLeftTop, yLeftToe[i] - terraceWidth/2)
	zRightTop = c(zRightTop, zRightToe[i] + outerTerraceEdgeHeight)
	zLeftTop = c(zLeftTop, zRightTop[i])

	standardizedDepth = standardize(thalwegsNoSlope[i], mean(thalwegsNoSlope), sd(thalwegsNoSlope))
	standardizedWidth = standardize(bankfullWidths[i], mean(bankfullWidths), sd(bankfullWidths))
	standardizedCenterlineCurvature = standardize(centerlineCurvatures[i], mean(centerlineCurvatures), sd(centerlineCurvatures))
	Wbf_stds = c(Wbf_stds, standardizedWidth)
	Zt_stds = c(Zt_stds, standardizedDepth)
	CV_WZ = c(CV_WZ, Wbf_stds[i]*Zt_stds[i])
	CV_ZC = c(CV_ZC, Zt_stds[i]*standardizedCenterlineCurvature)
	currentGCS = standardizedDepth*standardizedWidth
	if(currentGCS > 0){
		positiveGCS = positiveGCS + 1
	}
	else if(currentGCS < 0){
		negativeGCS = negativeGCS + 1
	}
}

if(positiveGCS != 0 || negativeGCS != 0)
{
	negPercentGCS = 100*negativeGCS/(negativeGCS+positiveGCS)
	posPercentGCS = 100*positiveGCS/(negativeGCS+positiveGCS)
}

print("Computations complete.")

Graph_yRightTop = c(round(yRightToe[XResolution/2], digits=3), round(yRightTop[XResolution/2], digits=3))
Graph_zRightTop = c(round(zRightToe[XResolution/2], digits=3), round(zRightTop[XResolution/2], digits=3))

Graph_yLeftTop = c(round(yLeftToe[XResolution/2], digits=3), round(yLeftTop[XResolution/2], digits=3))
Graph_zLeftTop = c(round(zLeftToe[XResolution/2], digits=3), round(zLeftTop[XResolution/2], digits=3))

Graph_yRightToe = c(round(n_xs[XResolution/2, ChannelXSPoints], digits=3), round(yRightToe[XResolution/2], digits=3))
Graph_zRightToe = c(round(h_n[XResolution/2, ChannelXSPoints], digits=3), round(zRightToe[XResolution/2], digits=3))

Graph_yLeftToe = c(round(n_xs[XResolution/2, 1], digits=3), round(yLeftToe[XResolution/2], digits=3))
Graph_zLeftToe = c(round(h_n[XResolution/2, 1], digits=3), round(zLeftToe[XResolution/2], digits=3))

Graph_yRightBoundary = c(round(yRightTop[XResolution/2], digits=3), round(yRightTop[XResolution/2]+boundaryWidth, digits=3))
Graph_zRightBoundary = c(round(zRightTop[XResolution/2], digits=3), round(zRightTop[XResolution/2], digits=3))

Graph_yLeftBoundary = c(round(yLeftTop[XResolution/2], digits=3), round(yLeftTop[XResolution/2]-boundaryWidth, digits=3))
Graph_zLeftBoundary = c(round(zLeftTop[XResolution/2], digits=3), round(zLeftTop[XResolution/2], digits=3))

################
#### Graphs ####
################
# Notes for legend:
# - par(xpd = TRUE) allows legend outside of plot
# - inset controls positioning
# - lty sets length of legend lines
# - lwd sets thickness of legend lines
# - pt.cex assures the plot itself isn't modified
# - cex controls point/text size

# Produce the centerline curvature graph
png(filename=file.path(directory, file_outputs[1]), 10, 7.5, "in", res=100)
plot(main = "Centerline Curvature", round(scms, digits=3), round(centerlineCurvatures, digits=3),
	ylim = range(centerlineCurvatures[which.min(centerlineCurvatures)]-0.05,centerlineCurvatures[which.max(centerlineCurvatures)]+0.05),
	col = "darkblue", xlab = "S (meters)", ylab = "Elevation (meters)", cex = 0.75)
lines(round(scms, digits=3), round(centerlineCurvatures, digits=3),
	col = "darkblue")
dev.off()

print(paste(file_outputs[1], "generated."))

png(filename=file.path(directory, file_outputs[2]), 10, 7.5, "in", res=100)
plot(main = "Valley Section", round(n_xs[XResolution/2,], digits=3), round(h_n[XResolution/2,], digits=3),
	xlim = range(yLeftTop[which.min(yLeftTop)]-boundaryWidth, yRightTop[which.max(yRightTop)]+boundaryWidth),
	ylim = range(h_n[XResolution/2,which.min(h_n[XResolution/2,])],
		zRightTop[which.max(zRightTop)]),
	col = "darkblue", xlab = "Y (meters)", ylab = "Elevation (meters)", cex = 0.75)
lines(round(n_xs[XResolution/2,], digits=3), round(h_n[XResolution/2,], digits=3),
	col = "darkblue", lwd = 4)

# Plot valley floors
points(yRightToe[XResolution/2], zRightToe[XResolution/2], col = "chocolate4")
lines(Graph_yRightToe, Graph_zRightToe, col = "chocolate4", lwd = 4)

points(yLeftToe[XResolution/2], zLeftToe[XResolution/2], col = "chocolate4")
lines(Graph_yLeftToe, Graph_zLeftToe, col = "chocolate4", lwd = 4)

# Plot valley tops
points(yRightTop[XResolution/2], zRightTop[XResolution/2], col = "black")
lines(Graph_yRightTop, Graph_zRightTop, col = "black", lwd = 4)

points(yLeftTop[XResolution/2], zLeftTop[XResolution/2], col = "black")
lines(Graph_yLeftTop, Graph_zLeftTop, col = "black", lwd = 4)

# Plot boundary widths
points(yRightTop[XResolution/2]+boundaryWidth, zRightTop[XResolution/2], col = "darkorchid4")
lines(Graph_yRightBoundary, Graph_zRightBoundary, col = "darkorchid4", lwd = 4)

points(yLeftTop[XResolution/2]-boundaryWidth, zLeftTop[XResolution/2], col = "darkorchid4")
lines(Graph_yLeftBoundary, Graph_zLeftBoundary, col = "darkorchid4", lwd = 4)

par(xpd = TRUE)
legend("topright", inset = c(0, -0.13), c("Boundaries", "Terrace", "Floodplain", "Channel"),
	lty = c(1,1,1,1), lwd = c(4,4,4,4), col = c("darkorchid4", "black", "chocolate4", "darkblue"), cex = 0.75)
dev.off()

print(paste(file_outputs[2], "generated."))

# Produce the Geometric Covariance Structures graph
png(filename=file.path(directory, file_outputs[3]), 10, 7.5, "in", res=100)
plot(main = "Geometric Covariance Structures", round(xms, digits=3), round(CV_WZ, digits=3),
	ylim = range(min(CV_WZ[which.min(CV_WZ)]-0.5, CV_ZC[which.min(CV_ZC)]-0.5),max(CV_WZ[which.max(CV_WZ)]+0.5, CV_ZC[which.max(CV_ZC)]+0.5)),
	col = "forestgreen", xlab = "X (meters)", ylab = "Geometric Covariance", cex = 0.75)
lines(round(xms, digits=3), round(CV_WZ, digits=3),
	col = "forestgreen")
par(new = TRUE)
plot(round(xms, digits=3), round(CV_ZC, digits=3),
	ylim = range(min(CV_WZ[which.min(CV_WZ)]-0.5, CV_ZC[which.min(CV_ZC)]-0.5),max(CV_WZ[which.max(CV_WZ)]+0.5, CV_ZC[which.max(CV_ZC)]+0.5)),
	col = "darkred", axes = FALSE, xlab = "", ylab = "", cex = 0.75)
lines(round(xms, digits=3), round(CV_ZC, digits=3),
	col = "darkred")
par(xpd = TRUE)
legend("topright", inset = c(0, -0.11), c("C(Wbf*Zt)", "C(Zt*Cs)"),
	lty = c(1,1), lwd = c(4,4), col = c("forestgreen", "darkred"), cex = 1)
dev.off()

print(paste(file_outputs[3], "generated."))

# Produce the longitudinal profile graph
png(filename=file.path(directory, file_outputs[4]), 10, 7.5, units = "in", res=100)
plot(main = "Longitudinal Profile", round(xms, digits=3), round(zRightTop, digits=3),
	ylim = range(thalwegs[which.min(thalwegs)]-5,zRightTop[which.max(zRightTop)]+5),
	col = "black", xlab = "X (meters)", ylab = "Elevation (meters)", cex = 0.75)
lines(round(xms, digits=3), round(zRightTop, digits=3),
	col = "black")
par(new = TRUE)
plot(round(xms, digits=3), round(zRightToe, digits=3),
	ylim = range(thalwegs[which.min(thalwegs)]-5,zRightTop[which.max(zRightTop)]+5),
	col = "chocolate4", axes = FALSE, xlab = "", ylab = "", cex = 0.75)
lines(round(xms, digits=3), round(zRightToe, digits=3),
	col = "chocolate4")
par(new = TRUE)
plot(round(xms, digits=3), round(topsofBank, digits=3),
	ylim = range(thalwegs[which.min(thalwegs)]-5,zRightTop[which.max(zRightTop)]+5),
	col = "chartreuse4", axes = FALSE, xlab = "", ylab = "", cex = 0.75)
lines(round(xms, digits=3), round(topsofBank, digits=3),
	col = "chartreuse4")
par(new = TRUE)
plot(round(xms, digits=3), round(thalwegs, digits=3),
	ylim = range(thalwegs[which.min(thalwegs)]-5,zRightTop[which.max(zRightTop)]+5),
	col = "dimgray", axes = FALSE, xlab = "", ylab = "", cex = 0.75)
lines(round(xms, digits=3), round(thalwegs, digits=3),
	col = "dimgray")
par(xpd = TRUE)
legend("topright", inset = c(0, -0.13), c("Valley Top", "Valley Floor", "Bank Top", "Thalweg Elevation"),
	lty = c(1,1,1,1), lwd = c(4,4,4,4), col = c("black", "chocolate4", "chartreuse4", "dimgray"), cex = 0.75)
dev.off()

print(paste(file_outputs[4], "generated."))

# Produce the planform graph(s)
png(filename=file.path(directory, file_outputs[5]), 10, 7.5, units = "in", res=100)
plot(main = "Planform", round(xms, digits=3), round(channelMeanders, digits=3),
	ylim = range((yLeftTop[which.min(yLeftTop)]-5),(yRightTop[which.max(yRightTop)]+5)),
	col = "darkblue", xlab = "X (meters)", ylab = "Y (meters)", cex = 0.75)
lines(round(xms, digits=3), round(channelMeanders, digits=3),
	col = "darkblue")
par(new = TRUE)
plot(round(xms, digits=3), round(bankPoints[,ChannelXSPoints], digits=3),
	ylim = range((yLeftTop[which.min(yLeftTop)]-5),(yRightTop[which.max(yRightTop)]+5)),
	col = "chartreuse4", axes = FALSE, xlab = "", ylab = "", cex = 0.75)
lines(round(xms, digits=3), round(bankPoints[,ChannelXSPoints], digits=3),
	col = "chartreuse4")
par(new = TRUE)
plot(round(xms, digits=3), round(bankPoints[,1], digits=3),
	ylim = range((yLeftTop[which.min(yLeftTop)]-5),(yRightTop[which.max(yRightTop)]+5)),
	col = "chartreuse4", axes = FALSE, xlab = "", ylab = "", cex = 0.75)
lines(round(xms, digits=3), round(bankPoints[,1], digits=3),
	col = "chartreuse4")
par(new = TRUE)
plot(round(xms, digits=3), round(yRightToe, digits=3),
	ylim = range((yLeftTop[which.min(yLeftTop)]-5),(yRightTop[which.max(yRightTop)]+5)),
	col = "chocolate4", axes = FALSE, xlab = "", ylab = "", cex = 0.75)
lines(round(xms, digits=3), round(yRightToe, digits=3),
	col = "chocolate4")
par(new = TRUE)
plot(round(xms, digits=3), round(yLeftToe, digits=3),
	ylim = range((yLeftTop[which.min(yLeftTop)]-5),(yRightTop[which.max(yRightTop)]+5)),
	col = "chocolate4", axes = FALSE, xlab = "", ylab = "", cex = 0.75)
lines(round(xms, digits=3), round(yLeftToe, digits=3),
	col = "chocolate4")
par(new = TRUE)
plot(round(xms, digits=3), round(yRightTop, digits=3),
	ylim = range((yLeftTop[which.min(yLeftTop)]-5),(yRightTop[which.max(yRightTop)]+5)),
	col = "black", axes = FALSE, xlab = "", ylab = "", cex = 0.75)
lines(round(xms, digits=3), round(yRightTop, digits=3),
	col = "black")
par(new = TRUE)
plot(round(xms, digits=3), round(yLeftTop, digits=3),
	ylim = range((yLeftTop[which.min(yLeftTop)]-5),(yRightTop[which.max(yRightTop)]+5)),
	col = "black", axes = FALSE, xlab = "", ylab = "", cex = 0.75)
lines(round(xms, digits=3), round(yLeftTop, digits=3),
	col = "black")
par(xpd = TRUE)
legend("topright", inset = c(0, -0.13), c("Channel Meander", "Channel Banks", "Valley Floors", "Valley Tops"),
	lty = c(1,1,1,1), lwd = c(4,4,4,4), col = c("darkblue", "chartreuse4", "chocolate4", "black"), cex = 0.75)
dev.off()

print(paste(file_outputs[5], "generated."))

#png(filename="DisturbedMeander.png", 10, 7.5, "in", res=100)
#plot(main = "Disturbed Meander", round(disturbedX, digits=3), round(disturbedY, digits=3),
#	ylim = range(disturbedY), col="chartreuse4", xlab = "X (meters)", ylab = "Y (meters)", cex = 0.75)
#lines(round(disturbedX, digits=3), round(disturbedY, digits=3), col="chartreuse4")
#dev.off()

#####################
#### CSV OUTPUTS ####
#####################
# X = xShifts + xms + xms + xms + xms + xms + xms
# Y = bankPoints + yRightTop + yLeftTop + (0.5 + yRightTop[which.max(yRightTop)]) + -(0.5 + yRightTop[which.max(yRightTop)]) + yLeftToe + yRightToe
# Z = h_n + zRightTop + zLeftTop + zRightTop + zRightTop + zLeftToe + zRightToe

# Produce BoundaryPoints.csv
values = data.frame(matrix(nrow=17, ncol=1), stringsAsFactors=FALSE)
values[1,1] = XResolution*(ChannelXSPoints+2)
values[2,1] = XResolution*ChannelXSPoints
values[3,1] = XResolution*(ChannelXSPoints+5)
values[4,1] = XResolution*(ChannelXSPoints-1)
values[5,1] = 0
values[6,1] = XResolution*(ChannelXSPoints+4)
values[7,1] = XResolution*(ChannelXSPoints+1)
values[8,1] = XResolution*(ChannelXSPoints+3)
values[9,1] = XResolution*(ChannelXSPoints+4)-1
values[10,1] = XResolution*(ChannelXSPoints+2)-1
values[11,1] = XResolution*(ChannelXSPoints+5)-1
values[12,1] = XResolution-1
values[13,1] = XResolution*ChannelXSPoints-1
values[14,1] = XResolution*(ChannelXSPoints+6)-1
values[15,1] = XResolution*(ChannelXSPoints+1)-1
values[16,1] = XResolution*(ChannelXSPoints+3)-1
values[17,1] = XResolution*(ChannelXSPoints+2)

write.table(values, file = file.path(directory, file_outputs[6]),
	append = FALSE, row.names = FALSE, col.names = FALSE, quote = FALSE)

print(paste(file_outputs[6], "generated."))

# Produce Data.csv
values = data.frame(matrix(nrow=14, ncol=1), stringsAsFactors=FALSE)
rownames(values) = c("Coefficient of Variation (Wbf):", "Standard Deviation (Wbf):", "Average (Wbf):",
		"Coefficient of Variation (Hbf):", "Standard Deviation (Hbf):", "Average (Hbf):",
		"wr:", "wp:", "hres:", "hcrit:", "GCS (-):", "GCS (+):", "Sinuosity:", "Channel Slope:")
values[1,1] = c(round(sd(bankfullWidths)/mean(bankfullWidths), digits=3))
values[2,1] = c(round(sd(bankfullWidths), digits=3))
values[3,1] = c(round(mean(bankfullWidths), digits=3))
values[4,1] = c(round(sd(bankfullDepths)/mean(bankfullDepths), digits=3))
values[5,1] = c(round(sd(bankfullDepths), digits=3))
values[6,1] = c(round(mean(bankfullDepths), digits=3))
values[7,1] = c(round(wr, digits=3))
values[8,1] = c(round(wp, digits=3))
values[9,1] = c(round(hres, digits=3))
values[10,1] = c(round(hcrit, digits=3))
values[11,1] = c(paste(as.character(round(negPercentGCS, digits=3)), "%", sep=""))
values[12,1] = c(paste(as.character(round(posPercentGCS, digits=3)), "%", sep=""))
values[13,1] = c(round(sinuosity, digits=3))
values[14,1] = c(round(channelSlope, digits=5))
write.table(values, file = file.path(directory, file_outputs[7]),
	append = FALSE, col.names = FALSE, sep = "\t", quote = FALSE)

print(paste(file_outputs[7], "generated."))

# Produce CartesianCoordinates.csv
header1 = data.frame("X,Y,Z")
header2 = data.frame("X,Y")
header3 = data.frame("X,Z")
header4 = data.frame("Y,Z")

firstSet = data.frame(rbind(c(format(round(xShifts[1,1], 6), nsmall=6),
		format(round(bankPoints[1,1], 6), nsmall=6), format(round(h_n[1,1], 6), nsmall=6))))
points = data.frame()

for(j in seq(from=1, to=ChannelXSPoints, by=1))
	for(i in seq(from=1, to=XResolution, by=1))
		if(i != 1 || j != 1)
			points = rbind(points, c(round(xShifts[i,j], digits=3), round(bankPoints[i,j], digits=3), round(h_n[i,j], digits=3)))

for(i in seq(from=1, to=XResolution, by=1))
	points = rbind(points, c(round(xms[i], digits=3), round(yRightTop[i], digits=3), round(zRightTop[i], digits=3)))

for(i in seq(from=1, to=XResolution, by=1))
	points = rbind(points, c(round(xms[i], digits=3), round(yLeftTop[i], digits=3), round(zLeftTop[i], digits=3)))

for(i in seq(from=1, to=XResolution, by=1))
	points = rbind(points, c(round(xms[i], digits=3), round(boundaryWidth + yRightTop[which.max(yRightTop)], digits=3), round(zRightTop[i], digits=3)))

for(i in seq(from=1, to=XResolution, by=1))
	points = rbind(points, c(round(xms[i], digits=3), round(-boundaryWidth - yRightTop[which.max(yRightTop)], digits=3), round(zRightTop[i], digits=3)))

for(i in seq(from=1, to=XResolution, by=1))
	points = rbind(points, c(round(xms[i], digits=3), round(yLeftToe[i], digits=3), round(zLeftToe[i], digits=3)))

for(i in seq(from=1, to=XResolution, by=1))
	points = rbind(points, c(round(xms[i], digits=3), round(yRightToe[i], digits=3), round(zRightToe[i], digits=3)))

write.table(header1, file=file.path(directory, file_outputs[8]), row.names=FALSE, col.names=FALSE, quote=FALSE, append=TRUE)
write.table(firstSet, file=file.path(directory, file_outputs[8]), row.names=FALSE, col.names=FALSE, quote=FALSE, sep=",", append=TRUE)
write.table(points, file=file.path(directory, file_outputs[8]), row.names=FALSE, col.names=FALSE, sep= ",", append=TRUE)
print(paste(file_outputs[8], "generated."))

points = data.frame()

for(i in seq(from=1, to=XResolution, by=1))
	points = rbind(points, c(round(scms[i], digits=3), round(centerlineCurvatures[i], digits=3)))

write.table(header2, file=file.path(directory, file_outputs[9]), row.names=FALSE, col.names=FALSE, quote=FALSE, append=TRUE)
write.table(points, file=file.path(directory, file_outputs[9]), row.names=FALSE, col.names=FALSE, sep= ",", append=TRUE)
print(paste(file_outputs[9], "generated."))

points = data.frame()

for(i in seq(from=1, to=ChannelXSPoints, by=1))
	points = rbind(points, c(round(n_xs[XResolution/2,i], digits=3), round(h_n[XResolution/2,i], digits=3)))

points = rbind(points, c(round(yRightTop[XResolution/2]+boundaryWidth, digits=3), round(zRightTop[XResolution/2], digits=3)))
points = rbind(points, c(round(yLeftTop[XResolution/2]-boundaryWidth, digits=3), round(zLeftTop[XResolution/2], digits=3)))
points = rbind(points, c(round(yRightTop[XResolution/2], digits=3), round(zRightTop[XResolution/2], digits=3)))
points = rbind(points, c(round(yRightToe[XResolution/2], digits=3), round(zRightToe[XResolution/2], digits=3)))
points = rbind(points, c(round(yLeftTop[XResolution/2], digits=3), round(zLeftTop[XResolution/2], digits=3)))
points = rbind(points, c(round(yLeftToe[XResolution/2], digits=3), round(zLeftToe[XResolution/2], digits=3)))

write.table(header4, file=file.path(directory, file_outputs[10]), row.names=FALSE, col.names=FALSE, quote=FALSE, append=TRUE)
write.table(points, file=file.path(directory, file_outputs[10]), row.names=FALSE, col.names=FALSE, sep= ",", append=TRUE)
print(paste(file_outputs[10], "generated."))

points = data.frame()

for(i in seq(from=1, to=XResolution, by=1))
	points = rbind(points, c(round(xms[i], digits=3), round(CV_WZ[i], digits=3)))

for(i in seq(from=1, to=XResolution, by=1))
	points = rbind(points, c(round(xms[i], digits=3), round(CV_ZC[i], digits=3)))

write.table(header2, file=file.path(directory, file_outputs[11]), row.names=FALSE, col.names=FALSE, quote=FALSE, append=TRUE)
write.table(points, file=file.path(directory, file_outputs[11]), row.names=FALSE, col.names=FALSE, sep= ",", append=TRUE)
print(paste(file_outputs[11], "generated."))

points = data.frame()

for(i in seq(from=1, to=XResolution, by=1))
	points = rbind(points, c(round(xms[i], digits=3), round(zRightTop[i], digits=3)))

for(i in seq(from=1, to=XResolution, by=1))
	points = rbind(points, c(round(xms[i], digits=3), round(zRightToe[i], digits=3)))

for(i in seq(from=1, to=XResolution, by=1))
	points = rbind(points, c(round(xms[i], digits=3), round(thalwegs[i], digits=3)))

for(i in seq(from=1, to=XResolution, by=1))
	points = rbind(points, c(round(xms[i], digits=3), round(topsofBank[i], digits=3)))

write.table(header3, file=file.path(directory, file_outputs[12]), row.names=FALSE, col.names=FALSE, quote=FALSE, append=TRUE)
write.table(points, file=file.path(directory, file_outputs[12]), row.names=FALSE, col.names=FALSE, sep= ",", append=TRUE)
print(paste(file_outputs[12], "generated."))

points = data.frame()

for(i in seq(from=1, to=XResolution, by=1))
	points = rbind(points, c(round(xms[i], digits=3), round(channelMeanders[i], digits=3)))

for(i in seq(from=1, to=XResolution, by=1))
	points = rbind(points, c(round(xms[i], digits=3), round(bankPoints[i,ChannelXSPoints], digits=3)))

for(i in seq(from=1, to=XResolution, by=1))
	points = rbind(points, c(round(xms[i], digits=3), round(bankPoints[i,1], digits=3)))

for(i in seq(from=1, to=XResolution, by=1))
	points = rbind(points, c(round(xms[i], digits=3), round(yRightTop[i], digits=3)))

for(i in seq(from=1, to=XResolution, by=1))
	points = rbind(points, c(round(xms[i], digits=3), round(yLeftTop[i], digits=3)))

for(i in seq(from=1, to=XResolution, by=1))
	points = rbind(points, c(round(xms[i], digits=3), round(yRightToe[i], digits=3)))

for(i in seq(from=1, to=XResolution, by=1))
	points = rbind(points, c(round(xms[i], digits=3), round(yLeftToe[i], digits=3)))

write.table(header2, file=file.path(directory, file_outputs[13]), row.names=FALSE, col.names=FALSE, quote=FALSE, append=TRUE)
write.table(points, file=file.path(directory, file_outputs[13]), row.names=FALSE, col.names=FALSE, sep= ",", append=TRUE)
print(paste(file_outputs[13], "generated."))

print("Done.")

}


#' @export
load.tped <- function(prefix) {
  tped.file <- paste0(prefix, '.tped')
  tfam.file <- paste0(prefix, '.tfam')
  stopifnot(file.exists(tped.file), file.exists(tfam.file))

  geno.samples <- read.table(tfam.file)
  n.samples <- nrow(geno.samples)

  geno.data <- scan(tped.file, character())
  n.snps <- length(geno.data)/(2*n.samples+4)

  dim(geno.data) <- c(2*n.samples+4, n.snps)

  geno.raw <- geno.data[-(1:4), ]
  geno.info <- geno.data[1:4, ]
  rm('geno.data')
  gc(FALSE)

  colnames(geno.info) <- c('chromosome', 'id', 'distance', 'position')

  alleles <- sort(unique(as.vector(geno.raw)))
  # Put '0' (missing) at the end
  alleles <- c(alleles[alleles !='0'], '0')
  n.alleles <- length(alleles)-1
  rev.order <- c(n.alleles:1, n.alleles+1)

  # This is the most time consuming step
  has.what <- t(apply(geno.raw, 2, function (x) alleles %in% x))

  # A allele is first alphabetically
  # B allele is last alphabetically
  a.allele <- alleles[apply(has.what, 1, which.max)]
  b.allele <- (alleles[rev.order])[apply(has.what[, rev.order], 1, which.max)]
  b.allele[a.allele==b.allele] <- NA

  geno.both <- apply(geno.raw, 1, function (x) x != a.allele)
  geno.both[geno.raw=='0'] <- NA

  # Add even and odd columns to get diploid genotype code (# of b alleles)
  geno <- geno.both[, 2*(1:n.samples)-1] + geno.both[, 2*(1:n.samples)]

  geno.info$a <- a.allele
  geno.info$b <- b.allele

  colnames(geno) <- make.names(geno.samples$V2)
  rownames(geno) <- make.names(geno.info$id)

  return (list(geno=geno, geno.info=geno.info))
}


library(Seurat)

write_csv = function(vec, fn){write.table(vec, file = fn, append = FALSE, quote = FALSE, sep = ",",
                eol = "\n", na = "NA", dec = ".", row.names = TRUE,
                col.names = TRUE, qmethod = c("escape", "double"),
                fileEncoding = "")}

data = Read10X(data.dir = "b_cells/hg19")
x <- CreateSeuratObject(counts = data,  project = 'b_cells')

to_merge_name = c('b_cells', 'cd4_t_helper', 'cd14_monocytes', 'cytotoxic_t', 'cd56_nk', 'cd34')
to_merge_obj = c()

for (ct in to_merge_name[2:6]) {
    fn = paste0(ct, '/hg19')
    data = Read10X(data.dir = fn)
    obj <- CreateSeuratObject(counts = data, project = ct)
    to_merge_obj = cbind(to_merge_obj, obj)
    }

pbmc.big <- merge(x, y = to_merge_obj, add.cell.ids = to_merge_name, project = "PBMCbig")
pbmc.big = NormalizeData(pbmc.big, normalization.method = "LogNormalize", scale.factor = 10000)
pbmc.big = ScaleData(pbmc.big)

markers = FindAllMarkers(pbmc.big)
write_csv(markers, 'seurat_markers.csv')


###################################################################################################################
##
## This script re-maps gridded 500m climate data to match HRUs generated for the Okanagan basin. Whenever a new
## *.rvh file is generated for the model domain, this script must be executed to remap climate data as well.
##
## Original script produced by JF; Minor adjustments made by LAB Apri-12-2019
##
###################################################################################################################

## Source file configuration
source("/var/obwb-hydro-modelling/file-config.R")

suppressMessages(library(proj4))
suppressMessages(library(ncdf4))
suppressMessages(library(ncdf4.helpers))
suppressMessages(library(ramify))
suppressMessages(library(FNN))
suppressMessages(library(pracma))
suppressMessages(library(R.utils))
suppressMessages(library(utils))
suppressMessages(library(raster))

# Load base packages for error-free execution using Rscript from the command line
# require(stats)
# require(graphics)
# require(grDevices)
# require(utils)
# require(datasets)
require(methods)
# require(base)
# require(tfruns)

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

Remake.Data <- TRUE

output.dir <- file.path(global.input.dir, processed.climate.dir)

if (Remake.Data){

  print("...loading high-res HRU grid point indices...")

  input.dir <- file.path(global.input.dir, processed.spatial.dir)

  input.file <- okanagan.hru.table.file

  load(file.path(input.dir,input.file))

  HRU <- DT[,c("coords.x","coords.y","subbasin","Tidy.ID","X","Y")]

  print("...saving to trimmed-down file...")

 # nc_close(f)

  rm(DT)

  rm(input.dir)

  rm(input.file)

 # rm(f)

  save.image(file.path(output.dir, paste("spatial.grid.data", Sys.Date(), "RData", sep = ".")))

  } else {

    print("...loading spatial data...")

    load(file.path(output.dir, spatial.grid.data.processed.file))
  }

args <- commandArgs(trailingOnly=TRUE)
if (length(args)==1) {
  Var <- args[1]
} else{
  stop("Missing tasmin/tasmax/pr argument.")
}

print("...loading climate data grid point time/lat/lon...")

input.dir <- file.path(global.input.dir, raw.climate.in.dir)

if(Var == "tasmax"){input.file <- tasmax.raw.in.file}
if(Var == "tasmin"){input.file <- tasmin.raw.in.file}
if(Var == "pr"){input.file <- precip.raw.in.file}

f <- nc_open(file.path(input.dir,input.file))

lat=ncvar_get(f,"lat")

d <- dim(lat)
nlat <- d[1]
nlon <- d[2]
lat <- flatten(lat)
lon <- flatten(ncvar_get(f,"lon"))
time <- ncvar_get(f,"time")
nt <- length(time)

print("...finding nearest neighbour...")

CLIMlatlon <- data.frame(lat = lat, lon = lon)

HRUlatlon <- data.frame(lat = HRU$Y, lon = HRU$X)

nns <- get.knnx(CLIMlatlon, HRUlatlon, k=1)

HRUtoCLIMmapping <- nns$nn.index

HRUlist <- unique(HRU$Tidy.ID)

print("..loading full climate dataset...")

CLIMfull <- array(0., c(nlat * nlon, nt))

pb <- txtProgressBar(min = 0, max = nt, style = 3)

for (t in 1:nt){

  CLIMfull[,t] <- flatten(ncvar_get(f, Var, start=c(1,1,t), count = c(-1,-1,1)))

  setTxtProgressBar(pb, t)
}

close(pb)

print("...calculating weighted per-HRU climate data...")

CLIMts <- array(0, c(length(HRUlist), nt))

iHRU <- 0

pb <- txtProgressBar(min = 0, max = length(HRUlist), style = 3)

for (nHRU in HRUlist){

  print(paste("nHRU=", nHRU, sep=""))

  setTxtProgressBar(pb, nHRU)

  if (!grepl("NA",nHRU)){

    iHRU <- iHRU + 1
    #Get indices from full list that match the unique(ID)
    i <- which(HRU$Tidy.ID == nHRU)
    #For these indices, get all unique HRUtoCLIMmapping values
    HRUClimOverlaps <- HRUtoCLIMmapping[i]

    nTot <- length(HRUClimOverlaps)

    Overlaps <- unique(HRUClimOverlaps)#Loop over unique clim cells
    #print(paste("Total number of unique climate grid cells under HRU ",nHRU,"=",length(Overlaps),sep=""))
    for (c.ind in Overlaps){

      nOverlap <- length(which(HRUClimOverlaps == c.ind))

      w <- nOverlap/nTot

      ts <- CLIMfull[c.ind, ]

      if (any(is.na(ts))){
        stop("Found na in climate data time series.")
      }
      CLIMts[iHRU,]=CLIMts[iHRU,]+ ts * w
    }
  }
}

close(pb)

print("...writing HRU climate file to netCDF...")

dim1 <- ncdim_def("HRU", units="HRU", HRUlist, longname="HRU_ID")

dim2 <- ncdim_def("time", units="days since 1950-01-01 00:00:00", time, longname="days since 1950-01-01 00:00:00")

if(Var == "pr"){
  HRU_def <- ncvar_def(Var, "mm", list(dim1,dim2), prec="float")
} else {
  HRU_def <- ncvar_def(Var, "deg_C", list(dim1,dim2), prec="float")
}

ncout <- nc_create(file.path(output.dir, paste(Var, "HRU.timeseries", Sys.Date(), "nc", sep=".")), list(HRU_def), force_v4=T)

ncvar_put(ncout,HRU_def,CLIMts)

ncatt_put(ncout,"time","calendar","gregorian")

nc_close(ncout)

print("Done!")


library(changepoint)
library(dplyr)

air_data <- read.table("E:\\airbox-May.csv", header = FALSE)
colnames(air_data) <- c("date_time", "ID", "PM25", "T", "Humid", "Coor_x", "Coor_y")
air_data$f_time <- as.POSIXct(strptime(air_data$date_time, "%Y-%m-%dT%H:%M:%SZ",tz = "Etc/GMT+8"))

sensor_ID <- unique(air_data$ID)
for(j in 1:101){ #應該要到length(sensor_ID)
  if( j == 6 || j == 7 || j == 8 || j == 11 || j == 15 || j == 19 || j == 24 ||
        j == 25 || j == 27 || j == 28 || j == 29 || j == 32 || j == 43 || j == 51 ||
        j == 52 || j == 53 || j == 55 || j == 57 || j == 62 || j == 66 || j == 70 ||
        j == 71 || j == 76 || j == 80 || j == 84 || j == 86 || j == 92 || j == 94 ||
        j == 97 || j == 99
      ) next
  if( j == 82 ) next
	PM25_of_sensor <- subset(air_data, ID == sensor_ID[j])

	del_index_arr = group_by(PM25_of_sensor, as.Date(f_time, tz = "Etc/GMT+8")) %>%
	summarise( length(PM25) > 5 )

	Day_ID <- unique(as.Date(PM25_of_sensor$f_time, tz = "Etc/GMT+8"))
	del_index = which(as.data.frame(del_index_arr[,2])[,1] %in% 0)

	if(length(del_index) != 0) PM25_of_sensor <- PM25_of_sensor[ -which( Day_ID[del_index] == as.Date(PM25_of_sensor$f_time, tz = "Etc/GMT+8") ),]
	#get Day_ID after deleting the ones with length shorter than 4
	Day_ID <- unique(as.Date(PM25_of_sensor$f_time, tz = "Etc/GMT+8"))

	ch_id_group = group_by(PM25_of_sensor, as.Date(f_time, tz = "Etc/GMT+8")) %>%
	summarise(cpts(cpt.meanvar(PM25)))

	ch_id = as.data.frame(ch_id_group[,2])[,1]

	if( length(ch_id) == 0 ) next
	for(i in 1:length(ch_id)){
	    #if( j == 5 && i == 11 ) break
		if(is.na(ch_id[i])) {
			print(i)
			next
		}
		sensor_of_day <- PM25_of_sensor[ which( as.Date(PM25_of_sensor$f_time, tz = "Etc/GMT+8") == Day_ID[i] ), ]
		#plot(sensor_of_day$PM25, sensor_of_day$date_d)
		zz_b = 1:ch_id[i]
		xx_b = sensor_of_day$f_time[zz_b]
		yy_b = rep(mean(sensor_of_day$PM25[zz_b]), times = length(zz_b))
		zz_f = (ch_id[i]+1):length(sensor_of_day$PM25)
		xx_f = sensor_of_day$f_time[zz_f]
		yy_f = rep(mean(sensor_of_day$PM25[zz_f]), times = length(zz_f))

		plot(as.POSIXct(sensor_of_day$f_time), sensor_of_day$PM25,type = "o", xlab = "PM2.5", ylab = "Time")
		lines(xx_b,yy_b,col="red")
		lines(xx_f,yy_f,col="red")

		#curve(x=sensor_of_day$PM25[ch_id],as.numeric(sensor_of_day$f_time[1]), as.numeric(sensor_of_day$f_time[ch_id]))

		pic_name <- paste0("E:\\myGraph\\Sensor",j, "_p", i,".png")
		dev.copy(png,pic_name)
		dev.off()
		#time_dif <- diff(time_of_d)
		#diff_in_dat <- as.numeric(as.Date(time_of_d[2]) - as.Date(time_of_d[1]))
	}
}


# Univariant Curve option in R --------------------------------------------------------------------
# Summary: functions to calculate temperatures at given logK and pressures, calculate
#          pressures at given logK and temperatures, and to export and plot results.
# Author: Grayson Boyer
# Last updated: September 20, 2021

########### UNIVARIANT CURVE FUNCTIONS ###########

uc_solveT <- function(logK, species, state, coeff,
                      pressures = 1, IS=0, minT = 0.1, maxT = 100, tol=0.00001){

  user_minT <- minT
  user_maxT <- maxT

  # create a data frame to hold results
  PlH <- rep(NA, length(pressures)) # placeholder

  df <- data.frame(P = sprintf("%.3f", round(pressures, 3)),
                   T = PlH,
                   rho = PlH,
                   logK = PlH,
                   G = PlH,
                   H = PlH,
                   S = PlH,
                   V = PlH,
                   Cp = PlH,
                   stringsAsFactors=FALSE
                 )

  for (pressure in pressures){

    minT <- user_minT
    maxT <- user_maxT
    completed_iter <- 0
    converged <- FALSE

    while(!converged){
      if(completed_iter > 100){
        warning("Too many iterations (>100). Terminating calculation.")
        break
      }

      # perform a subcrt calculation using a guess
      found_guesslogK <- FALSE
      iter_guesslogK <- 0
      while(!found_guesslogK){
        if(iter_guesslogK == 0){
          guessT <- mean(c(minT, maxT))
        }else if(iter_guesslogK <= 20){
          guessT <- seq(minT, maxT, length.out=20)[iter_guesslogK]
        }else{
          warning("Could not find a viable temperature guess in this range after 20 tries. Terminating calculation.")
          break
        }

        guess_calc <- suppressMessages(subcrt(species, state, coeff, T = guessT, P = pressure, IS = IS, exceed.Ttr = T))
        guesslogK <- guess_calc$out$logK

        if(!is.na(guesslogK) && is.finite(guesslogK)){
          found_guesslogK <- TRUE
        }else{
          iter_guesslogK <- iter_guesslogK + 1
        }
      }

      if(is.na(guesslogK) | !is.finite(guesslogK)){
        break
      }

      # check if initial guess is close enough to actual logK within tolerance
      if(abs(logK - guesslogK) < tol){
        this_P <- sprintf("%.3f", round(pressure, 3))
        df[df[, "P"] == this_P, "T"] <- sprintf("%.3f", round(guessT, 3))

        if("rho" %in% names(guess_calc$out)){
          df[df[, "P"] == this_P, "rho"] <- sprintf("%.3f", round(guess_calc$out$rho, 3))
        }
        df[df[, "P"] == this_P, "logK"] <- sprintf("%.3f", round(guesslogK, 3))
        df[df[, "P"] == this_P, "G"] <- sprintf("%.0f", round(guess_calc$out$G, 0))
        df[df[, "P"] == this_P, "H"] <- sprintf("%.0f", round(guess_calc$out$H, 0))
        df[df[, "P"] == this_P, "S"] <- sprintf("%.1f", round(guess_calc$out$S, 1))
        df[df[, "P"] == this_P, "V"] <- sprintf("%.1f", round(guess_calc$out$V, 1))
        df[df[, "P"] == this_P, "Cp"] <- sprintf("%.1f", round(guess_calc$out$Cp, 1))

        result <- list(reaction = guess_calc$reaction, out = df)

        converged <- TRUE
        break
      }

      # perform an initial calculation across a range of temperatures bounded by current minT and maxT
      init_calc <- suppressMessages(subcrt(species, state, coeff, T = seq(minT, maxT, length.out = 200), P = pressure, IS=IS, exceed.Ttr=T)$out)

      # Check if logK falls between any of the temperature iterations in the initial calculation
      logK_check_complete <- FALSE
      for (i in 1:(length(init_calc$logK)-1)){

        logKmin <- init_calc$logK[i]
        logKmax <- init_calc$logK[i+1]

        if ((!is.finite(logKmin)) | (!is.finite(logKmax))){
          if(!("Warning" %in% colnames(df))){
            df$Warning <-PlH # create 'Warning' column
          }

          this_P <- sprintf("%.3f", round(pressure, 3))
          df[df[, "P"] == this_P, "Warning"] <- paste("Could not converge on T for this P within", user_minT, "and", user_maxT, "degC")

          result <- list(reaction = guess_calc$reaction, out = df)
          converged <- TRUE
        } else if ((logK <= 0) & (logK <= logKmin) & (logK >= logKmax)){
          minT <- init_calc$T[i]
          maxT <- init_calc$T[i+1]
          logK_check_complete <- TRUE
          break
        } else if ((logK >= 0) & (logK <= logKmin) & (logK >= logKmax)){
          minT <- init_calc$T[i]
          maxT <- init_calc$T[i+1]
          logK_check_complete <- TRUE
          break
        } else if ((logK < 0) & (logK >= logKmin) & (logK <= logKmax)){
          minT <- init_calc$T[i]
          maxT <- init_calc$T[i+1]
          logK_check_complete <- TRUE
          break
        } else if ((i == (length(init_calc$logK)-1)) & (!logK_check_complete)){
          if(!("Warning" %in% colnames(df))){
            df$Warning <-PlH # create 'Warning' column
          }

          this_P <- sprintf("%.3f", round(pressure, 3))
          df[df[, "P"] == this_P, "Warning"] <- paste("Could not converge on T for this P within", user_minT, "and", user_maxT, "degC")

          result <- list(reaction = guess_calc$reaction, out = df)
          converged <- TRUE
        }

      } # end logK for loop

      completed_iter <- completed_iter + 1 # increase iteration counter

    } # end !converged while loop

  } # end pressure for loop

  # convert columns to numeric
  df <- result[["out"]]
  cols.num <- c("P", "T", "logK", "G", "H", "S", "V", "Cp")

  if(!("rho" %in% names(guess_calc$out))){
    df <- df[ , -which(names(df) %in% c("rho"))] # drop the empty rho column
  }else{
    cols.num <- c(cols.num, "rho")
  }

  df[cols.num] <- sapply(df[cols.num], as.numeric)
  result[["out"]] <- df

  return(result)

} # end uc_solveT function

uc_solveP <- function(logK, species, state, coeff,
                      temperatures = 1, IS=0,
                      minP = 1, maxP = 500, tol=0.00001){

  user_minP <- minP
  user_maxP <- maxP

  # create a data frame to hold results
  PlH <- rep(NA, length(temperatures)) # placeholder

  df <- data.frame(P = PlH,
                   T = sprintf("%.3f", round(temperatures, 3)),
                   rho = PlH,
                   logK = PlH,
                   G = PlH,
                   H = PlH,
                   S = PlH,
                   V = PlH,
                   Cp = PlH,
                   stringsAsFactors=FALSE
                 )

  for (temperature in temperatures){

    minP <- user_minP
    maxP <- user_maxP
    completed_iter <- 0
    converged <- FALSE

    while(!converged){
      if(completed_iter > 100){
        print("Too many iterations (>100). Terminating calculation.")
        break
      }

      # perform a subcrt calculation using a guess
      guessP <- mean(c(minP, maxP))
      guess_calc <- suppressMessages(subcrt(species, state, coeff, P = guessP, T = temperature, IS=IS))
      guesslogK <- guess_calc$out$logK

      # check if initial guess is close enough to actual logK within tolerance
      if(abs(logK - guesslogK) < tol){
        this_T <- sprintf("%.3f", round(temperature, 3))
        df[df[, "T"] == this_T, "P"] <- sprintf("%.3f", round(guessP, 3))
        df[df[, "T"] == this_T, "rho"] <- sprintf("%.3f", round(guess_calc$out$rho, 3))
        df[df[, "T"] == this_T, "logK"] <- sprintf("%.3f", round(guesslogK, 3))
        df[df[, "T"] == this_T, "G"] <- sprintf("%.0f", round(guess_calc$out$G, 0))
        df[df[, "T"] == this_T, "H"] <- sprintf("%.0f", round(guess_calc$out$H, 0))
        df[df[, "T"] == this_T, "S"] <- sprintf("%.1f", round(guess_calc$out$S, 1))
        df[df[, "T"] == this_T, "V"] <- sprintf("%.1f", round(guess_calc$out$V, 1))
        df[df[, "T"] == this_T, "Cp"] <- sprintf("%.1f", round(guess_calc$out$Cp, 1))

        result <- list(reaction = guess_calc$reaction, out = df)

        converged <- TRUE
        break
      }

      # perform an initial calculation across a range of temperatures bounded by current minT and maxT
      init_calc <- suppressMessages(subcrt(species, state, coeff, P = seq(minP, maxP, length.out = 10), T = temperature, IS=IS)$out)

      # Check if logK falls between any of the temperature iterations in the initial calculation
      logK_check_complete <- FALSE
      for (i in 1:(length(init_calc$logK)-1)){

        logKmin <- init_calc$logK[i]
        logKmax <- init_calc$logK[i+1]
        if ((!is.finite(logKmin)) | (!is.finite(logKmax))){
          if(!("Warning" %in% colnames(df))){
            df$Warning <-PlH # create 'Warning' column
          }

          this_T <- sprintf("%.3f", round(pressure, 3))
          df[df[, "T"] == this_T, "Warning"] <- paste("Could not converge on P for this T within", user_minP, "and", user_maxP, "bars")

          result <- list(reaction = guess_calc$reaction, out = df)
          converged <- TRUE
        }else if ((logK >= 0) & (logK <= logKmin) & (logK >= logKmax)){
          minP <- init_calc$P[i]
          maxP <- init_calc$P[i+1]
          logK_check_complete <- TRUE
          break
        } else if ((logK <= 0) & (logK <= logKmin) & (logK >= logKmax)){
          minP <- init_calc$P[i]
          maxP <- init_calc$P[i+1]
          logK_check_complete <- TRUE
          break
        } else if ((logK > 0) & (logK >= logKmin) & (logK <= logKmax)){
          minP <- init_calc$P[i]
          maxP <- init_calc$P[i+1]
          logK_check_complete <- TRUE
          break
        } else if ((i == (length(init_calc$logK)-1)) & (!logK_check_complete)){
          if(!("Warning" %in% colnames(df))){
            df$Warning <-PlH # create 'Warning' column
          }

          this_T <- sprintf("%.3f", round(temperature, 3))
          df[df[, "T"] == this_T, "Warning"] <- paste("Could not converge on P for this T within", user_minP, "and", user_maxP, "bars")

          result <- list(reaction = guess_calc$reaction, out = df)
          converged <- TRUE
        }

      } # end logK for loop

      completed_iter <- completed_iter + 1 # increase iteration counter

    } # end !converged while loop

  } # end pressure for loop

  # convert columns to numeric
  df <- result[["out"]]
  cols.num <- c("P", "T", "logK", "G", "H", "S", "V", "Cp")

  if(!("rho" %in% names(guess_calc$out))){
    df <- df[ , -which(names(df) %in% c("rho"))] # drop the empty rho column
  }else{
    cols.num <- c(cols.num, "rho")
  }

  df[cols.num] <- sapply(df[cols.num], as.numeric)
  result[["out"]] <- df

  return(result)

} # end uc_solveP function

write_csv_output <- function(result, create_output_csv=F){
    # write csv table
    if(create_output_csv){
      write.csv(result$out, csv_filename, row.names=F)
    }
}

### Create plot temperature-based
create_output_plot_T <- function(logK, species, state, coeff, pressures, minT, maxT, res=300){
    # print(as.numeric(as.character(result$out$T)))
    calc <- subcrt(species, state, coeff, T=seq(minT, maxT, length.out=res), P=pressures[1])$out$logK

    if(min(calc, na.rm=T) != Inf){
        if(logK < min(calc, na.rm=T)){
            this_ylim <- c(logK-1, max(calc, na.rm=T))
        } else if(logK > max(calc, na.rm=T)){
            this_ylim <- c(min(calc, na.rm=T), logK+1)
        } else {
            this_ylim <- c(min(calc, na.rm=T), max(calc, na.rm=T))
        }
    }

    plot(x=NA,
         y=NA,
         xlim=c(minT-10, maxT+10),
         ylim=this_ylim,
         ylab="logK",
         xlab=expression("Temperature " ( degree*C)),
         type="l")
    grid (NULL, NULL, lty = 1, col = "lightgray")
    lines(x=seq(minT, maxT, length.out=res), y=rep(logK, res), col="red", lwd=3)
    for(pressure in pressures){
      lines(x=seq(minT, maxT, length.out=res),
            y=subcrt(species, state, coeff, T=seq(minT, maxT, length.out=res), P=pressure)$out$logK)
    }

}

### Create plot pressure-based
create_output_plot_P <- function(logK, species, state, coeff, temperatures, minP, maxP, res=300){
    #print(as.numeric(as.character(result$out$T)))
    calc <- subcrt(species, state, coeff, P=seq(minP, maxP, length.out=res), T=temperatures[1])$out$logK

    if(min(calc, na.rm=T) != Inf){
        if(logK < min(calc, na.rm=T)){
            this_ylim <- c(logK-1, max(calc, na.rm=T))
        } else if(logK > max(calc, na.rm=T)){
            this_ylim <- c(min(calc, na.rm=T), logK+1)
        } else {
            this_ylim <- c(min(calc, na.rm=T), max(calc, na.rm=T))
        }
    }

    plot(x=NA,
         y=NA,
         xlim=c(minP-1, maxP+1),
         ylim=this_ylim,
         ylab="logK",
         xlab="Pressure (bars)",
         type="l")
    grid (NULL, NULL, lty = 1, col = "lightgray")
    lines(x=seq(minP, maxP, length.out=res), y=rep(logK, res), col="red", lwd=3)
    for(temperature in temperatures){
      lines(x=seq(minP, maxP, length.out=res),
            y=subcrt(species, state, coeff, P=seq(minP, maxP, length.out=res), T=temperature)$out$logK)
    }

}

thermoinfo <- function(species){
    return(info(info(species)))
}


library(lme4)
source("R/functions/get_score.r")

fn.si = file.path(PROJECT_DIR, "generated_data", "SLE", "SLE_sample_info_2_sle.txt")
info = fread(fn.si, data.table = F)

info = info %>%
  mutate(DA=factor(DA, levels=c("low","mid","high")),
         DAn = as.numeric(DA),
         SUBJECT = factor(SUBJECT, levels=
                            unique(SUBJECT[order(as.numeric(sub("SLE-","",SUBJECT)))])))

info = info %>%
  mutate(DA2 = ifelse(DAn>1, "high", "low")) %>%
  group_by(SUBJECT) %>%
  mutate(DAn.min = min(DAn, na.rm=t), DAn.max = max(DAn, na.rm=t)) %>%
  ungroup()

si = info$DAn.min==1 & info$DAn.max>1 & (info$DAn==info$DAn.min | info$DAn==info$DAn.max)
sum(si)
subj = info$SUBJECT[si] %>% as.character() %>% unique()

fn.ge = file.path(PROJECT_DIR, "generated_data", "SLE", "SLE_ge_matrix_gene_sle.txt")
dat = fread(fn.ge, data.table = F) %>%
  gather("SAMPLE_NAME", "value", -gene) %>%
  inner_join(info[si,] %>% dplyr::select(SAMPLE_NAME, SUBJECT, PG, DA2), by="SAMPLE_NAME")

datm = dat %>%
  group_by(gene, SUBJECT, PG, DA2) %>%
  summarise(value = mean(value, na.rm=T)) %>%
  ungroup()

dat.fc = datm %>%
  spread("DA2","value") %>%
  mutate(Delta = high-low)

dat2 = dat.fc %>%
  dplyr::select(-PG, -high, -low) %>%
  spread(SUBJECT, Delta) %>%
  tibble::column_to_rownames("gene") %>%
  data.matrix()

fn.btm = file.path(PROJECT_DIR, "data", "SLE", "sle_figure6A_BTM.txt")
df.btm = fread(fn.btm) %>%
  mutate(ID = paste0("DC.",ID))

fn.subj = file.path(PROJECT_DIR, "data", "SLE", "sle_figure6A_subjects.txt")
df.subj = fread(fn.subj)

library(tmod)
data(tmod)
list.mod = tmod[df.btm$ID]

fn.pg = file.path(PROJECT_DIR, "data", "SLE", "phenotypes", "SLE_SUBJECT_PG.txt")
df.pg = read_tsv(fn.pg)

dn.out = file.path(PROJECT_DIR, "figure_generation")
dir.create(dn.out, showWarnings = F)

res.all = matrix(NA, nrow = nrow(list.mod$MODULES), ncol = ncol(dat2))
rownames(res.all) = df.btm$ID
colnames(res.all) = colnames(dat2)

for(s in 1:ncol(dat2)) {
  res = tmodCERNOtest(rownames(dat2)[order(dat2[,s], decreasing = T)] ,
                       qval = 999, mset=list.mod, order.by = "none")
  res.all[,s] = res$adj.P.Val
}

isubj = match(df.subj$SUBJECT, colnames(res.all))
isubj = isubj[!is.na(isubj)]
res.all = res.all[,isubj]

df.all = -log10(res.all) %>% t() %>%
  as.data.frame() %>%
  tibble::rownames_to_column("SUBJECT")

DF = left_join(df.all, df.pg, by="SUBJECT")

library(ComplexHeatmap)
library(circlize)

mat.btm = DF %>%
  dplyr::select(-PG) %>%
  tibble::column_to_rownames("SUBJECT") %>%
  data.matrix()
colnames(mat.btm) = with(df.btm, glue::glue("{sub('DC.','',ID)} - {Title}"))
pg = DF %>%
  dplyr::select(SUBJECT, PG) %>%
  mutate(PG = factor(PG)) %>%
  tibble::column_to_rownames("SUBJECT") %>%
  data.matrix()

cm = palette()[-8]
df.n = df.btm %>%
  mutate(Group = factor(Group, levels = unique(df.btm$Group))) %>%
  group_by(Group) %>%
  tally()

hm = Heatmap(mat.btm, name = "-log10(p.adj)", cluster_columns = F, cluster_rows = F, split=pg,
        col = colorRamp2(c(0, 3), c("black", "#F3EC18"))) +
  Heatmap(pg, name="PG", col = cm, show_row_names = T, show_heatmap_legend = F)
# for(i in 1:7){
#   decorate_heatmap_body("-log10(p.adj)", slice = i, {
#     for(j in 1:(nrow(df.n)-1)){
#       grid.lines(rep(sum(df.n$n[1:j])/sum(df.n$n),2), c(0,1), gp = gpar(col = "white", lwd=3, lty = 1))
#     }
#     })
# }
fn.hm1 = file.path(dn.out, "SLE_BTM_PG")
png(paste0(fn.hm1, ".png"), w=800, h=800)
draw(hm)
dev.off()
pdf(paste0(fn.hm1, ".pdf"), w=9, h=10)
draw(hm)
dev.off()

# Compressed heatmap

DF2 = DF %>%
  gather("ID", "p", -SUBJECT, -PG) %>%
  left_join(df.btm, by="ID") %>%
  mutate(Group = factor(Group, levels=rev(unique(Group)))) %>%
  group_by(PG, Group) %>%
  summarise(p.mean = mean(p, na.rm=T)) %>%
  ungroup() %>%
  mutate(PG = paste0("PG",PG))

ggplot(DF2, aes(PG, Group, col=p.mean, size=p.mean)) +
  geom_point() +
  scale_color_distiller(palette = "YlOrRd", direction = 1,
                        guide = guide_colorbar(title="mean -log(FDR)", title.position = "top", title.hjust = 0.5)) +
  scale_size_continuous(range = c(0, 25), guide = F) +
  scale_x_discrete(position = "top") +
  xlab("SLE Patient Groups") +
  ylab(NULL) +
  theme_bw() + theme(legend.position = "bottom")
fn.hm2 = file.path(dn.out, "SLE_BTM_PG_compressed2")
ggsave(paste0(fn.hm2, ".png"), w=7, h=5)
ggsave(paste0(fn.hm2, ".pdf"), w=7, h=5, useDingbats=F)


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

#This is the wrapper for running the LCM model for
# Crozier, Burke, Chasco, Widener and Zabel 2020
# Iconic salmon populations face perilous challenges from climate change across their life cycle
# published in Communications Biology

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

set.seed(10000)
library(plyr)

# Model control parameters---------
#1.Select which model you want to run. Models are defined by which freshwater and marine covariates they include
      #e.g., Model 1:
          # FW: p2TsuFfall
          # In-river: ersstArc.win + ersstWAcoast.sum
          # Transport: ersstArc.win

        model<-"Model1";filename<-"p2TsuFfall"; Fname="F.S3.ParrF"; FW.name="Ffall"
          # model<-"Model2"; filename<-"p2Fsu"; Fname="F.S2.ParrSu"; FW.name="Fsu"
          # model<-"Model3"; filename<-"p2TsuFfall"; Fname="F.S3.ParrF"; FW.name="Ffall"
                arrayname<-paste0(model,".array")
              load(file=paste("Input files/param",arrayname,sep="."),verbose=T) #param.array.1K

#2. Decide how many simulations,populations and climate scenarios you want to run and build list of scenarios
        runs = 10
        years = 75 #2015:2089
        pop<-creeks<-"bearvalley"
#       pop<-creeks<-c("bearvalley","big","camas","loon","marsh","secesh","sulphur","valley")

            climate =c("stationary","4.5" , "8.5"   )
            climateshort =c("1","45" , "85"   )
            quant = c("25", "50", "75")

        nsim<-length(pop)*length(model)*length(climate)*length(quant)#;nsim
        scenario<-length(model)*length(climate)*length(quant);scenario
        scenario.name<-vector("character",length=scenario)
     cnt.scenario=0
        for(l in 1:length(model)){
            for(cc in 1:length(climate)){
            for(qq in 1:length(quant)){
                 cnt.scenario=cnt.scenario+1
               scenario.name[cnt.scenario]=paste(climate[cc],quant[qq],model[l],sep=".");scenario.name
            }}}

#Input files-------------------
    #FW
        source("LCM.fxn.r") #functions for model relationships
        popinit<-read.csv("Input files/Ninit.csv", header = T, row.names = 1)
        hydro<-read.csv(file="Input files/climategrid_survival_80yr_2020_PA.csv",header=TRUE,row.names = NULL);hydro$gridYear<-rep(1:80,length=nrow(hydro))
        FW<-read.csv(file="Input files/SALM.Qflow.csv",header=TRUE,row.names = NULL)#;head(FW)
            FW<-FW[FW$year>=2015,]
            scalefactors<-read.csv(file="Input files/scalefactors.corrected.May2019.csv",row.names=1)#;scalefactors
        su<-read.csv("Input files/AprilJuneAndSurv_LoopsTransport.csv",row.names = NULL,header=TRUE)#;head(su)
            su$LGRtemp<-round_any(su$LGrTempAJ,0.5)#;simtemp
            su$LGRflow<-round_any(su$LGrFlowAJ,20)#;simflow

    #SARs
        if(model=="Model3") sarfile<-"Model3.SAR100.Rdata"  else sarfile<-"Model1.Model2.SAR100.Rdata"
            print(sarfile)
               load(paste0("Input files/",sarfile),verbose=TRUE)

      #collect parameters used in each run
            param.marT<-as.data.frame(t(sarcoefT_rqvs["stationary","50",,]))
                  names(param.marT)<-paste("T",names(param.marT),sep=".")
            param.marI<-as.data.frame(t(sarcoefI_rqvs["stationary","50",,]))
                  names(param.marI)<-paste("I",names(param.marI),sep=".")

# Set up temporary arrays to store data during model runs-----------
    N.new = N = array(0,5)
    surv.s1=surv.trib=surv.inriver=pt=pt.sar=pt.sup=surv.main=surv.s2=surv.s3=surv.sar=surv.sarI=surv.sarT=surv.sup=sup.spr.inriver=sup.spr.transport=sup.sum.inriver=sup.sum.transport=sup.spring=sup.summer=Spawners = Recruits = array(0,years) #indiv years within a run

    # Arrays to save output-----------
      spawner.array<-parrsmolt.array<-recruit.array<-array(0,dim=c(years,runs,length(pop),scenario),dimnames=list(2015:2089,paste0("sim",1:runs),pop,scenario.name))#;dim(spawner.array)
      response<-c("yrQET50","Mean2020","Mean2040","Mean2060","Mean2080","Meanallyears")
            allparam<-c( names(param.marI),names(param.marT),dimnames(param.array.1K)[[2]],response)# ;allparam
      param.array<-array(0,dim=c(runs,length(allparam),length(pop),scenario),dimnames=list(paste0("sim",1:runs),allparam,pop,scenario.name))#;dim(param.array)

#START LOOPING THROUGH SIMULATIONS ========================
    print(Sys.time())
#k=1;l=1;m=1;cc=1;p=1;j=1;qq=1
cnt=0
for(k in 1:length(pop)){ # loop across populations
    cnt.scenario=0
  print(paste("Pop",k,pop[k],Sys.time()))
  ha= popinit[pop[k],"ha"]
  for(cc in 1:length(climate)){
  for(qq in 1:length(quant)){ #loop across quantiles of each climate scenario
     cnt.scenario=cnt.scenario+1;print(scenario.name[cnt.scenario])
  for (j in 1:runs){
   jj<-sample(length(param.array.1K[,1,1]),1)
   jj.sar<-sample(length(sarI_rqys[1,1,1,]),1)
        param<-as.list(param.array.1K[jj,,pop[k]])#;unlist(param)

        #collect parameters used in each run
            param.marT<-as.data.frame(t(sarcoefT_rqvs[climate[cc],quant[qq],,jj.sar]))  #;unlist(param.marT) #dimnames(sarcoefT_rqvs)
            param.marI<-as.data.frame(t(sarcoefI_rqvs[climate[cc],quant[qq],,jj.sar])) #dimnames(sarBeta_frqvs)[[1]][2]
            param.array[j,paste("T",names(param.marT),sep="."),k,scenario.name[cnt.scenario]]<-unlist(param.marT)
            param.array[j,paste("I",names(param.marI),sep="."),k,scenario.name[cnt.scenario]]<-unlist(param.marI)
            param.array[j,names(param),k,scenario.name[cnt.scenario]]<-unlist(param)

        #Load raw T and F projections from TMB model
              T1<- sc_envProj_rqvys[climate[cc],quant[qq],"T.S2.ParrSu",,jj.sar]#*env_sc["T.S2.ParrSu"]+env_mu["T.S2.ParrSu"]
              F1<- sc_envProj_rqvys[climate[cc],quant[qq],Fname,,jj.sar]#*env_sc[Fname]+env_mu[Fname]
          #Add trends
               if(cc>1) T1<-T1+FW[,paste0("Tsu.Q",quant[qq],".RCP",climate[cc])]
               if(cc>1) F1<-F1+FW[,paste0(FW.name,quant[qq],".RCP",climateshort[cc])]
          #Scale for gompertz model coefficients
               T1<-(T1-scalefactors["mean","T.S2.ParrSu"])/scalefactors["sd","T.S2.ParrSu"]
               F1<-(F1-scalefactors["mean",Fname])/scalefactors["sd",Fname]

#Initialize all age classes
     N[1:5] = c(0,0,0,0,0)
        for (i in 1:5){
          xx<-sample(1:dim(envProj_rqvys)[5],1)
          N.new[1] = popinit[pop[k],"stationaryMeanSp"]*exp(param$p1+param$c1*log(popinit[pop[k],"stationaryMeanSp"]/ha))
          if(filename=="p2Fsu")        surv.trib[i] = exp(param$p2+param$c2*log(max(N[1]/ha,1))+param$BF*F1[i])
          if(length(grep("p2Tsu",filename))>0)   {surv.trib[i] = exp(param$p2+param$c2*log(max(N[1]/ha,1))+param$BT*T1[i]+param$BF*F1[i])}
          if(length(grep("c2",filename))>0)   {surv.trib[i] = exp(param$p2+param$c2*log(max(N[1]/ha,1))+param$BT*T1[i]*log(max(N[1]/ha,1))+param$BF*F1[i]*log(max(N[1]/ha,1)))}
          surv.inriver[i]=  hydro[hydro$gridYear==envProj_rqvys[climate[cc],quant[qq],"gridYear",i,xx] &
                    hydro$flow==envProj_rqvys[climate[cc],quant[qq],"gridFlow",i,xx]
                  & hydro$temp==envProj_rqvys[climate[cc],quant[qq],"gridTemp",i,xx],"surv"]
          pt[i]=hydro[hydro$gridYear==envProj_rqvys[climate[cc],quant[qq],"gridYear",i,xx] &
                  hydro$flow==envProj_rqvys[climate[cc],quant[qq],"gridFlow",i,xx]
                & hydro$temp==envProj_rqvys[climate[cc],quant[qq],"gridTemp",i,xx],"proptrans"]
          surv.main[i] =S2.mainstem(pt=pt[i], s.inriver=surv.inriver[i])
          pt.sar[i]<-pt[i]*0.98/((1-pt[i])*surv.inriver[i]+pt[i]*0.98)
          N.new[2] = N[1]*surv.trib[i]*surv.main[i]
          N.new[3] = N[2]*s3.fxn(pt=pt.sar[i],sarI=plogis(sarI_rqys[climate[cc],quant[qq],i,xx]),sarT=plogis(sarT_rqys[climate[cc],quant[qq],i,xx]),b3=param$b3,b4=param$b4,So=param$s0)$s3
          N.new[4] = N[3]*(1-param$b3)*param$s0
          N.new[5] = N[4]*(1-param$b4)*param$s0
          N = N.new
        };N

             for (i in 1:years){
          # Calculate effective spawners for recruit calculations
          #In the first year, we do not have pt.sup yet, so we are just using the average survival of upstream migrants
              if(i==1){
                      myvar="aprmayjunetempLGR";lgrtemp<-sc_envProj_rqvys[climate[cc],quant[qq],myvar,i,jj.sar]#*env_sc[myvar]+env_mu[myvar]
                      myvar="aprmayjuneflowLGR";lgrflow<-sc_envProj_rqvys[climate[cc],quant[qq],myvar,i,jj.sar]#*env_sc[myvar]+env_mu[myvar]
                      simtemp<-round_any(lgrtemp,0.5)#;simtemp
                      simflow<-round_any(lgrflow,20)#;simflow
                      su.Temp.matches<-su[which(abs(simtemp-(su$LGRtemp))==min(abs(simtemp-(su$LGRtemp)))),]#;su.Temp.matches
                      su.Flow.matches<-su.Temp.matches[which(abs(simflow-(su.Temp.matches$LGRflow))==min(abs(simflow-(su.Temp.matches$LGRflow)))),]#;su.Flow.matches
                      surv.sup[i]<-sample(su.Flow.matches$SpringSurv_BoToLG,1)
                      if(k %in% c(6,8)) surv.sup[i]<-sample(su.Flow.matches$SummerSurv_BoToLG,1)

                      spawners = (param$b4*N[4] + param$f5*N[5])*surv.sup[i]*0.9
              }

          #In subsequent years, we use output from SARs in the previous year to determine the precent of upstream migrants that were transported as juveniles
            if(i>1){    spawners = (param$b4*N[4] + param$f5*N[5])*surv.sup[i-1]*0.9 }

    #Survival in each age class
          surv.s1[i]=exp(param$p1+param$c1*log(spawners/ha))
                 if(filename=="p2Fsu")        surv.trib[i] = exp(param$p2+param$c2*log(max(N[1]/ha,1))+param$BF*F1[i])
                 if(length(grep("p2Tsu",filename))>0)   {surv.trib[i] = exp(param$p2+param$c2*log(max(N[1]/ha,1))+param$BT*T1[i]+param$BF*F1[i])}
                 if(length(grep("c2",filename))>0)   {surv.trib[i] = exp(param$p2+param$c2*log(max(N[1]/ha,1))+param$BT*T1[i]*log(max(N[1]/ha,1))+param$BF*F1[i]*log(max(N[1]/ha,1)))}
          surv.inriver[i]=  hydro[hydro$gridYear==envProj_rqvys[climate[cc],quant[qq],"gridYear",i,jj.sar] &
                                  hydro$flow==envProj_rqvys[climate[cc],quant[qq],"gridFlow",i,jj.sar] &
                                  hydro$temp==envProj_rqvys[climate[cc],quant[qq],"gridTemp",i,jj.sar],"surv"]
          pt[i]=  hydro[hydro$gridYear==envProj_rqvys[climate[cc],quant[qq],"gridYear",i,jj.sar] &
                        hydro$flow==envProj_rqvys[climate[cc],quant[qq],"gridFlow",i,jj.sar] &
                        hydro$temp==envProj_rqvys[climate[cc],quant[qq],"gridTemp",i,jj.sar],"proptrans"]
          surv.main[i] =S2.mainstem(pt=pt[i], s.inriver=surv.inriver[i])
          pt.sar[i]<-pt[i]*0.98/((1-pt[i])*surv.inriver[i]+pt[i]*0.98)
          surv.s2[i] =surv.trib[i]*surv.main[i]
                s3 = s3.fxn(pt=pt.sar[i],sarI=plogis(sarI_rqys[climate[cc],quant[qq],i,jj.sar]),sarT=plogis(sarT_rqys[climate[cc],quant[qq],i,jj.sar]),b3=param$b3,b4=param$b4,So=param$s0)
          surv.s3[i]   = s3$s3
          surv.sarI[i] = s3$sarI
          surv.sarT[i] = s3$sarT
          surv.sar[i]  = s3$sar
      #tracking in-river and transported fish separately for upstream migration survival
          pt.sup[i]<-pt.sar[i]*surv.sarT[i]/surv.sar[i]

              myvar="aprmayjunetempLGR";lgrtemp<-sc_envProj_rqvys[climate[cc],quant[qq],myvar,i,jj.sar]#*env_sc[myvar]+env_mu[myvar]
              myvar="aprmayjuneflowLGR";lgrflow<-sc_envProj_rqvys[climate[cc],quant[qq],myvar,i,jj.sar]#*env_sc[myvar]+env_mu[myvar]
              simtemp<-round_any(lgrtemp,0.5)#;simtemp
              simflow<-round_any(lgrflow,20)#;simflow
              su.Temp.matches<-su[which(abs(simtemp-(su$LGRtemp))==min(abs(simtemp-(su$LGRtemp)))),]#;su.Temp.matches
              su.Flow.matches<-su.Temp.matches[which(abs(simflow-(su.Temp.matches$LGRflow))==min(abs(simflow-(su.Temp.matches$LGRflow)))),]#;su.Flow.matches
                          xx<-sample(1:nrow(su.Flow.matches),size=1);xx
                  sup.spr.inriver[i]<-su.Flow.matches$Spr_Pred_BOLG_inriver[xx]
                  sup.spr.transport[i]<-su.Flow.matches$Spr_Pred_BOLG_transport[xx]
                  sup.sum.inriver[i]<-su.Flow.matches$Sum_Pred_BOLG_inriver[xx]
                  sup.sum.transport[i]<-su.Flow.matches$Sum_Pred_BOLG_transport[xx]

                  sup.spring[i]<-pt.sup[i]* sup.spr.transport[i]+(1-pt.sup[i])* sup.spr.inriver[i]
                  sup.summer[i]<-pt.sup[i]* sup.sum.transport[i]+(1-pt.sup[i])* sup.sum.inriver[i]
          surv.sup[i]<-sup.spring[i]
          if(k %in% c(6,8)) surv.sup[i]<-sup.summer[i]
          #Note that surv.sup[i] will be used in next year's calculation of spawners, not this year's N[1]

          N.new[1] = spawners*surv.s1[i]
          N.new[2] = N[1]*surv.s2[i]
          N.new[3] = N[2]*surv.s3[i]
          N.new[4] = N[3]*(1-param$b3)*param$s0
          N.new[5] = N[4]*(1-param$b4)*param$s0

          N = N.new

      # calculate spawners
          Spawners[i] = (param$b4*N[4] + N[5])*surv.sup[i]*0.9
          # calculate recruits referenced to brood year
          if (i > 4 && i <= (years-1))
               Recruits[i-4] = param$b4*N[4]*surv.sup[i]*0.9
          if (i > 5)
               Recruits[i-5] = Recruits[i-5] + N[5]*surv.sup[i]*0.9
        } #end years
        Spawners2<-Spawners[5:years]

        spawner.array[,j,k,cnt.scenario]<-Spawners
        parrsmolt.array[,j,k,cnt.scenario]<-surv.trib
        recruit.array[,j,k,cnt.scenario]<-Recruits
  }  #end runs

#Store spawner and recruit matrices and name them by scenario
      save(spawner.array,file=paste("output/spawner",filename,arrayname,sep="."))
      save(param.array,file=paste("output/param",filename,arrayname,sep="."))
      save(parrsmolt.array,file=paste("output/parrsmolt",filename,arrayname,sep="."))
      save(recruit.array,file=paste("output/recruit",filename,arrayname,sep="."))

      cnt=cnt+1

    }   #end quantiles qq
    }   #end climate cc
}    #end populations

#Add response metrics to param.array-------------
            years<-2015:2089 #dimnames(spawner.array)[[1]]
            runs<-dim(spawner.array)[[2]]
            pop<-dimnames(spawner.array)[[3]]
            scenarios<-dimnames(spawner.array)[[4]]
            spQET<-spawner.array
                spQET[1:3,,,]<-NA
                for(k in 1:length(pop)){
                    for(ss in 1:length(scenarios)){
                     for ( j in 1:runs){
                        spawners<-spawner.array[,j,k,scenarios[ss]];spawners
                        for (i in 4:75){ifelse (sum(spawners[(i-3):i]) < 200,spQET[i,j,k,ss]<-1,spQET[i,j,k,ss]<-0) }
                        param.array[j,"yrQET50",k,scenarios[ss]]<-ifelse(max(spQET[,j,k,scenarios[ss]],na.rm=TRUE)>0.5  ,
                                    years[min(which(spQET[,j,k,scenarios[ss]]>0.5))]  ,  2115)
                        param.array[j,"Mean2020",k,scenarios[ss]]<-exp(mean(log(spawners[6:15])))
                        param.array[j,"Mean2040",k,scenarios[ss]]<-exp(mean(log(spawners[26:35])))
                        param.array[j,"Mean2060",k,scenarios[ss]]<-exp(mean(log(spawners[46:55])))
                        param.array[j,"Mean2080",k,scenarios[ss]]<-exp(mean(log(spawners[66:75])))
                        param.array[j,"Meanallyears",k,scenarios[ss]]<-exp(mean(log(spawners)))
                        } #end runs
                      }#end scenarios
                    }#end pop

      save(param.array,file=paste("output/param",filename,arrayname,sep="."))


# setwd("~/GitHub/Mobility/workstream/EpiEstimOverG/Rdata")
d=readRDS('Rdata/2020-04-26_output_SI_2.rds')
a=d$resEpi$median_R
View(a)

d2=readRDS('../EpiEstimOver/Rdata/2020-04-26_output_SI_2.rds')

a2=d2$resEpi$median_R

b<-merge(x = a,y = a2,by = 'dates')
View(b)
cvs <- merge(x= d$resEpi$CV, y=d2$resEpi$CV,by='dates')

plot(b$Argentina.x,b$Argentina.y)
lines(c(0,10),c(0,10))

plot(b$United_Kingdom.x,
     b$United_Kingdom.y)

plot(b$United_States_of_America.x,
     b$United_States_of_America.y)

plot(b$Belgium.x,
     b$Belgium.y)

plot(b$Chile.x,
     b$Chile.y)

plot(b$Egypt.x,
     b$Egypt.y)

plot(b$France.x,
     b$France.y)


#' Creates a Watershed object
#' @param stream Stream network raster, required
#' @param drainage Drainage direction raster, required
#' @param elevation Optional elevation raster
#' @param accumulation Optional flow accumulation raster
#' @param catchmentArea Optional catchment area raster
#' @param otherLayers RasterStack of other data layers to add to the Watershed object
#' @details All raster maps will be cropped to the stream network. The values in `stream` will
#' 		be automatically assigned to a reachID field in the Watershed object.
#' @return A watershed object
#' @export
Watershed <- function(stream, drainage, elevation, accumulation, catchmentArea, otherLayers) {
	## drainage will be added later, after it is fixed by WSConnectivity
	dataRasters <- list()
	if(!missing(elevation)) dataRasters$elevation <- elevation
	if(!missing(accumulation)) dataRasters$accumulation <- accumulation
	if(!missing(catchmentArea)) dataRasters$catchmentArea <- catchmentArea
	if(!missing(otherLayers)) dataRasters$otherLayers <- otherLayers
	layerStack <- lapply(dataRasters, function(x) {
		if(!raster::compareRaster(stream, x, stopiffalse = FALSE))
			x <- raster::crop(x, stream)
		raster::mask(x, stream)
	})

	## create pixel IDs and add other layers, if present
	allRasters <- raster::stack(stream, stream)
	names(allRasters) <- c('reachID', 'id')
	if(length(layerStack) > 0) {
		layerStack <- raster::stack(layerStack)
		allRasters <- raster::addLayer(allRasters, layerStack)
	}
	maskIndices <- which(!is.na(raster::values(stream)))
	allRasters$id[maskIndices] <- 1:length(maskIndices)

	allSPDF <- rasterToSPDF(allRasters, complete.cases = TRUE)
	if(!raster::compareRaster(allRasters, drainage, stopiffalse = FALSE))
		drainage <- raster::crop(drainage, allRasters)
	adjacency <- WSConnectivity(drainage, allRasters$id)
	allSPDF <- sp::merge(allSPDF, adjacency$drainage, by = 'id', all.x = TRUE)
	allSPDF$length <- WSComputeLength(allSPDF$drainage, raster::res(drainage))
	allSPDF$vReachNumber <- allSPDF$reachID

	wsobj <- list(data = allSPDF, adjacency = adjacency$adjacency)
	class(wsobj) <- c("Watershed", class(wsobj))

	wsobj = .rebuild_reach_topology(wsobj)
	attr(wsobj, "version") <- packageVersion("WatershedTools")
	return(wsobj)
}

#' Compute connectivity matrix
#'
#' @param drainage Drainage direction raster
#' @param stream Stream network raster; see `details`
#'
#' @details The stream network raster should be NA in all cells not considered a part of the
#'		river network. The pixel values of the raster must be unique IDs representing individual
#'		stream reaches to model. At present, the only supported reach size is a single pixel, thus
#'		each pixel must have a unique value.
#' @return A list with two elements, the first containing corrected drainage directions, the
#' 		second with A [Matrix::sparseMatrix()] representation of the river network. For a `stream`
#' 		input raster with `n` non-NA cells, the dimensions of this matrix will be n by n. Dimnames
#'		of the matrix will be the pixel IDs from the `stream` input raster. Values of the
#'		matrix cells are either 0 or 1; a zero indicates no flow, a one in cell i,j indicates
#'		that reach `i` receives water from reach `j`.
#' @keywords internal
WSConnectivity <- function(drainage, stream) {
	ids <- raster::values(stream)
	inds <- which(!is.na(ids))
	ids <- ids[inds]
	if(any(duplicated(ids)))
		stop("Stream IDs must be all unique")

	rowMat <- matrix(1:raster::nrow(drainage), nrow=raster::nrow(drainage),
		ncol=raster::ncol(drainage))
	colMat <- matrix(1:raster::ncol(drainage), nrow=raster::nrow(drainage),
		ncol=raster::ncol(drainage), byrow=TRUE)
	coordRas <- raster::stack(list(x = raster::raster(colMat, template = drainage),
		y = raster::raster(rowMat, template = drainage), drainage = drainage, id = stream))
	coordRas <- raster::mask(coordRas, stream)

	xy <- WSFlowTo(coordRas[inds])
	res <- xy[,c('fromID', 'drainage')]
	colnames(res)[1] <- 'id'
	list(drainage = res, adjacency = Matrix::sparseMatrix(xy[,'toID'], xy[,'fromID'],
		dims=rep(length(inds), 2), dimnames = list(ids, ids), x = 1))
}

#' Compute which pixels flow into which other pixels
#' @param mat A matrix with minimum three columns, the first being the x-coordinate, second the y,
#'		and third the ID.
#' @return A matrix of IDs, the first column the source, the second column the destination
#' @keywords internal
WSFlowTo <- function(mat) {
	newy <- mat[,2]
	newx <- mat[,1]

	ind <- which(mat[,3] > 0)
	xoffset <- c(1, 0, -1, -1, -1, 0, 1, 1)
	yoffset <- c(-1, -1, -1, 0, 1, 1, 1, 0)
	newx[ind] <- newx[ind] + xoffset[mat[ind,3]]
	newy[ind] <- newy[ind] + yoffset[mat[ind,3]]
	na_ind <- which(mat[,3] < 0 | newx < 1 | newy < 1 | newx > max(mat[,1]) | newy > max(mat[,2]))
	newx[na_ind] <- newy[na_ind] <- mat[na_ind, 'drainage'] <- NA
	resMat <- cbind(mat, newx, newy)
	resMat <- merge(resMat[,c('newx', 'newy', 'id', 'drainage')], resMat[,c('x', 'y', 'id')], by = c(1,2), all.x = TRUE)
	resMat <- resMat[,c(1,2,4,3,5)]
	colnames(resMat)[4:5] <- c('fromID', 'toID')

	resMat <- WSCheckDrainage(resMat, mat)
	resMat <- resMat[order(resMat[,'fromID']),]
	resMat <- resMat[complete.cases(resMat),]
	return(resMat)
}

#' Check and fix problems with drainage direction
#' @param connMat preliminary connectivity matrix
#' @param drainMat Drainage direction matrix
#' @param prevProbs Previous number of problems, to allow stopping if no improvement on
#' 		subsequent calls
#' @details In some cases, drainage direction rasters don't agree with flow accumulation, resulting
#' 		in a delineated stream that doesn't have the right drainage direction. This function
#' 		attempts to detect and fix this in the adjacency matrix and the drainage layer
#' @keywords internal
#' @return A corrected connectivity matrix
WSCheckDrainage <- function(connMat, drainMat, prevProbs = NA) {
	probs <- which(is.na(connMat[,'toID']) & connMat[,'drainage'] > 0)
	if(length(probs) == 0 | (!is.na(prevProbs) & length(probs) == prevProbs))
		return(connMat)

	prFix <- do.call(rbind,
		lapply(connMat[probs,'fromID'], WSFixDrainage, drainMat = drainMat, connMat = connMat))
	connMat <- connMat[-probs,]
	connMat <- rbind(connMat, prFix)
	WSCheckDrainage(connMat, drainMat, prevProbs = length(probs))
}

#' Fix drainage direction for a single pixel
#' @param id ID of the problematic pixel
#' @param connMat preliminary connectivity matrix
#' @param drainMat Drainage direction matrix
#' @keywords internal
WSFixDrainage <- function(id, drainMat, connMat) {
	i <- which(drainMat[,'id'] == id) # problem cell index
	j <- which(connMat[,'toID'] == id) # upstream of problem cell
	upID <- connMat[j,'fromID']
	x <- drainMat[i,'x']
	y <- drainMat[i,'y']
	downInd <- which(drainMat[,'x'] >= x-1 & drainMat[,'x'] <= x+1 & drainMat[,'y'] >= y-1 & drainMat[,'y'] <= y+1 & !(drainMat[,'id'] %in% c(id, upID)))
	out <- connMat[connMat[,'fromID'] == id,]
	if(length(downInd) == 1) {
		out[,'newx'] <- drainMat[downInd,'x']
		out[,'newy'] <- drainMat[downInd,'y']
		out[,'toID'] <- drainMat[downInd,'id']
		xo <- out[,'newx'] - drainMat[i,'x']
		yo <- out[,'newy'] - drainMat[i,'y']
		xoffset <- c(1, 0, -1, -1, -1, 0, 1, 1)
		yoffset <- c(-1, -1, -1, 0, 1, 1, 1, 0)
		out[,'drainage'] <- which(xoffset == xo & yoffset == yo)
	}
	out
}

#' Compute length to next pixel given drainage direction
#' @param drainage drainage direction vector
#' @param cellsize size of each cell (vector of length 2)
#' @keywords internal
#' @return vector of lengths
WSComputeLength <- function(drainage, cellsize) {
	cellLength <- rep(cellsize[1], length(drainage))
	if(abs(cellsize[1] - cellsize[2]) > 1e-4) {
		vertical <- which(drainage %in% c(2,6))
		cellLength[vertical] <- cellsize[2]
	}
	diagonal <- which(drainage %in% c(1,3,5,7))
	cellLength[diagonal] <- sqrt(cellsize[1]^2 + cellsize[2]^2)
	cellLength
}

#' Get data from all confluences of a watershed
#'
#' @param ws Watershed object
#' @return A `data.frame` containing data for all confluences
#' @export
confluences <- function(ws) {
	as.data.frame(ws$data[Matrix::rowSums(ws$adjacency) > 1,])
}

#' Get data from all headwaters of a watershed
#'
#' @param ws Watershed object
#' @return a `data.frame` containing data for all headwaters
#' @export
headwaters <- function(ws) {
	as.data.frame(ws$data[Matrix::rowSums(ws$adjacency) == 0,])
}

#' Get data from all outlets of a watershed
#'
#' @param ws Watershed object
#' @param rid vector of reach IDs, if NA returns outlet for entire network
#' @param output Output type to return
#' @return a `data.frame` or a `SpatialPixelsDataFrame` containing data for all outlets
#' @export
outlets <- function(ws, rid, output = c("data.frame", "Spatial")) {
	output = match.arg(output)
	if(!missing(rid)) {
		out_ind = sapply(rid, function(i) {
			ii = which(ws$data$reachID == i)
			mat = ws$adjacency[ii,ii, drop=FALSE]
			pix = which(Matrix::colSums(mat) == 0)
			as.integer(rownames(mat)[pix])
		})
	} else {
		out_ind = which(Matrix::colSums(ws$adjacency) == 0)
	}
	res = ws$data[out_ind,]
	if(output == "data.frame") {
		res = as.data.frame(res)
	}
	res
}

#' Get the pixel ID of the next downstream pixel for each pixel in the watershed
#' @param ws A watershed object
#' @return A vector of pixel IDs
#' @export
downstreamPixelIds <- function(ws) {
	mat <- Matrix::which(ws$adjacency == 1, arr.ind = TRUE)
	endpt <- Matrix::which(Matrix::colSums(ws$adjacency) == 0)
	mat <- rbind(mat, c(NA, endpt))
	# rearrange so the UPSTREAM pixels (second column) indicate the row number
	mat <- mat[order(mat[,2]),]
	if(!all(mat[,2] == 1:nrow(mat)))
		stop("There is an error with the topology")
	mat[,1]
}

#' Extract pixelIDs from a watershed at spatial locations
#' @param ws A watershed object
#' @param x An object inheriting from `sp::SpatialPoints()`
#' @return A vector of pixel IDs
#' @export
extract <- function(ws, x) {
	ras <- raster::rasterFromXYZ(ws[,c('x', 'y', 'id')])
	raster::extract(ras, x)
}

#' Compute a site by pixel accumulation matrix
#'
#' The default behavior computes distance, where positive numbers indicate downstream
#' distances and negative numbers indicate upstream distances. Other variables can also
#' be used, but in all cases the values will be summed to compute the 'distance'
#'
#' Upstream distances do NOT include intermediate pixels; they only include pixels in `x`
#'
#' @param ws A Watershed
#' @param x A vector of pixel ids from which to compute the distance
#' @param variable The variable to use for the distance
#' @return A matrix with dimensions `length(x)` by `nrow(ws)`
#' @export
siteByPixel <- function(ws, x, variable = 'length') {
	dsPixes <- downstreamPixelIds(ws)
	dm <- dmat(x, dsPixes, nrow(ws$data), ws[,variable])
	rownames(dm) <- x
	colnames(dm) <- ws[,'id']
	dm
}