#' @title
#' Calculate the ordering of events
#'
#' @description
#' For each event, we generate distributions of time of event occurance using profiles within clusters. These distributions are then pair wise compared and the results of all comparisons are represented in the graph space, where events are the graph nodes, and the directional edges represent that the source node event occurs significantly early than the target node. This graph is then utilized to generate the ordering.
#'
#' @param Tc A matrix containing time course data.
#' @param clusters A vector with same length as number of profiles. The cluster labels are assumed to be numbers, starting from 1.
#' @param mat_events A matrix containing the time regions (and events for the centroid) generated by running the \code{calcEvents} function.
#' @param test The test used to compare the event time distributions. The choice is between a parametric or a non-parametric test:
#' \describe{
#' 		\item{\code{wilcox}}{Choosing this will result in event times being compared using the Mann Whitney U test}
#' 		\item{\code{t-test}}{Choosing this will result in event times being compared using the Students t-test}
#' }
#' @param fdrSignif The significance cutoff for FDR correction, performed after pairwise comparisons of the event times.
#' @param phosEventTh Value between 0 and 1, to define the threshold at which a phosphorylation (or increasing) event occurs. Here, a threshold of 0 corresponds to the minimum value within an interval. (Such an event is designated as 1).
#' @param dephosEventTh Value between 0 and 1, to define the threshold at which a dephosphorylation (or decreasing) event occurs. A threshold of 0 corresponds to the maximum value within an interval. (Such an event is designated as -1).
#'
#'
#' @return A list with four named objects is returned, which encodes the order of the events and the clusters.
#'
#'
#' @importFrom methods is
#' @importFrom stats p.adjust wilcox.test t.test
#' @importFrom nem transitive.reduction
#' @importFrom igraph graph_from_adjacency_matrix adjacent_vertices V are.connected vertex_connectivity
#'
#' @seealso \code{\link[e1071]{cmeans}} for clustering time profiles, \code{\link{calcEvents}} for identifying events.
#'
#' @export
calculateOrder <- function(Tc, clusters, mat_events, test="wilcox", fdrSignif=0.05, phosEventTh=0.5, dephosEventTh=0.5){

	stopifnot(is(Tc, "matrix"),  (length(clusters) == nrow(Tc)), is(mat_events, "matrix"), (fdrSignif >0 && fdrSignif <= 1 ), (phosEventTh >= 0 && phosEventTh <= 1), (dephosEventTh >= 0 && dephosEventTh <= 1))

	if (!(test == eventOrderTest$param) && !(test == eventOrderTest$nonParam)){
		stop(paste("Test ", test, " not recognized.", sep=""))
	}

	list_matrices <- splitIntoSubMatrices(Tc, clusters)

	list_distributions <- getDistOfAllEvents_v2(mat_events, list_matrices, phosEventTh, dephosEventTh)

	# mat_missingStats <- missingStats(list_distributions) # exclude events based on percentage missing. mat_fiftyPoints, list_distributions
	# return(mat_missingStats)

	# return (list_distributions)

	list_pVal_stat <- list()

	if (test==eventOrderTest$nonParam){
		print ("Running wilcoxon test.")
		list_pVal_stat <- performWilcoxonSignedRankTabular(list_distributions)

		title_testType = "(Non-parametric)"
	}
	else {
		print("Running t-test.")
		list_pVal_stat <- performTtestsTabular(list_distributions)

		title_testType = "(Parametric)"
	}

	# FDR adjustment for multiple testing.
	mat_pValsFDR <- matrix(stats::p.adjust(as.vector(list_pVal_stat[[1]]), method='fdr'), ncol=nrow(mat_events))

	# Convert to adjacency matrix.
	signifs <- mat_pValsFDR < fdrSignif
	statistic_t <- list_pVal_stat[[2]]
	statistic_t[!signifs] <- NA

	statistic_t[statistic_t > 0] <- NA
	statistic_t[is.na(statistic_t)] <- 0
	statistic_t[statistic_t < 0] <- 1

	# library(nem) # for trasitive reduction
	# library(igraph) # for adjacency matrix
	reducted <- nem::transitive.reduction(statistic_t)
	net = igraph::graph_from_adjacency_matrix(reducted, mode="directed")

	list_eventsOrder <- getEventsOrderInGraph(reducted, net) # computing the order of the events in the mat_events based on a bfs search.
	list_eventsOrder <- adjustEvents(list_eventsOrder, signifs)

	mat_events_withOrder <- appendOrder(mat_events, list_eventsOrder)

	res <- list(mat_events_withOrder, list_eventsOrder, signifs, test)
	names(res) <- c("mat_events_withOrder", "individEventOrder", "signifs", "test")
	return (res)

}

#' @title
#' Visualize the order of events.
#'
#' @description
#' A plot depicting the temporal order of events is generated. The order is shown using two visualizations, event maps (top) and event sparklines (bottom). The event sparkline is a summary of the event map.
#'
#' @param theOrder A list containing information regarding the order of events and clusters generated via the \code{calculateOrder} function.
#'
#'
#' @return A plot containing the ordered clusters by occurance of first event is generated (see description).
#'
#'
#' @importFrom methods is
#' @importFrom graphics plot segments axis rect text lines
#' @importFrom shape Arrows
#'
#' @seealso \code{\link{calculateOrder}}
#'
#' @export
visualizeOrder <- function(theOrder){
# Visualise the ordering of events

	stopifnot(is(theOrder, "list"), length(theOrder) == 4)

	mat_events_withOrder <- theOrder$mat_events_withOrder
	list_eventsOrder <- theOrder$individEventOrder
	signifs <- theOrder$signifs
	test <- theOrder$test

	title_testType = ""
	## Getting other things ready for plotting

	if (test==eventOrderTest$nonParam){
		title_testType = "(Non-parametric)"
	}
	else {
		title_testType = "(Parametric)"
	}

	# plotting constants
	sigEventsDiff_x = 0.5
	nonSigEventsDiff_x = 0.25

	eventPtGraph_y = -1
	yLabelInit = -1.8
	yLabelSpace = 0.5

	lineDiff_y = 1

	# graphXStart = -1
	eventStart_x = 0

	blockSpacingFmEvent_x = sigEventsDiff_x/2
	blockStart_x = eventStart_x - blockSpacingFmEvent_x

	#x_lineStart, y_lineStart, y_lineDecr, x_incr_sig, x_incr_nonSig

	yPos_eventPts = -1

	# plotting values
	list_blocks <- getRectBlock(list_eventsOrder, signifs)
	# print(list_blocks)

	mat_eventPoints <- getTheClusLines(mat_events_withOrder, list_eventsOrder, signifs, list_blocks, eventStart_x, sigEventsDiff_x, nonSigEventsDiff_x, lineDiff_y)

	eventEnd_x = max(as.numeric(mat_eventPoints[,cols_matFifty$col_x])) #  + blockSpacingFmEvent_x
	blockEnd_x = eventEnd_x + blockSpacingFmEvent_x

	mat_bgRects <- getRectPoints(mat_eventPoints, list_blocks, blockStart_x, blockSpacingFmEvent_x)

	# mat_eventPoints <- adjustByBgRects(mat_bgRects, list_eventsOrder, mat_eventPoints)

	mat_grayLines <- getGrayLines(mat_eventPoints, signifs)

	mat_grayLines_v2 <- getGrayLines_v2(list_eventsOrder, mat_eventPoints, signifs)

	mat_clusConnLines <- getClusConnLines(mat_eventPoints, blockStart_x, blockEnd_x)

	mat_clusConnLines <- makeDecrBarOpaque(mat_clusConnLines, FALSE)
	# print(mat_clusConnLines)
	vec_labels <- getYaxisLabels(mat_eventPoints)

	mat_xLabelsClus <- getXaxisLabels(list_eventsOrder, mat_eventPoints, signifs, list_blocks, eventStart_x, sigEventsDiff_x, nonSigEventsDiff_x, yLabelInit, yLabelSpace);

	# a set of points to set up the graph.
	# print(mat_eventPoints)
	graphics::plot(mat_eventPoints[,cols_matFifty$col_x], mat_eventPoints[,cols_matFifty$col_y], asp=NA, yaxt="n", lwd=0.25, col=colors_orderedEvents$incr, pch=".", xlab="Temporal order", ylab="Clusters",  main=paste("Temporal order of events in clusters", title_testType, sep=""), xlim=c(eventStart_x, eventEnd_x), ylim=c(-4, max(as.numeric(mat_eventPoints[,cols_matFifty$col_clus]))), xaxt="n", bty="n", cex.main = 0.8) #,
	# print("over here..")
	# background gray rectangles.
	if (nrow(mat_bgRects) > 0){
		for (rowNum in 1:nrow(mat_bgRects)){
			if (rowNum%%2 == 1){
				graphics::rect(mat_bgRects[rowNum,1], lineDiff_y/2, mat_bgRects[rowNum,2], max(as.numeric(mat_eventPoints[,cols_matFifty$col_clus])) + (lineDiff_y/2), col = "#ededed", border=NA)
			}

		}
	}

	# axis labels on sides 2 and 4.
	graphics::axis(side=2, las=1, at=seq(1,length(vec_labels)), labels=rev(vec_labels), cex=0.02,  col = NA ) #, col.ticks = 1)

	graphics::axis(side=4, las=1, at=seq(1,length(vec_labels)), labels=rev(vec_labels), cex=0.02,  col = NA ) #, col.ticks = 1)

	graphics::segments(x0=as.numeric(mat_grayLines[,cols_clusPlotObjs$col_x0]), y0=as.numeric(mat_grayLines[,cols_clusPlotObjs$col_y0]), x1=as.numeric(mat_grayLines[,cols_clusPlotObjs$col_x1]), y1=as.numeric(mat_grayLines[,cols_clusPlotObjs$col_y1]), col="#808080", lty="dotted", lwd=0.5)
	# C99999

	# rect(-0.5, 0, 0.5, 17.5, col = "yellow", border="#ededed")

	# the cluster lines
	graphics::segments(x0=as.numeric(mat_clusConnLines[,cols_clusPlotObjs$col_x0]), y0=as.numeric(mat_clusConnLines[,cols_clusPlotObjs$col_y0]), x1=as.numeric(mat_clusConnLines[,cols_clusPlotObjs$col_x1]), y1=as.numeric(mat_clusConnLines[,cols_clusPlotObjs$col_y1]), col=mat_clusConnLines[,cols_clusPlotObjs$col_col], lwd=16, lend=2)

	# the events (arrows) within a graph
	mat_upEvents = mat_eventPoints[mat_events_withOrder[,cols_matFifty$col_dir] == 1,]
	mat_downEvents = mat_eventPoints[mat_events_withOrder[,cols_matFifty$col_dir] == -1,]

	# print(mat_upEvents)

	## arrow bottoms
	shape::Arrows(x0=as.numeric(mat_upEvents[,cols_matFifty$col_x]), x1=as.numeric(mat_upEvents[,cols_matFifty$col_x]), y0=as.numeric(mat_upEvents[,cols_matFifty$col_y])-0.01-0.2,  y1=as.numeric(mat_upEvents[,cols_matFifty$col_y])-0.01, arr.type="triangle", arr.length=0.01, arr.width=0.01, col=color_events$up, lwd=2, lend=2, arr.adj=0)

	shape::Arrows(x0=as.numeric(mat_downEvents[,cols_matFifty$col_x]), x1=as.numeric(mat_downEvents[,cols_matFifty$col_x]), y0=as.numeric(mat_downEvents[,cols_matFifty$col_y])+0.25,  y1=as.numeric(mat_downEvents[,cols_matFifty$col_y])+0.25-0.2, arr.type="triangle", arr.length=0.01, arr.width=0.01, col=color_events$down, lwd=2, lend=2, arr.adj=0)

	## sharp arrow heads
	shape::Arrows(x0=as.numeric(mat_upEvents[,cols_matFifty$col_x]), x1=as.numeric(mat_upEvents[,cols_matFifty$col_x]), y0=as.numeric(mat_upEvents[,cols_matFifty$col_y])-0.01-0.2,  y1=as.numeric(mat_upEvents[,cols_matFifty$col_y])-0.01, arr.type="triangle", arr.length=0.13, arr.width=0.15, col=color_events$up, arr.adj=0, segment=FALSE)

	shape::Arrows(x0=as.numeric(mat_downEvents[,cols_matFifty$col_x]), x1=as.numeric(mat_downEvents[,cols_matFifty$col_x]), y0=as.numeric(mat_downEvents[,cols_matFifty$col_y])+0.25,  y1=as.numeric(mat_downEvents[,cols_matFifty$col_y])+0.25-0.2, arr.type="triangle", arr.length=0.13, arr.width=0.15, col=color_events$down, arr.adj=0, segment=FALSE)

	# gray lines in events points maps
	straightGrayLines = mat_grayLines_v2[mat_grayLines_v2[,cols_grayLines_v2$col_isSemiCirc] == FALSE,]
	graphics::segments(x0=as.numeric(straightGrayLines[,cols_grayLines_v2$col_x0]), y0=rep(yPos_eventPts, length(straightGrayLines)), x1=as.numeric(straightGrayLines[,cols_grayLines_v2$col_x1]), y1=rep(yPos_eventPts, length(straightGrayLines)), lwd=1, col="#A2A2A2") #, lty="dotted")

	# gray curves in events points map
	mat_curvePoints = mat_grayLines_v2[mat_grayLines_v2[,cols_grayLines_v2$col_isSemiCirc] == TRUE,,drop=FALSE]

	if (length(mat_curvePoints) > 0 && nrow(mat_curvePoints) > 0){
		for (i in 1:nrow(mat_curvePoints)){
			list_pts = calcCurves(mat_curvePoints[i, cols_grayLines_v2$col_x0], mat_curvePoints[i, cols_grayLines_v2$col_x1], -1)
			graphics::lines(list_pts[[1]], list_pts[[2]], col="#A2A2A2")
		}
	}

	# printing up and down events (in arc events map)
	y_adjust = 0.15

	## arrow bottom lines
	shape::Arrows(x0=as.numeric(mat_upEvents[,cols_matFifty$col_x]), x1=as.numeric(mat_upEvents[,cols_matFifty$col_x]), y0=rep(-1.2, nrow(mat_upEvents)), y1=rep(-1, nrow(mat_upEvents)), arr.type="triangle", arr.length=0.01, arr.width=0.01, col=color_events$up, lwd=2, lend=2, arr.adj=0)

	shape::Arrows(x0=as.numeric(mat_downEvents[,cols_matFifty$col_x]), x1=as.numeric(mat_downEvents[,cols_matFifty$col_x]), y0=rep(-0.8, nrow(mat_downEvents)), y1=rep(-1, nrow(mat_downEvents)), arr.type="triangle", arr.length=0.01, arr.width=0.01, col=color_events$down, lwd=2, lend=2, arr.adj=0)

	## sharp arrow heads
	shape::Arrows(x0=as.numeric(mat_upEvents[,cols_matFifty$col_x]), x1=as.numeric(mat_upEvents[,cols_matFifty$col_x]), y0=rep(-1.2, nrow(mat_upEvents)), y1=rep(-1, nrow(mat_upEvents)), arr.type="triangle", arr.length=0.13, arr.width=0.15, col=color_events$up, arr.adj=0, segment=FALSE)

	shape::Arrows(x0=as.numeric(mat_downEvents[,cols_matFifty$col_x]), x1=as.numeric(mat_downEvents[,cols_matFifty$col_x]), y0=rep(-0.8, nrow(mat_downEvents)), y1=rep(-1, nrow(mat_downEvents)), arr.type="triangle", arr.length=0.13, arr.width=0.15, col=color_events$down, arr.adj=0, segment=FALSE)

	# vec_clusEvent = mat_eventPoints[,4]
	# print(vec_clusEvent)
	# vec_clusEvent[mat_eventPoints[mat_fiftyPoints[,cols_matFifty$col_dir] == 1]] = color_events$up
	# vec_clusEvent[mat_eventPoints[mat_fiftyPoints[,cols_matFifty$col_dir] == -1] = color_events$down

	# x label text.
	graphics::text(x=as.numeric(mat_xLabelsClus[,1]), y=as.numeric(mat_xLabelsClus[,2]), labels=mat_xLabelsClus[,3], offset=0, cex=0.5, col=mat_xLabelsClus[,4])

}

#' @title
#' Rearrange clusters by events
#'
#' @description
#' After calculating the order of events, we can now rearrange clusters, so that the first cluster contains the first event and so on.
#'
#' @param clusters A vector with same length as number of profiles. The cluster labels are assumed to be numbers, starting from 1.
#' @param theOrder A list containing information regarding the order of events and clusters generated via the \code{calculateOrder} function.
#'
#'
#' @return The returned vector now contains the cluster rearranged according to the computed ordering in \code{theOrder}.
#'
#'
#' @importFrom methods is
#' @importFrom rlang duplicate
#'
#' @seealso \code{\link[e1071]{cmeans}} for clustering, \code{\link{calculateOrder}} to generate the order.
#'
#' @export
rearrangeClusters <- function(clusters, theOrder){

	stopifnot(is(theOrder, "list"), length(theOrder) == 4)

	clusterOrder <- matrix(ncol=1, nrow=max(theOrder$mat_events_withOrder[,cols_matFifty_v2$clus]), data=NA) # the row numb stores the original order
	# print(clusterOrder)
	orderCounter = 1
	for (i in 1:length(theOrder$individEventOrder)){
		for (j in 1:length(theOrder$individEventOrder[[i]])){

			clusNum = theOrder$mat_events_withOrder[theOrder$individEventOrder[[i]][j], cols_matFifty_v2$clus]

			if (is.na(clusterOrder[clusNum, 1])){
				# print(paste(clusNum, orderCounter))
				clusterOrder[clusNum, 1] <- orderCounter;

				orderCounter = orderCounter + 1;
				# print(clusterOrder)
			}
		}
	}
	# return(clusterOrder)

	origClusters = clusters
	# centers = rlang::duplicate(clustered$centers)
	for (origOrder in 1:nrow(clusterOrder)){
		if (!is.na(clusterOrder[origOrder,1])){
			# print(paste(origOrder, clusterOrder[origOrder,1]))
			clusters[origClusters == origOrder] = clusterOrder[origOrder,1]
			# clustered$center[clusterOrder[origOrder,1], ] = centers[origOrder,]
		}
	}
	return (clusters)
}

calcCurves <- function(x0, x1, yCentPos){

	x_10pts <- seq(x0, x1, length.out=50)

	y_10pts <- topSemiCircleEq(x_10pts, yCentPos)

	list_pts <- list(x_10pts, y_10pts)
	return (list_pts)

}

topSemiCircleEq <- function(xPts, yCentPos){
	yPts = c()

	r = abs(xPts[1] - xPts[length(xPts)])/2
	xCentPos = (xPts[1] + xPts[length(xPts)]) /2

	for (xPt in xPts){
		yPt = sqrt(abs(r^2 - (xPt-xCentPos)^2)) + yCentPos + 0.4
		yPts = c(yPts, yPt)
	}

	return (yPts)
}

appendOrder <- function(mat_fiftyPoints, list_eventsOrder){

	# mat_withOrder <- cbind(mat_fiftyPoints, rep(0,nrow(mat_fiftyPoints)))

	for (i in 1:length(list_eventsOrder)){
		eventNum <- list_eventsOrder[[i]]

		mat_fiftyPoints[eventNum, Col_events$order] = i
	}

	colnames(mat_fiftyPoints)[Col_events$order] = "order";
	return(mat_fiftyPoints)
}

################################## AUXILLARY
adjustEvents <- function(list_eventsOrder, signifs){
	list_newEventsOrder <- list()
	i_new = 1

	for (i in 1:length(list_eventsOrder)){
		# print(list_eventsOrder[[i]])
		isAddedVec = FALSE
		for (j in 1:length(list_eventsOrder[[i]])){

			if (isAddedVec == FALSE){ # add every row atleast once
				# add to list first
				list_newEventsOrder[[length(list_newEventsOrder) + 1]] <- list_eventsOrder[[i]]
				isAddedVec = TRUE
				# print(list_newEventsOrder)
			}

			if (length(list_eventsOrder[[i]]) == 1){ # if only one element break
				break
			}

			if (isAnyOneNonSignifFromNextAll(list_eventsOrder, list_eventsOrder[[i]][j], i, signifs)){ # remove that element, and add to end.
				# add the jth one to a new next layer
				# print("here!")
				# print(list_eventsOrder[[i]][j])

				list_newEventsOrder <- rmElemAndAddSepElseNew(list_newEventsOrder, list_eventsOrder[[i]][j])
				# print("now list is")
				# print(list_newEventsOrder)

			}
		}

	}

	return (list_newEventsOrder)
}

checkAndAddEventAtEnd <- function(anEvent, list_newEventsOrder){
	isFound = FALSE
	for (i in 1:length(list_newEventsOrder)){
		if (anEvent %in% list_newEventsOrder){
			isFound = TRUE
		}
	}

	if (isFound == FALSE){
		list_newEventsOrder <- append(list_newEventsOrder, c(anEvent))
	}

	return(list_newEventsOrder)
}

rmElemAndAddSepElseNew <- function(list_newEventsOrder, theElem, theVec){
	# print("The eleme is ")
	# print(theElem)

	isDeleted = FALSE
	for (i in 1:length(list_newEventsOrder)){
		if (theElem %in% list_newEventsOrder[[i]]){
			idx = match(theElem, list_newEventsOrder[[i]])
			# print(" the idx is ")
			# print(idx)
			if (idx > 0){

				if (length (list_newEventsOrder[[i]]) > 1){
					list_newEventsOrder[[i]] <- list_newEventsOrder[[i]][-idx]
					isDeleted = TRUE
				}

				if (length(list_newEventsOrder[[i]]) == 0){
					print("Need to delete this here....?")
					list_newEventsOrder <- list_newEventsOrder[-i]
				}
			}

		}
	}
	if (isDeleted == TRUE){
		for (i in 1:length(list_newEventsOrder)){
			if (length(list_newEventsOrder[[i]]) == 0){
				list_newEventsOrder <- Filter(Negate(is.null), list_newEventsOrder)
			}
		}
		list_newEventsOrder <- append(list_newEventsOrder, c(theElem))
	}

	return (list_newEventsOrder)
}

rmElemAndAddSepElseNew_old <- function(list_newEventsOrder, theElem, theVec){
	# print("The eleme is ")
	# print(theElem)
	for (i in 1:length(list_newEventsOrder)){
		if (theElem %in% list_newEventsOrder[[i]]){
			idx = match(theElem, list_newEventsOrder[[i]])
			# print(" the idx is ")
			# print(idx)
			if (idx > 0){
				list_newEventsOrder[[i]] <- list_newEventsOrder[[i]][-idx]
			}

		}
	}

	list_newEventsOrder <- append(list_newEventsOrder, c(theElem))

	return (list_newEventsOrder)
}

isVecInList <- function(theVec, theList, elemToRm){

	for (subVec in theList){
		if (all(subVec==theVec)){
			return (TRUE)
		}
	}

	return (FALSE)
}

isAnyOneNonSignifFromNextAll <- function(list_eventsOrder, currEvent, currentLayer, signifs){
	if ((currentLayer + 1) >= length(list_eventsOrder)){
		return (FALSE)
	}

	for (i in seq((currentLayer + 1), length(list_eventsOrder))){

		isAny = isAnyNonSignifFromPrev(c(currEvent), list_eventsOrder[[i]], signifs)

		if (isAny == TRUE){
			return (TRUE)
		}
	}

	return (FALSE)
}

getEventsOrderInGraph <- function(reducted, net){
	vec_roots <- getRoots(reducted) # get root nodes
	vec_linCurrNodes <- vec_roots

	# list_currNodes <- as.list(vec_roots)

	vec_visited <- c()

	list_eventsOrder <- list()

	while(length(vec_linCurrNodes) > 0){

		# list_prevNodes = list_currNodes

		# print("vec_linCurrNodes")
		# print (vec_linCurrNodes)

		vec_newForVisit <- getNotVisitedBefore(vec_linCurrNodes, vec_visited)

		vec_newForVisit <- onlyPatron(vec_newForVisit, net)

		# print("to visit")
		# print (vec_newForVisit)

		if (length(vec_newForVisit) > 0){
			# print("to visit")
			# print (vec_newForVisit)

			list_eventsOrder <- addNodesToOrderList(vec_newForVisit, list_eventsOrder)
			vec_visited <- visitNodes(vec_newForVisit, vec_visited)
		}

		list_currNodes <- getAllInNextHop(net, vec_newForVisit, "out")
		vec_linCurrNodes <- convertToUniqueVec(list_currNodes)

		if (length(vec_linCurrNodes) == 0 && length(igraph::V(net)) != length(vec_visited)){
			vec_linCurrNodes <- setdiff(igraph::V(net), vec_visited)
		}
	}
	return (list_eventsOrder)
}

cols_clusPlotObjs$col_x0 <- 1
cols_clusPlotObjs$col_y0 <- 2
cols_clusPlotObjs$col_x1 <- 3
cols_clusPlotObjs$col_y1 <- 4
cols_clusPlotObjs$col_col <- 5

getNumOfCrossingAndDir <- function(mat_fiftyPoints, clusNum){

	totalNumOfCrossings <- 0
	list_dir = list()

	for (rowNum in 1:nrow(mat_fiftyPoints)){
		if (mat_fiftyPoints[rowNum, cols_matFifty$col_clus] == clusNum){
			totalNumOfCrossings = totalNumOfCrossings + 1
			list_dir = append(list_dir, mat_fiftyPoints[rowNum, cols_matFifty$col_dir])
		}
	}

	return (list(totalNumOfCrossings, list_dir))
}

genDistForEvent <- function(clusMat, dir, startTp, endTp, phosTh, dephosTh){
	mat_distribution <- matrix(ncol=4)

	for (profNum in 1:nrow(clusMat)){

		if ((dir == 1 && clusMat[profNum, startTp] < clusMat[profNum, endTp]) || (dir == -1 && clusMat[profNum, startTp] > clusMat[profNum, endTp])){
			# direction holds; do calculation, and save.
			# print(clusMat[profNum, startTp:endTp])

			crossPt <- calcCrossing_v3(clusMat[profNum, startTp:endTp], dir, (startTp -1), phosTh, dephosTh)

			mat_distribution <- addToMatrix(mat_distribution, profNum, crossPt[1], crossPt[2], dir)

		}
		else{
			mat_distribution <- addToMatrix(mat_distribution, profNum, NA, NA, dir)
		}
	}

	mat_distribution <- mat_distribution[-1,, drop=FALSE]
	return (mat_distribution)
}

getDistOfAllEvents_v2 <- function(mat_fiftyPoints, list_matrices, phosTh, dephosTh){
	list_distributions <- list()

	for (eventNum in 1:nrow(mat_fiftyPoints)){
		dist <- genDistForEvent(list_matrices[[mat_fiftyPoints[eventNum,cols_matFifty_v2$clus]]], mat_fiftyPoints[eventNum, cols_matFifty_v2$dir], mat_fiftyPoints[eventNum, cols_matFifty_v2$startTp], mat_fiftyPoints[eventNum, cols_matFifty_v2$endTp], phosTh, dephosTh)

		list_distributions[[length(list_distributions) + 1]] <-  dist
	}

	return(list_distributions)
}

isComparisonPossible <- function(list1, list2){
	list1 <- list1[!is.na(list1)]
	list2 <- list2[!is.na(list2)]

	# print(list1)

	if(all(abs(list1 - mean(list1)) < 0.0001) && all(abs(list2 - mean(list2)) < 0.0001) && abs(mean(list1) - mean(list2)) < 0.0001) {
		# print("false!!!)")
		return (FALSE)

	}

	return (TRUE)
}

performWilcoxonSignedRankTabular <- function(list_distributions){
	mat_pVal = matrix(nrow=length(list_distributions), ncol=length(list_distributions))
	mat_statistic = matrix(nrow=length(list_distributions), ncol=length(list_distributions))

	for (i in 1:length(list_distributions)){
		for (j in 1:length(list_distributions)){

			if (i != j){

				if (!isComparisonPossible(list_distributions[[i]][,cols_matFifty$col_x], list_distributions[[j]][,cols_matFifty$col_x])){ # add as pval = 1 (being the exact same from a uniform distribution).
					mat_pVal[i, j] <- 1
					mat_statistic[i, j] <- NA
				}
				else{ # do the comparison
					res <- stats::wilcox.test(list_distributions[[i]][,cols_matFifty$col_x], list_distributions[[j]][,cols_matFifty$col_x], paired=FALSE, conf.int=TRUE)

					# if (stats::wilcox.test(list_distributions[[i]][,cols_matFifty$col_x], list_distributions[[j]][,cols_matFifty$col_x], paired=FALSE, conf.int=TRUE)){
					#	print(paste("The case here ", i, j))

					#}
					# return (res)
					# print (res)
					mat_pVal[i, j] <- res$p.value
					mat_statistic[i, j] <- res$estimate
				}
			}
		}
	}

	list_pVal_stat <- list()
	list_pVal_stat[[1]] <- mat_pVal
	list_pVal_stat[[2]] <- mat_statistic
	return (list_pVal_stat)
}

performTtestsTabular <- function(list_distributions){
	mat_pVal = matrix(nrow=length(list_distributions), ncol=length(list_distributions))
	mat_statistic = matrix(nrow=length(list_distributions), ncol=length(list_distributions))

	for (i in 1:length(list_distributions)){
		for (j in 1:length(list_distributions)){

			if (i != j){
				if (!isComparisonPossible(list_distributions[[i]][,cols_matFifty$col_x], list_distributions[[j]][,cols_matFifty$col_x])){ # add as pval = 1 (being the exact same from a uniform distribution).
					mat_pVal[i, j] <- 1
					mat_statistic[i, j] <- NA
				}
				else{ # do the comparison
					res <- stats::t.test(list_distributions[[i]][,cols_matFifty$col_x], list_distributions[[j]][,cols_matFifty$col_x], paired=FALSE)
					mat_pVal[i, j] <- res$p.value
					mat_statistic[i, j] <- res$statistic
				}
			}
		}
	}

	list_pVal_stat <- list()
	list_pVal_stat[[1]] <- mat_pVal
	list_pVal_stat[[2]] <- mat_statistic
	return (list_pVal_stat)
}

################################ GRAPH_TRAVERSAL

getRoots <- function(reducted){
	vec_roots = c()
	for (colNum in 1:nrow(reducted)){

		isAllZeros = TRUE
		for (rowNum in 1:ncol(reducted)){
			if (reducted[rowNum, colNum] == 1){
				isAllZeros = FALSE
				break
			}
		}

		if (isAllZeros == TRUE){
			vec_roots <- append(vec_roots, colNum)
		}

	}

	return (vec_roots)
}

getNotVisitedBefore <- function(vec_currNodes, vec_visited){
	vec_newForVisit <- c()

	for (i in 1:length(vec_currNodes)){

		if (!(vec_currNodes[i] %in% vec_visited) && !(vec_currNodes[i] %in% vec_newForVisit)){
			vec_newForVisit <- c(vec_newForVisit, vec_currNodes)
		}
	}

	return (vec_newForVisit)
}

onlyPatron <- function(vec_nodes, net){

	# only add a node if it is not a child of anything else in this set.

	vec_parentsOnly <- c()

	for (i in 1:length(vec_nodes)){
		isChild = FALSE;

		vec_withoutCurr <- setdiff(vec_nodes, vec_nodes[i])

		if (length(vec_withoutCurr) > 0) {
			list_children <- getAllInNextHop(net, vec_withoutCurr, 'out')
			vec_children <- convertToUniqueVec(list_children)

			# print(vec_children)
			# print(vec_nodes[i])

			if (vec_nodes[i] %in% vec_children){
				isChild = TRUE
			}
			else { # make sure that this node is also not in the downstream lineage.
				if (length(vec_children) > 0){
					for (j in 1:length(vec_children)){
						if (igraph::are.connected(net, vec_children[j], vec_nodes[i]) == TRUE || igraph::vertex_connectivity(net, vec_children[j], vec_nodes[i]) == 1){
							isChild = TRUE
						}
					}
				}
			}

		}

		if (isChild == FALSE){
			vec_parentsOnly <- c(vec_parentsOnly, vec_nodes[i])
		}

	}

	return (vec_parentsOnly)
}

addNodesToOrderList <- function(vec_nodesInNewLayer, list_eventsOrder){
	pos <- length(list_eventsOrder) + 1
	list_eventsOrder[[pos]] <- vec_nodesInNewLayer
	return (list_eventsOrder)
}

visitNodes <- function(vec_newForVisit, vec_visited){

	vec_visited <- c(vec_visited, vec_newForVisit)

	return (vec_visited)
}

getAllInNextHop <- function(network, list_nodes, edgeDir){
	list_ <- igraph::adjacent_vertices(network, list_nodes, mode="out")

	return (list_)
}

convertToUniqueVec <- function(list_nodes){
	vec_nodes <- c()
	# print("lvl1")
	if (length(list_nodes) > 0){
		for (i in 1:length(list_nodes)){
			# print("lvl2")
			if (length(list_nodes[[i]]) > 0){
				for(j in 1:length(list_nodes[[i]])){
					# print(c(i,j), sep="\t")
					# print(list_nodes)
					if (! (list_nodes[[i]][j] %in% vec_nodes)){
						vec_nodes <- c(vec_nodes, list_nodes[[i]][j])
					}
				}
			}
		}
	}
	# print(list_nodes)
	return (vec_nodes)
}

###################### FOR PLOTTING
getXaxisLabels <- function(list_eventsOrder, mat_eventPoints, signifs, list_blocks, eventStart_x, xSigIncr, xNonSigIncr, yLabelInit, yLabelSpace){
	mat_xLabelsClus = matrix(ncol=4) #x0, y0, labelNames, color
	x0 = eventStart_x;
	eventsVisited = c()

	isFirst = TRUE

	for (i in 1:length(list_eventsOrder)){

		eventsVisited = c(eventsVisited, list_eventsOrder[[i]])

		if (i > 1 && isAnyNonSignifFromPrevAll(list_eventsOrder, i, signifs) == TRUE || isInSameBlock(list_eventsOrder[[i]], eventsVisited, list_blocks)){
			if (isFirst == FALSE){
				x0 = x0 + xNonSigIncr;
			}
			else{
				isFirst = FALSE
			}
		}
		else {
			if (isFirst == FALSE){
				x0 = x0 + xSigIncr;
			}
			else {
				isFirst = FALSE
			}

		}

		y0 = yLabelInit

		sortedEvents <- getSortedEventsByY(list_eventsOrder[[i]], mat_eventPoints)

		for (event in sortedEvents){

			# print(mat_eventPoints[event, cols_matFifty$col_dir])

			col = mat_eventPoints[event, cols_matFifty$col_dir]
			# col = color_events$up

			# if (mat_eventPoints[event, cols_matFifty$col_dir] != colors_orderedEvents$incr){
			# 	col = color_events$down
			# }

			rowVal = c(x0, y0, mat_eventPoints[event, cols_matFifty$col_clus], col)
			mat_xLabelsClus <- rbind(mat_xLabelsClus, rowVal)

			y0 = y0 - yLabelSpace;
		}

	}

	mat_xLabelsClus <- mat_xLabelsClus[-1,]
	return (mat_xLabelsClus)
}

getSortedEventsByY <- function(events, mat_eventPoints){
	theOrder <- rev(order(as.numeric(mat_eventPoints[events, cols_matFifty$col_y])))
	return(events[theOrder])
}

getGrayLines_v2 <- function(list_eventsOrder, mat_eventPoints, signifs){
	theGrayLines = matrix(ncol=4) # x0, x1, isSemiCircle, color

	for (i in 1:nrow(signifs)){
		for (j in i:ncol(signifs)){
			if (i != j){
				if (signifs[j, i] == FALSE){
					# if in same layer no need for line

					j_layer = getLayerNum(list_eventsOrder, j)
					i_layer = getLayerNum(list_eventsOrder, i)

					if (j_layer != i_layer){
						if (i_layer - 1 == j_layer || j_layer - 1 == i_layer){
							rowVal <- c(mat_eventPoints[i, cols_matFifty$col_x], mat_eventPoints[j, cols_matFifty$col_x], FALSE, "#808080")
						}
						else{
							rowVal <- c(mat_eventPoints[i, cols_matFifty$col_x], mat_eventPoints[j, cols_matFifty$col_x], TRUE, "#808080")
						}
						theGrayLines <- rbind(theGrayLines, rowVal)
					}
					# if in diff layer
						# if in consecutive layer, draw straight line

						# if not, draw semicircle.

					# draw a gray50 line between the i and j events

				}
			}
		}
	}
	theGrayLines <- theGrayLines[-1,]

	# print(theGrayLines)
	return (theGrayLines)
}

getLayerNum <- function(list_eventsOrder, event){
	for (i in 1:length(list_eventsOrder)){
		if (event %in% list_eventsOrder[[i]]){
			return (i)
		}
	}

	return (-1)
}

getGrayLines <- function(mat_eventPoints, signifs){
	theGrayLines = matrix(ncol=5)

	for (i in 1:nrow(signifs)){
		for (j in i:ncol(signifs)){
			if (i != j){
				if (signifs[j, i] == FALSE){
					# draw a gray50 line between the i and j events
					rowVal <-  c(mat_eventPoints[i, cols_matFifty$col_x], mat_eventPoints[i, cols_matFifty$col_y], mat_eventPoints[j, cols_matFifty$col_x], mat_eventPoints[j, cols_matFifty$col_y], "red")
					theGrayLines <- rbind(theGrayLines, rowVal)
				}
			}
		}
	}
	theGrayLines <- theGrayLines[-1,,drop=F]

	return (theGrayLines)
}

getRectPoints <- function(mat_eventPoints, list_blocks, rectStart, rectSpacingFmEvent){ #xStart, incr
	mat_rectPts = matrix(ncol=2) # [x0, x1]

	for (i in 1:length(list_blocks)){
		xVal <- max(as.numeric(mat_eventPoints[list_blocks[[i]], cols_matFifty$col_x])) + rectSpacingFmEvent

		if (i == 1){
			x0 <- rectStart
		}
		else{
			x0 <- mat_rectPts[nrow(mat_rectPts), cols_rectPoints$x1]
		}

		mat_rectPts <- rbind(mat_rectPts, c(x0, xVal))

	}
	mat_rectPts <- mat_rectPts[-1, ]
	return (mat_rectPts)
}

getRectBlock <- function(list_eventsOrder, signifs){
		list_blocks <- list()

		prevBlock <- c()
		currBlock <- list_eventsOrder[[1]]

		if(length(list_eventsOrder) > 1) {
			for (i in 2:length(list_eventsOrder)){

				isAny = isAnyNonSignifFromPrev(list_eventsOrder[[i]], currBlock, signifs)

				if (isAny == TRUE){
					currBlock <- c(currBlock, list_eventsOrder[[i]])

				}
				else{

					prevBlock <- c(prevBlock, currBlock)
					list_blocks[[length(list_blocks)+1]] <- currBlock
					currBlock <- list_eventsOrder[[i]]
					# rectPoints <- addToRectPoints(rectPoints, list_eventsOrder[[i]], mat_eventPoints)

					 # can improve further - i.e. take max of prevBlock listEvents x value (done)
				}

				# if (i == length(list_eventsOrder)){
			#		if (list_blocks[[length(list_blocks)]])
			#	}

				if (length(list_blocks) > 0 && length(prevBlock) > 0 && length(currBlock) > 0 && isAnyNonSignifFromPrev(currBlock, prevBlock, signifs) == TRUE){

					# print(length(list_blocks))
					# theCurrVec = list_blocks[[length(list_blocks)]]
					# theIdx = prevBlock == theCurrVec

					# print(theCurrVec)
					# print(prevBlock)

					# prevBlock <- prevBlock[!theIdx]
					prevBlock <- setdiff(prevBlock, list_blocks[[length(list_blocks)]])
					# prevBlock <- prevBlock[!prevBlock == joiningEvents]
					currBlock <- c(currBlock, list_blocks[[length(list_blocks)]])
					list_blocks <- list_blocks[-length(list_blocks)]

				}
			}

			# print(currBlock)
			if (length(list_blocks) > 0 && any(currBlock %in% list_blocks[[length(list_blocks)]]) == TRUE && all(currBlock %in% list_blocks[[length(list_blocks)]]) == FALSE ){
				list_blocks[[length(list_blocks)]] <- currBlock
			}
			else if (length(list_blocks) > 0 && all(currBlock %in% list_blocks[[length(list_blocks)]]) == FALSE){
				list_blocks[[length(list_blocks)+1]] <- currBlock
			}

		}
		# print("list blocks in getRectBlock")
		# print(list_blocks)
		# print("The list_blocks")
		# print(list_blocks)
		return (list_blocks)

}

addToRectPoints <- function(rectPoints, events, mat_eventPoints){
	# print(max(as.numeric(mat_eventPoints[events, cols_matFifty$col_x])))
	maxX <- max(as.numeric(mat_eventPoints[events, cols_matFifty$col_x]))

	rowVal = c()
	if (nrow(rectPoints) <= 1){
		rowVal <- c(-1, maxX-0.5)

	}
	else{
		rowVal <- c(rectPoints[nrow(rectPoints), 2], maxX-0.5)
	}
	# print("here")
	# print(rowVal)

	rectPoints <- rbind(rectPoints, rowVal)
	return (rectPoints)
}

makeDecrBarOpaque <- function(mat_clusConnLines, isCombined){

	if (isCombined == TRUE){
		for (i in 1:length(Color_multiomics)){
			idx <- mat_clusConnLines[,cols_clusPlotObjs$col_col] == Color_multiomics[[i]]$decr

			mat_clusConnLines[idx,cols_clusPlotObjs$col_col] = colors_orderedEvents$decr

			idx <- mat_clusConnLines[,cols_clusPlotObjs$col_col] == Color_multiomics[[i]]$incr

			mat_clusConnLines[idx,cols_clusPlotObjs$col_col] = Color_multiomics[[i]]$bar

		}
	}

	if (isCombined == FALSE){
		idx <- mat_clusConnLines[,cols_clusPlotObjs$col_col] == color_events$down

		mat_clusConnLines[idx,cols_clusPlotObjs$col_col] = colors_orderedEvents$decr

		idx <- mat_clusConnLines[,cols_clusPlotObjs$col_col] == color_events$up

		mat_clusConnLines[idx,cols_clusPlotObjs$col_col] = colors_orderedEvents$incr
	}

	return (mat_clusConnLines)
}

getClusConnLines <- function(mat_eventPoints, xStart, xEnd){
	mat_clusConnLines = matrix(ncol=5,nrow=nrow(mat_eventPoints))
	mat_basalConnLines = matrix(ncol=5,nrow=max(as.numeric(mat_eventPoints[,cols_matFifty$col_clus]))) # only need 1 for each cluster

	basalCounter = 1
	prevClus = -1

	for(i in 1:nrow(mat_eventPoints)){

		# adding start point
		mat_clusConnLines[i, cols_clusPlotObjs$col_x0] <- mat_eventPoints[i, cols_matFifty$col_x]
		mat_clusConnLines[i, cols_clusPlotObjs$col_y0] <- mat_eventPoints[i, cols_matFifty$col_y]

		# adding end y
		mat_clusConnLines[i, cols_clusPlotObjs$col_y1] <- mat_eventPoints[i, cols_matFifty$col_y]

		# adding end x
		mat_clusConnLines[i, cols_clusPlotObjs$col_x1] <- getTheEndX(mat_eventPoints, i, xEnd)

		# adding color
		mat_clusConnLines[i, cols_clusPlotObjs$col_col] <- mat_eventPoints[i, cols_matFifty$col_dir]

		## handling the adding of the basal
		if (prevClus == -1 ){
			# just store everything
			mat_basalConnLines[basalCounter, cols_clusPlotObjs$col_x0] = xStart;
			mat_basalConnLines[basalCounter, cols_clusPlotObjs$col_x1] = mat_clusConnLines[i, cols_clusPlotObjs$col_x0];
			mat_basalConnLines[basalCounter, cols_clusPlotObjs$col_y0] = mat_clusConnLines[i, cols_clusPlotObjs$col_y0];
			mat_basalConnLines[basalCounter, cols_clusPlotObjs$col_y1] = mat_clusConnLines[i, cols_clusPlotObjs$col_y1];

			mat_basalConnLines[basalCounter, cols_clusPlotObjs$col_col]  <- getOppColor(mat_eventPoints[i, cols_matFifty$col_dir])

			prevClus = mat_eventPoints[i,cols_matFifty$col_clus]
			# print(prevClus)
		}
		else if (prevClus == as.integer(mat_eventPoints[i,cols_matFifty$col_clus])){
			# update x if smaller (and then also color to be opposite)

			if (as.numeric(mat_clusConnLines[i, cols_clusPlotObjs$col_x0]) < as.numeric(mat_basalConnLines[basalCounter, cols_clusPlotObjs$col_x1]) ){
				mat_basalConnLines[basalCounter, cols_clusPlotObjs$col_x0] = mat_clusConnLines[i, cols_clusPlotObjs$col_x0];
				mat_basalConnLines[basalCounter, cols_clusPlotObjs$col_col]  <- getOppColor(mat_eventPoints[i, cols_matFifty$col_dir])
			}
		}
		else if (prevClus !=  mat_eventPoints[i,cols_matFifty$col_clus]){
			prevClus = mat_eventPoints[i,cols_matFifty$col_clus]
			basalCounter = basalCounter + 1
			# store everything again
			mat_basalConnLines[basalCounter, cols_clusPlotObjs$col_x0] = xStart;
			mat_basalConnLines[basalCounter, cols_clusPlotObjs$col_x1] = mat_clusConnLines[i, cols_clusPlotObjs$col_x0];
			mat_basalConnLines[basalCounter, cols_clusPlotObjs$col_y0] = mat_clusConnLines[i, cols_clusPlotObjs$col_y0];
			mat_basalConnLines[basalCounter, cols_clusPlotObjs$col_y1] = mat_clusConnLines[i, cols_clusPlotObjs$col_y1];

			mat_basalConnLines[basalCounter, cols_clusPlotObjs$col_col]  <- getOppColor(mat_eventPoints[i, cols_matFifty$col_dir])

		}

	}

	mat_clusConnLines = rbind(mat_clusConnLines, mat_basalConnLines)
	# print(mat_clusConnLines)
	# print(mat_eventPoints)
	return (mat_clusConnLines)

}

getOppColor <- function (thisCol){
	# omics colors
	if (thisCol == color_events$up){
		return (color_events$down)
	}
	else if (thisCol == color_events$down){
		return (color_events$up)
	}

	# multiomics colors
	for (i in 1:length(Color_multiomics)){
		if (thisCol == Color_multiomics[[i]]$incr){
			return (Color_multiomics[[i]]$decr)
		}
		else if (thisCol == Color_multiomics[[i]]$decr){
			return (Color_multiomics[[i]]$incr)
		}
	}

	return ("black")
}

getTheEndX <- function(mat_eventPoints, eventNum, defaultEndX){
	endX <- defaultEndX

	startX <- mat_eventPoints[eventNum, cols_matFifty$col_x]

	for (i in 1:nrow(mat_eventPoints)){
		if (i != eventNum){ # if not the current event
			if (mat_eventPoints[i, cols_matFifty$col_clus] == mat_eventPoints[eventNum, cols_matFifty$col_clus]){ # if same cluster
				if (as.numeric(mat_eventPoints[i, cols_matFifty$col_x]) > as.numeric(startX) && as.numeric(mat_eventPoints[i, cols_matFifty$col_x]) < as.numeric(endX)){ # if newX > startX && < endX; then update
					endX <- mat_eventPoints[i, cols_matFifty$col_x]
				}

			}
		}
	}

	return (endX)
}

getYaxisLabels <- function(mat_eventPoints){
	ord <- order(as.numeric(mat_eventPoints[,cols_matFifty$col_x]))
	clusNums <- as.numeric(mat_eventPoints[ord,1])
	clusNumLabels <- c()

	for(i in 1:length(clusNums)){
		if (! clusNums[[i]] %in% clusNumLabels){
			clusNumLabels <- append(clusNumLabels, clusNums[[i]])
		}
	}
	vec_labels =  as.vector(clusNumLabels)

	return (vec_labels)
}

getYIfClusPres <- function(currClusNum, mat_eventPoints){

	for (rowNum in 1:nrow(mat_eventPoints)){
		if (!is.na(mat_eventPoints[rowNum, cols_matFifty$col_clus]) && currClusNum == mat_eventPoints[rowNum, cols_matFifty$col_clus]){
			return (mat_eventPoints[rowNum, cols_matFifty$col_y])
		}
	}

	return (-1)
}

isAnyNonSignifFromPrevAll <- function(list_eventsOrder, currLayerNum, signifs){

	for (i in seq(1, (currLayerNum - 1))){
		isAny = isAnyNonSignifFromPrev(list_eventsOrder[[currLayerNum]], list_eventsOrder[[i]], signifs)
		if (isAny == TRUE){
			return (TRUE)
		}
	}

	return (FALSE)
}

getColorIfMultiOmics <- function(eventNum, mat_events, dir){
	datasetNum <- mat_events[eventNum, Col_events$combinedDatasetNum]

	if (is.na(datasetNum) && dir == 1){
		return(color_events$up)
	}
	else if (is.na(datasetNum) && dir == -1){
		return(color_events$down)
	}

	# otherwise its a multiomics data sets.
	if (dir == 1){
		return(Color_multiomics[[datasetNum]]$incr)
	}

	else if(dir == -1){
		return(Color_multiomics[[datasetNum]]$decr)
	}

}

getTheClusLines <- function(mat_fiftyPoints, list_eventsOrder, signifs, list_blocks, xStart, xIncrSig, xIncrNonSig, yDecr){ #xStart, yStart, y_decr, x_incr_sig, x_incr_nonSig

	mat_eventPoints <- matrix(nrow=nrow(mat_fiftyPoints), ncol=4)

	x <- xStart
	y <- max(mat_fiftyPoints[,1])

	eventsVisited = c()

	for (i in 1:length(list_eventsOrder)){
		for (j in 1:length(list_eventsOrder[[i]])){
			eventNum <- list_eventsOrder[[i]][j]

			# adding y coordinate
			prevY <- getYIfClusPres(mat_fiftyPoints[eventNum, cols_matFifty$col_clus], mat_eventPoints)
			if (prevY == -1){
				mat_eventPoints[eventNum, cols_matFifty$col_y] <- y
				y <- y - yDecr
			}
			else{
				mat_eventPoints[eventNum, cols_matFifty$col_y] <- prevY
			}

			# assigning color

			# if (mat_fiftyPoints[eventNum, cols_matFifty$col_dir] == 1){
			theColor <- getColorIfMultiOmics(eventNum, mat_fiftyPoints, mat_fiftyPoints[eventNum, cols_matFifty$col_dir])

			mat_eventPoints[eventNum, cols_matFifty$col_dir] = theColor
			# }
			#else{
			#	theColor <- getColorIfMultiOmics(eventNum, mat_fiftyPoints, -1)
			#	mat_eventPoints[eventNum, cols_matFifty$col_dir] = theColor
			#}

			# assigning cluster number
			mat_eventPoints[eventNum, cols_matFifty$col_clus] <- mat_fiftyPoints[eventNum, cols_matFifty$col_clus]

			eventsVisited <- c(eventsVisited, eventNum)
		}

		# adding x coordinate
		if (i == 1){
			#print("over here..?")
			mat_eventPoints <- addXForAll(list_eventsOrder[[i]], mat_eventPoints, x)
		}
		else{
			# if (isAnyNonSignifFromPrev(list_eventsOrder[[i]], list_eventsOrder[[i-1]], signifs) == TRUE){ # place events closer together
			if (isAnyNonSignifFromPrevAll(list_eventsOrder, i, signifs) == TRUE || isInSameBlock(list_eventsOrder[[i]], eventsVisited, list_blocks)){
				x <- x + xIncrNonSig
			}
			else {
				x <- x + xIncrSig
			}

			mat_eventPoints <- addXForAll(list_eventsOrder[[i]], mat_eventPoints, x)

		}
	}

	# print("The mat event points:")
	# print (mat_eventPoints)
	return (mat_eventPoints)

}

isInSameBlock <- function(events, eventsVisited, list_blocks){

	# 1. find block.
	# 2. exclude events from block, and from eventsVisited.
	# 3. See if others in block, which are also visited.
	# if so, return true, else return false.

	blockNum <- findBlock(events[1], list_blocks)

	eventsInBlock <-  as.vector(list_blocks[[blockNum]])
	otherEventsInBlock <- setdiff(eventsInBlock, events)

	otherEventsVisited <- setdiff(eventsVisited, events)

	if (length(otherEventsInBlock) > 0 && length(otherEventsVisited) > 0 && (any(otherEventsVisited %in% otherEventsInBlock) || any(otherEventsInBlock %in% otherEventsVisited))) {
		return (TRUE)
	}

	return (FALSE)
}

findBlock <- function(event, list_blocks){
	i = -1
	for (i in 1:length(list_blocks)){
		if (event %in% list_blocks[[i]]){
			return (i)
		}
	}

	return (i)
}

isAnyNonSignifFromPrev <- function(vec_curr, vec_prev, signifs){

	for (i in 1:length(vec_curr)){
		for (j in 1:length(vec_prev)){

			# print(paste(i, j, length(vec_curr), length(vec_prev), signifs[vec_curr[i], vec_prev[j]]))

			if (signifs[vec_curr[i], vec_prev[j]] == FALSE){
				return (TRUE)
			}

		}
	}

	return (FALSE)
}

addXForAll <- function(vec_curr, mat_eventPoints, x){

	for (i in 1:length(vec_curr)){
		mat_eventPoints[vec_curr[i], cols_matFifty$col_x] <- x
	}

	return (mat_eventPoints)
}


#autor:      Joao Sollari Lopes
#local:      INE, Lisboa
#Rversion:   3.6.1
#criado:     10.07.2017
#modificado: 06.12.2019

set.seed(12345)
n <- 20
x <- rep(0,n)
y <- rep(0,n)
x1 <- x + rnorm(n,sd=0.2)
y1 <- y + rnorm(n,sd=0.2)
x2 <- x + rnorm(n,sd=0.5)
y2 <- y + rnorm(n,sd=0.5)
x3 <- x + rnorm(n,sd=0.2) - 1
y3 <- y + rnorm(n,sd=0.2)

fnam <- "../images/concept_1.tiff"
tiff(file=fnam,units="in",width=9,height=3,res=300,compression="lzw")
par(mfrow=c(1,3),mgp=c(2,0.75,0),mar=c(3.1,3.1,0.2,0.2))
plot(0,0,xlim=c(-2,2),ylim=c(-2,2),pch=16,cex=1.5,col=1,xlab="x",ylab="y")
lines(c(-2,0),c(0,0),lwd=1.5,lty=2,col=1)
lines(c(0,0),c(-2,0),lwd=1.5,lty=2,col=1)
points(x1,y1,col=2,cex=1.5)
text(-2,2,"High accuracy | High precision",pos=4,cex=1.5,col=2)
plot(0,0,xlim=c(-2,2),ylim=c(-2,2),pch=16,cex=1.5,col=1,xlab="x",ylab="y")
lines(c(-2,0),c(0,0),lwd=1.5,lty=2,col=1)
lines(c(0,0),c(-2,0),lwd=1.5,lty=2,col=1)
points(x2,y2,col=2,cex=1.5)
text(-2,2,"High accuracy | Low precision",pos=4,cex=1.5,col=2)
plot(0,0,xlim=c(-2,2),ylim=c(-2,2),pch=16,cex=1.5,col=1,xlab="x",ylab="y")
lines(c(-2,0),c(0,0),lwd=1.5,lty=2,col=1)
lines(c(0,0),c(-2,0),lwd=1.5,lty=2,col=1)
points(x3,y3,col=2,cex=1.5)
text(-2,2,"Low accuracy | High precision",pos=4,cex=1.5,col=2)
dev.off()


levelplot(z ~ x+y, pretty=TRUE, contour=TRUE, data=d3)


include	defs

# gctoi --- convert any radix string to single precision integer

   integer function gctoi (str, i, radix)
   character str (ARB)
   integer i, radix

   integer base, v, d, j
   external index
   integer index

   character clower

   logical neg

   string digits "0123456789abcdef"

   v = 0
   base = radix

   while (str (i) == BLANK | str (i) == TAB)
      i = i + 1

   neg = (str (i) == MINUS)
   if (str (i) == PLUS | str (i) == MINUS)
      i = i + 1

   if (str (i + 2) == LETR & str (i) == DIG1 & IS_DIGIT(str (i + 1))
	 | str (i + 1) == LETR & IS_DIGIT(str (i))) {
      base = str (i) - DIG0
      j = i
      if (str (i + 1) != LETR) {
	 j = j + 1
	 base = base * 10 + (str (j) - DIG0)
	 }
      if (base < 2 | base > 16)
	 base = radix
      else
	 i = j + 2
      }

   for (; str (i) != EOS; i = i + 1) {
      if (IS_DIGIT(str (i)))
	 d = str (i) - DIG0
      else
	 d = index (digits, clower (str (i))) - 1
      if (d < 0 | d >= base)
	 break
      v = v * base + d
      }

   if (neg)
      return (-v)
   else
      return (+v)

   end


## ----echo=FALSE---------------------------------------------------------------
require(Hmisc)
knitrSet('coxcase')

## -----------------------------------------------------------------------------
require(rms)
options(prType='latex')   # for print, summary, anova
getHdata(prostate)
levels(prostate$ekg)[levels(prostate$ekg) %in%
                     c('old MI','recent MI')] <- 'MI'
# combines last 2 levels and uses a new name, MI

prostate$pf.coded <- as.integer(prostate$pf)
# save original pf, re-code to 1-4
levels(prostate$pf)  <- c(levels(prostate$pf)[1:3],
                          levels(prostate$pf)[3])
# combine last 2 levels

w <- transcan(~ sz + sg + ap + sbp + dbp + age +
              wt + hg + ekg + pf + bm + hx,
              imputed=TRUE, data=prostate, pl=FALSE, pr=FALSE)

attach(prostate)
sz  <- impute(w, sz, data=prostate)
sg  <- impute(w, sg, data=prostate)
age <- impute(w, age,data=prostate)
wt  <- impute(w, wt, data=prostate)
ekg <- impute(w, ekg,data=prostate)

dd <- datadist(prostate); options(datadist='dd')

units(dtime) <- 'Month'
S <- Surv(dtime, status != 'alive')

f <- cph(S ~ rx + rcs(age,4) + rcs(wt,4) + pf + hx +
         rcs(sbp,4) + rcs(dbp,4) + ekg + rcs(hg,4) +
         rcs(sg,4) + rcs(sz,4) + rcs(log(ap),4) + bm)

## ----results="asis"-----------------------------------------------------------
print(f, coefs=FALSE)

## ----results="asis"-----------------------------------------------------------
heart <- hx + ekg %nin% c('normal','benign')
label(heart) <- 'Heart Disease Code'
map   <- (2*dbp + sbp)/3
label(map) <- 'Mean Arterial Pressure/10'
dd <- datadist(dd, heart, map)

f <- cph(S ~ rx + rcs(age,4) + rcs(wt,3) + pf.coded +
         heart + rcs(map,3) + rcs(hg,4) +
         rcs(sg,3) + rcs(sz,3) + rcs(log(ap),5) + bm,
         x=TRUE, y=TRUE, surv=TRUE, time.inc=5*12)
print(f, coefs=3)
# x, y for predict, validate, calibrate;
# surv, time.inc for calibrate
print(anova(f), table.env=TRUE, label='tab:coxcase-anova1')# Table (*\ref{tab:coxcase-anova1}*)

## ----rx-ph,cap='Raw and spline-smoothed scaled Schoenfeld residuals for dose of estrogen, nonlinearly coded from the Cox model fit, with $\\pm$ 2 standard errors.',scap='Schoenfeld residuals for dose of estrogen in Cox model'----
phtest <- cox.zph(f, terms=TRUE)
phtest
plot(phtest, var='rx')   # Figure (*\ref{fig:coxcase-rx-ph}*)

## ----results='asis'-----------------------------------------------------------
z <- predict(f, type='terms')
z.dose <- z[,"rx"]  # same as saying z[,1] - get first column
z.other <- z[,-1]   # all but the first column of z
f.ia <- cph(S ~ z.dose * z.other)   # Figure (*\ref{tab:coxcase-anova2}*):
print(anova(f.ia), table.env=TRUE, label='tab:coxcase-anova2')

## ----cox-shapes,h=6,w=6.75,cap='Shape of each predictor on log hazard of death.  $Y$-axis shows $X\\hat{\\beta}$, but the predictors not plotted are set to reference values.  Note the highly non-monotonic relationship with \\co{ap}, and the increased slope after age 70 which occurs in outcome models for various diseases.',scap='Shapes of predictors for log hazard in prostate cancer'----
ggplot(Predict(f), sepdiscrete='vertical', nlevels=4,
       vnames='names')  # Figure (*\ref{fig:coxcase-cox-shapes}*)

## ----results='asis'-----------------------------------------------------------
set.seed(1)  # so can reproduce results
v <- validate(f, B=300)
latex(v, file='')

## ----cal-cox,cache=TRUE,cap='Bootstrap estimate of calibration accuracy for 5-year estimates from the final Cox model, using adaptive linear spline hazard regression~\\cite{koo95haz}.  The line nearer the ideal line corresponds to apparent predictive accuracy.  The blue curve corresponds to bootstrap-corrected estimates.',scap='Bootstrap estimates of calibration accuracy in prostate cancer model'----
cal <- calibrate(f, B=300, u=5*12, maxdim=4)
plot(cal, subtitles=FALSE)   # Figure (*\ref{fig:coxcase-cal-cox}*)

## ----summary-cox,top=1,cap='Hazard ratios and multi-level confidence bars for effects of predictors in model, using default ranges except for \\co{ap}',scap='Hazard ratios for prostate survival model'----
plot(summary(f, ap=c(1,20)), log=TRUE, main='')  # Figure (*\ref{fig:coxcase-summary-cox}*)

## ----cox-nomogram,w=6,h=7,ps=8,cap='Nomogram for predicting death in prostate cancer trial'----
surv  <- Survival(f)
surv3 <- function(x) surv(3*12,lp=x)
surv5 <- function(x) surv(5*12,lp=x)
quan  <- Quantile(f)
med   <- function(x) quan(lp=x)/12
ss    <- c(.05,.1,.2,.3,.4,.5,.6,.7,.8,.9,.95)

nom <- nomogram(f, ap=c(.1,.5,1,2,3,4,5,10,20,30,40),
                fun=list(surv3, surv5, med),
                funlabel=c('3-year Survival','5-year Survival',
                  'Median Survival Time (years)'),
                fun.at=list(ss, ss, c(.5,1:6)))
plot(nom, xfrac=.65, lmgp=.35)   # Figure (*\ref{fig:coxcase-cox-nomogram}*)


na.levs <- function(x, naset=NULL, setmid=NULL, set1=NULL, set0=NULL, setmean=NULL, setmedian=NULL, setmode=NULL, weight=NULL)
  UseMethod("na.levs")

na.levs.factor <- function(x, naset=NULL, setmedian=NULL, setmode=NULL, weight=NULL){
  x[x %in% naset] <- NA
  q <- (x %in% setmedian)
  r <- (x %in% setmode)
  x[q] <- NA
  x[r] <- NA
  x <- drop.levels(x, reorder=FALSE)
  if(!is.null(weight))
    x[q] <- names(table(x))[eval(sapply(1:length(table(x)), function(g) sum(wtd.table(x, weights)$sum.of.weights[1:g])/sum(wtd.table(x, weights)$sum.of.weights))>.5)][1]
  if(is.null(weight))
    x[q] <- names(table(x))[eval(sapply(1:length(table(x)), function(g) sum(table(x)[1:g])/sum(table(x)))>.5)][1]
  x[r] <- names(sort(table(x), decreasing=TRUE))[1]
  x
}

na.levs.numeric <- function(x, naset=NULL, setmid=NULL, set1=NULL, set0=NULL, setmean=NULL, weight=NULL){
  x[x %in% naset] <- NA
  q <- (x %in% setmid)
  r <- (x %in% set1)
  s <- (x %in% set0)
  t <- (x %in% setmean)
  x[q] <- NA
  x[r] <- NA
  x[s] <- NA
  x[t] <- NA
  x <- as.numeric(x)
  x <- (x-range(x, na.rm=TRUE)[1])/range((x-range(x, na.rm=TRUE)[1]), na.rm=TRUE)[2]
  x[q] <- .5
  x[r] <- 1
  x[s] <- 0
  if(!is.null(weight))
    x[t] <- wtd.mean(x, weight, na.rm=TRUE)
  else
    x[t] <- mean(x, na.rm=TRUE)
  x
}

na.levs.default <- function(x, naset=NULL, setmid=NULL, set1=NULL, set0=NULL, setmean=NULL, weight=NULL){
  x <- as.numeric(x)
  x[x %in% naset] <- NA
  q <- (x %in% setmid)
  r <- (x %in% set1)
  s <- (x %in% set0)
  t <- (x %in% setmean)
  x[q] <- NA
  x[r] <- NA
  x[s] <- NA
  x[t] <- NA
  x <- as.numeric(x)
  x <- (x-range(x, na.rm=TRUE)[1])/range((x-range(x, na.rm=TRUE)[1]), na.rm=TRUE)[2]
  x[q] <- .5
  x[r] <- 1
  x[s] <- 0
  if(!is.null(weight))
    x[t] <- wtd.mean(x, weight, na.rm=TRUE)
  else
    x[t] <- mean(x, na.rm=TRUE)
  x
}


context("Trans - numeric")

test_that("Pseudo-log is invertible", {
  trans <- pseudo_log_trans()
  expect_equal(
    trans$inverse(trans$transform(-10:10)),
    -10:10
  )
})

test_that("Modulus is invertible for negative and positive numbers", {
  trans <- modulus_trans(p = .1)
  expect_equal(trans$inv(trans$trans(-10:10)), -10:10)
  trans <- modulus_trans(p = -2)
  expect_equal(trans$inv(trans$trans(-10:10)), -10:10)
  trans <- modulus_trans(p = 1)
  expect_equal(trans$inv(trans$trans(-10:10)), -10:10)
})

test_that("Boxcox gives error for negative values", {
  trans <- boxcox_trans(p = .1)
  expect_error(trans$trans(-10:10))
  trans <- boxcox_trans(p = -2)
  expect_error(trans$trans(-10:10))
})

test_that("Boxcox is invertible", {
  trans <- boxcox_trans(p = .1)
  expect_equal(trans$inv(trans$trans(0:10)), 0:10)
  trans <- boxcox_trans(p = -2)
  expect_equal(trans$inv(trans$trans(0:10)), 0:10)
  trans <- boxcox_trans(p = 1)
  expect_equal(trans$inv(trans$trans(0:10)), 0:10)
})


#########################################
# File Name:-Assignment16.R
# Subject:- Support Vector Machine
# Author:- Debadutta Dey
#########################################

install.packages("kernlab")
install.packages("caTools")

library(XML)
library(kernlab)
library(caret)
library(sqldf)

###################################################################################################
# SalaryData_Train.csv
###################################################################################################
##Loading .csv into R
## File name "SalaryData_Train.csv"
SalaryData <- read.csv(file.choose(),header = TRUE,sep = ",",na.strings = c("NA","Na","nA","na",""))

sum(is.na(SalaryData))

summary(SalaryData)

str(SalaryData)

#############################################################################
# Feature Engineering
##############################################################################
factor_vars <- c ("workclass", "education", "maritalstatus", "occupation", "relationship","race","sex","native")

all_iv <- data.frame(VARS=factor_vars, IV=numeric(length(factor_vars)), STRENGTH=character(length(factor_vars)), stringsAsFactors = F)

for (factor_var in factor_vars){
  all_iv[all_iv$VARS == factor_var, "IV"] <- InformationValue::IV(X=SalaryData[, factor_var], Y=SalaryData$Salary)
  all_iv[all_iv$VARS == factor_var, "STRENGTH"] <- attr(InformationValue::IV(X=SalaryData[, factor_var], Y=SalaryData$Salary), "howgood")
}

all_iv <- all_iv[order(-all_iv$IV), ]

all_iv

SalaryData1<-SalaryData[,c(1,4,10,11,14)]

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

mod1<-ksvm(Salary~., data=SalaryData,kernal="rbfdot")   #0.8541169   0.8543825
?ksvm

SalaryDataTest <- read.csv(file.choose(),header = TRUE,sep = ",",na.strings = c("NA","Na","nA","na",""))

Pred <-predict(mod1,newdata = SalaryDataTest)

mean(Pred==SalaryDataTest$Salary)

table(Pred,SalaryDataTest$Salary)

## With Feature engineering

mod2<-ksvm(Salary~., data=SalaryData1,kernal="rbfplot")
?ksvm

SalaryDataTest1<-SalaryData[,c(1,4,10,11,14)]

Pred <-predict(mod2,newdata = SalaryDataTest1)

mean(Pred==SalaryDataTest1$Salary)

table(Pred,SalaryDataTest1$Salary)

## mod1 is final as it has higher accuracy.

###################################################################################################
# forestfires.csv
###################################################################################################
##Loading .csv into R
## File name "forestfires.csv"
forestfires <- read.csv(file.choose(),header = TRUE,sep = ",",na.strings = c("NA","Na","nA","na",""))

sum(is.na(forestfires))

summary(forestfires)

str(forestfires)

forestfires1<-forestfires

forestfires1$dayfri<-as.factor(forestfires1$dayfri)
forestfires1$daymon<-as.factor(forestfires1$daymon)
forestfires1$daysat<-as.factor(forestfires1$daysat)
forestfires1$daysun<-as.factor(forestfires1$daysun)
forestfires1$daythu<-as.factor(forestfires1$daythu)
forestfires1$daytue<-as.factor(forestfires1$daytue)
forestfires1$daywed<-as.factor(forestfires1$daywed)

forestfires1$monthapr<-as.factor(forestfires1$monthapr)
forestfires1$monthaug<-as.factor(forestfires1$monthaug)
forestfires1$monthdec<-as.factor(forestfires1$monthdec)
forestfires1$monthfeb<-as.factor(forestfires1$monthfeb)
forestfires1$monthjan<-as.factor(forestfires1$monthjan)
forestfires1$monthjul<-as.factor(forestfires1$monthjul)
forestfires1$monthjun<-as.factor(forestfires1$monthjun)
forestfires1$monthmar<-as.factor(forestfires1$monthmar)
forestfires1$monthmay<-as.factor(forestfires1$monthmay)
forestfires1$monthnov<-as.factor(forestfires1$monthnov)
forestfires1$monthoct<-as.factor(forestfires1$monthoct)
forestfires1$monthsep<-as.factor(forestfires1$monthsep)

str(forestfires1)
############################################################################
## Stratfied sampling
############################################################################

forestfires1_large<-forestfires1[forestfires1$size_category=="large",] # 139
forestfires1_small<-forestfires1[forestfires1$size_category=="small",] # 378

i=100
j=100

train <- rbind(forestfires1_large[1:i,],forestfires1_small[1:j,])
test <- rbind(forestfires1_large[i+1:139,],forestfires1_small[j+1:378,])
summary(test)

test<-sqldf("select * from test where size_category is not null")

sqldf("select count(1),size_category from forestfires1 group by size_category")
library(caTools)
train_rows = sample.split(forestfires1$size_category, SplitRatio=0.8)
train = forestfires1[train_rows,]
test  = forestfires1[-train_rows,]

#############################################################################
mod1<-ksvm(size_category~., data=train,kernal="vanilladot")

Pred <-predict(mod1,newdata = test)

mean(Pred==test$size_category)

mod2<-ksvm(size_category~., data=train,kernal="rbfdot")

Pred <-predict(mod2,newdata = test)

mean(Pred==test$size_category)

table(Pred,test$size_category)

mod3<-ksvm(size_category~., data=train,kernal="besseldot")

Pred <-predict(mod3,newdata = test)

mean(Pred==test$size_category)

table(Pred,test$size_category)

mod4<-ksvm(size_category~., data=train,kernal="anovadot")

Pred <-predict(mod4,newdata = test)

mean(Pred==test$size_category)

table(Pred,test$size_category)

mod5<-ksvm(size_category~., data=train,kernal="splinedot")

Pred <-predict(mod5,newdata = test)

mean(Pred==test$size_category)

table(Pred,test$size_category)

mod6<-ksvm(size_category~., data=train,kernal="stringdot")

Pred <-predict(mod6,newdata = test)

mean(Pred==test$size_category)

table(Pred,test$size_category)

## mod4 is final model

16. Support Vector Machine/SupportVectorMachine.r


 E04FFJ Example Program Results

  ---------------------------------------------------
  E04F(G|F)), Derivative free solver for data fitting
              (nonlinear least-squares problems)
  ---------------------------------------------------

  Problem statistics
    Number of variables                  4
    Number of unconstrained variables    2
    Number of fixed variables            0
    Starting interpolation points        5
    Total interpolation points           5
    Number of residuals                 11

 Begin of Options
     Print File                    =                   6     * d
     Print Level                   =                   2     * d
     Print Options                 =                 Yes     * d
     Print Solution                =                 All     * U
     Monitoring File               =                  -1     * d
     Monitoring Level              =                   4     * d
     Dfo Print Frequency           =                   1     * d
     Dfo Monitor Frequency         =                   0     * d

     Infinite Bound Size           =         1.00000E+20     * d
     Stats Time                    =                  No     * d
     Time Limit                    =         1.00000E+06     * d

     Dfo Initial Interp Points     =          Coordinate     * d
     Dfo Max Objective Calls       =                 500     * d
     Dfo Max Soft Restarts         =                   5     * d
     Dfo Max Unsucc Soft Restarts  =                   3     * d
     Dfo Maximum Slow Steps        =                  20     * d
     Dfo Noise Level               =         0.00000E+00     * d
     Dfo Noisy Problem             =                  No     * d
     Dfo Number Initial Points     =                   0     * d
     Dfo Number Interp Points      =                   0     * d
     Dfo Number Soft Restarts Pts  =                   3     * d
     Dfo Random Seed               =                  -1     * d
     Dfo Starting Trust Region     =         1.00000E-01     * d
     Dfo Trust Region Slow Tol     =         1.02648E-04     * d
     Dfo Trust Region Tolerance    =         5.00000E-06     * U
     Dfo Version                   =              Latest     * d
     Dfls Small Residuals Tol      =         1.08158E-12     * d
 End of Options
  ----------------------------------------
   step |    obj        rho    |    nf   |
  ----------------------------------------
      1 |  1.72E-03  1.00E-01  |     6   |
      2 |  6.41E-04  1.00E-01  |     7   |
      3 |  4.52E-04  1.00E-01  |     8   |
      4 |  4.05E-04  1.00E-02  |     9   |
      5 |  4.04E-04  1.00E-02  |    10   |
      6 |  4.03E-04  1.00E-02  |    14   |
      7 |  4.02E-04  1.00E-02  |    15   |
      8 |  4.02E-04  1.00E-03  |    20   |
      9 |  4.02E-04  7.07E-05  |    21   |
     10 |  4.02E-04  7.07E-05  |    23   | s
  ----------------------------------------
  Status: Converged, small trust region size

  Value of the objective                    4.02423E-04
  Number of objective function evaluations           27
  Number of steps                                    10

 Primal variables:
   idx   Lower bound        Value      Upper bound
     1       -inf       1.81300E-01         inf
     2   2.00000E-01    5.90128E-01    1.00000E+00
     3       -inf       2.56929E-01         inf
     4   3.00000E-01    3.00000E-01         inf


library(nloptr)
library(rlist)
library(Rlab)
library(RJSONIO)

source("likelihood_incubation_exp/model_fitting.r")
# load data and initialize parameters
load("CasosAjustados_Diagnostico.Rda")
params = list(
  "lambda" = 2 ^ 20,
  "beta_min" = 0.1,
  "beta_max" = 0.7,
  "tau1_min" = 1 / 3,
  "tau1_max" = 10,
  "tau2_min" = 1 / 40,
  "tau2_max" = 1 / 4,
  "N0_min" = 0,
  "N0_max" = 0,
  "A0_min" = 0,
  "A0_max" = 10,
  "t0" = 1
)

observed_I = data$`Estimados Totales`
observed_I = c(observed_I[1], 0, tail(observed_I, -1))
observed_I = observed_I[params$t0:length(observed_I)]

for (i in 1:1000) {
  params$beta0 = runif(length(observed_I), params$beta_min, params$beta_max)
  params$tau10 = runif(1, params$tau1_min, params$tau1_max)
  params$tau20 = runif(1, params$tau2_min, params$tau2_max)
  params$N00 = runif(1, params$N0_min, params$N0_max)
  params$A00 = runif(1, params$A0_min, params$A0_max)
  params$observed_I = observed_I
  # fit Nicolas's model
  model = fit(observed_I, beta0=params$beta0, beta_min=params$beta_min,
              beta_max=params$beta_max, tau10=params$tau10,
              tau1_min=params$tau1_min, tau1_max=params$tau1_max,
              tau20=params$tau20, tau2_min=params$tau2_min,
              tau2_max=params$tau2_max, N00=params$N00, N0_min=params$N0_min,
              N0_max=params$N0_max, A00=params$A00, A0_min=params$A0_min,
              A0_max=params$A0_max, lambda=params$lambda, ignore_beta_diff=26)
  # save fitted model and parameters
  timestamp = format(Sys.time(), "%Y%m%d%H%M")
  out_dir = paste("likelihood_incubation_exp", "tuned", timestamp, sep="/")
  dir.create(out_dir, recursive=TRUE)
  write(toJSON(params), paste(out_dir, "params.json", sep="/"))
  write(toJSON(model), paste(out_dir, "model.json", sep="/"))
  # plot reproduction number series
  R = model$beta / model$tau2
  png(paste(out_dir, "R(t).png", sep="/"))
  plot(R, xlab="t", ylab="R(t)", type="l")
  dev.off()
  # plot expected new cases with confidence intervals
  expected_I = get_expected(model$beta, model$tau1, model$tau2, model$N0,
                            model$A0)$I
  png(paste(out_dir, "I(t).png", sep="/"))
  plot(1:length(expected_I), expected_I, type="l")
  lines(1:length(observed_I), observed_I, col="red")
  dev.off()
}


################################################################################
#        1         2         3         4         5          6        7         8
#2345678901234567890123456789012345678901234567890123456789012345678901234567890
################################################################################
# PARAMETER FUNCTION
# functions used in estimation of parameters for warmouth model
#-------------------------------------------------------------------------------
# Growth functions

# Function to est growth based on VB relationship
# can use form with t0 or form with L0
# use of either form based on specification of t0 or L0
# can only specify 1 and other must be NA
VB.growth <- function(t, Linf, K, t0 = NA, L0 = NA, names = FALSE) {

    if(is.na(L0[1])){
        L <- Linf * (1 - exp(-K * (t - t0)))  # t0 form
    } else if (is.na(t0[1])) {
        L <- Linf - (Linf - L0) * exp(-K * t) # L0 form
    }
    if(names == TRUE) names(L) <- paste0("L", t)
    L
}

# function to est age from VB growth function
# can use form with t0 or form with L0
# use of either form based on specification of t0 or L0
# can only specify 1 and other must be NA
agebyVB <- function(L, Linf, K, t0 = NA, L0 = NA){

    if(is.na(L0[1])){
        t <- -1 / K * log( 1 - L / Linf) + t0    # t0 form
    } else if (is.na(t0[1])) {
        t <- log(-((L - Linf) / (Linf - L0)))/-K # L0 form
    }
    t
}

#-------------------------------------------------------------------------------
# Estimate population growth rate and predict confidence/prediction interval
# Based on data and fit from Randall et al (1995) and adjustemnt to relationship
# from Randall and Minns (2000)

r_max_pred <- function(w,         # prediction weight
                       h,         # prediction habitat (1 = lake; 2 = river)
                       interval){ # confidence or prediction interval

    # Data from Randall et al. (1995)
    data <- as.data.frame(list(
        Production = c(30.3, 3.8, 2.0, 228.5, 15.5, 4.7, 21.5, 30.8, 5.7, 85.7, 8.6,
                       270.0, 596.0, 198.0, 140.0, 100.0,  74.0,  52.0, 30.0, 174.5,
                       280.3, 243.5, 226.4, 375.4, 379.1, 217.6, 500.6, 297.2, 110.3,
                       128.8, 161.4, 83.4, 807.2, 228.0, 329.0, 168.7, 57.2, 147.3,
                       54.8, 76.5, 30.7, 35.3, 261.5, 98.3, 39.3, 33.3, 47.5, 26.1,
                       31.2, 53.0, 456.2, 80.3, 29.4),
        biomass = c(73.0, 7.3, 9.2, 372.2, 32.2, 11.2, 28.9, 11.6, 24.4, 277.8, 29.5,
                    161.2, 198.0,  95.0,  75.0,  59.0,  51.0, 129.0, 62.0, 124.4,
                    274.8, 228.4, 149.9, 376.0, 278.7, 127.5, 217.5, 187.2, 111.2,
                    241.0, 307.5, 50.2, 310.5, 142.5, 86.6, 45.6, 10.8, 40.9, 49.8,
                    42.5, 38.4, 37.4, 173.0, 71.0, 30.5, 21.3, 38.5, 21.5, 27.1, 36.0,
                    233.4, 80.2, 15.4),
        weight = c(18.0246914, 3.5540409, 25.8426966, 6.6786291, 24.2105263, 37.8378378,
                   17.8947368, 5.7058534, 219.8198198, 13.6712598, 64.2701525, 1.24,
                   0.2544987, 1.4843750, 3.0, 2.4583333, 5.6666667, 18.4285714, 15.5,
                   2.4777915, 2.3869707, 1.4815487, 0.7197976, 3.7586469, 1.3582997,
                   2.0675564, 1.6603053, 0.6602313, 2.8333376, 13.9872316, 6.1428743,
                   2.1183222, 9.3047648, 4.2462529, 4.4194948, 0.4892704, 1.6410880,
                   0.8880686, 7.9935795,   0.9173916, 5.9222702, 10.0700054, 0.8397202,
                   1.3179144, 1.9223497, 2.1759117, 3.3804548, 2.6022755, 3.7215051,
                   2.7067669, 5.1344098, 12.0819524, 0.6273679),
        habitat = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
                    1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
                    1, 1, 1, 1, 1, 1, 1, 1, 1)
    ))

    # fit regression model
    mod = lm(log10(Production/biomass) ~ log10(weight) + habitat, data = data)

    # x prediction values
    pred.data = data.frame(weight = w, habitat = h)

    # make prediction with desired interval estiamte
    rmax = (predict(mod, pred.data, interval = interval))

    # retransform and multiply by 2 (Randall and Minns 2000)
    10^rmax*2
}

#-------------------------------------------------------------------------------
# OTHER

# function to calc geometric mean between sequenital values in a vector
geom_mean_seq <- function(vec) {
    n = length(vec)
    sqrt(vec[2:n]*vec[1:(n-1)])
}

# geometric mean of a vector
geom_mean <- function(vec, na.rm = FALSE) {
    exp(mean(log(vec), na.rm = na.rm))
}

#-------------------------------------------------------------------------------
# For parameterizing projection matrix from expression

pmx_eval = function(mx, vars){
  matrix(sapply(mx, eval, vars),  sqrt(length(mx)), sqrt(length(mx)), byrow = T)
}

#===============================================================================
# Distribution functions

# Function to estimate shape parameters of the beta distribution
# from the defined mean and variance of data
beta_val <- function(mean, var){

  a <- mean * ((mean * (1 - mean)) / var - 1)
  b <- (1 - mean) * ((mean * (1 - mean)) / var - 1)

  list(a = a, b = b)
}

# Function to estimate shape parameters of the streched beta distribution
# from the defined mean and variance of data
# Streched beta is a beta dist'n scaled to outside (0,1) limits
# shape parameters give regulare beat dist'n which must be scaled with
# (max - min) + min when generating values with rbeta
beta_stretch_val <- function(mean, var = NA, sd = NA){

  if(is.na(var[1])) var = sd^2    # calc variance if not given
  if(is.na(sd[1])) sd = sqrt(var) # calc sd if not given

  # estimate mins and max of distribution
  min = qnorm(1e-6, mean, sd = sd)
  max = qnorm(1 - 1e-6, mean, sd = sd)

  # Scale means and variance to between 0 and 1
  mean.b <- (mean - min) / (max - min)
  var.b <- var * (1 / (max - min))^2

  # estimate beta dist'n shape parameters
  a <- mean.b * ((mean.b * (1 - mean.b)) / var.b - 1)
  b <- (1 - mean.b) * ((mean.b * (1 - mean.b)) / var.b - 1)

  # output
  list(a = a, b = b, min = min, max = max)
}

#===============================================================================
# Initial population size vector
# est. pop vector from desire adult population size

init_pop <- function(mx,   # Population Matrix
                     Nt,   # desire adult density
                     p.rep # maturity vector - 1: mature; 0: Juvenle; length Tmax + 1
)
{

  SS <- stable.stage(mx)                           # Stable stage distn
  Na <- SS * p.rep / sum(SS * p.rep) * Nt          # Calc adult pop
  Nj <- SS * (1-p.rep)/ sum(SS * p.rep) * Nt       # Calc juv pop
  N <- Nj + Na
  N
}

#===============================================================================

# Function to project population size including density dependence effects
Projection <- function(mx,          # projection matrix expression
                       data,        # life history data
                       lh_mean,     # mean life history data
                       N0,          # initial age1+ population size pop size
                       years,       # years to run simulation
                       p.cat,       # Probability of castastrophe
                       density_dependence = FALSE, # Boolean; if density-depedence included
                       demographic_stoch = FALSE,  # Boolean: if dempgraphic stochasticity included
                       allee = FALSE               # Boolean: if allee effects included
){
  #-----------------------------------------------------------------------------

  # needs popbio library
  require(popbio)

  # Castastrophes
  Catastrophe = sample(c(1,0), years, replace = TRUE,
                       prob = c(p.cat / data$gen.time, 1 - p.cat  / data$gen.time))

  # effect on castastrophe on pop size (percent recuction) - scaled Beta dist'n fit from Reed et al. (2003)
  e.cat <- sapply(Catastrophe, function(x) {
    ifelse(x == 0, NA, rbeta(1, shape1 = 0.762, shape2 = 1.5) * (1 - .5) + .5)
  })

  # Initialize parameters
  lh <- lh_mean

  fs <- f_rand(with(lh, c(f1, f2, f3, f4)), sd = data$f.logsd)
  lh$f1 <- fs[1]; lh$f2 <- fs[2]; lh$f3 <- fs[3]; lh$f4 <- fs[4];

  ss <- s_rand(with(lh, c(s0, s1, s2, s3)), cv = data$M.cv)
  lh$s0 <- ss$ss[1]; lh$s1 <- ss$ss[2]; lh$s2 <- ss$ss[3]; lh$s3 <- ss$ss[4];

  # Population matrix
  A <- pmx_eval(mx, lh)

  # Initial population structure
  N <- as.vector(stable.stage(A) * N0 )
  #N <- as.vector(A %*% init_pop(A, Na, data$p.rep) )

  # initialize output vectors
  Nvec <- rep(NA, years + 1); Nvec[1] <- sum(N) # * data$p.rep)        # Adult pop vector
  Evec <- rep(NA, years + 1);
  s0s <- NULL       # density dependent parameters
  Ns <- list(N)              # age-specific annual population size
  lambdas <- rep(NA, years)  # population growth rate

  # stochastic parameters
  fts <- list(fs)
  sts <- list(ss$ss)

  #-----------------------------------------------------------------------------
  # loop through years
  for(t in 1:years){

    #---------------------------------------------------------------------------
    # Density Dependence

    # Allee Effects
    if(allee) {

      lh$a.f <- sum(N*data$p.rep) ^ 2 / (data$a ^ 2 + sum(N*data$p.rep) ^ 2)
      if(is.finite(lh$a.f) == F) lh$a.f = 0

    }

    # Survival Density-Dependence
    Et <- E_est(lh, N) # Egg count
    Evec[t] <- Et      # save egg count in vector
    if(density_dependence) {

      #s0.d <- data$s0.max * exp(-data$b * Et)
      s0.d <- data$s0.max / (1 + data$b * Et)
      if(s0.d < 1e-300) s0.d <- 1e-300

      # Mean survival rate
      lh_mean$s0 <- s0.d
    }

    # Demographic Stochasticity
    # simlulates random variation in vital rates when pop size is small.
    # make N random drawns for each age class for vital rates. as N increase the
    # draw will be closer to the mean, samller Ns will be more stochastic
    if(demographic_stoch) {
      # Survival rate
      # Binomial distribution - Sum N drawn and divide by N to give mean Survival
      lh$s0 <- lh_mean$s0
      lh$s1 <- lh$s2 <- lh$s3 <- ifelse(sum(N) > 1 & sum(N) < 500,
                                        sum(rbinom(sum(N), 1, lh_mean$s1))/sum(N),
                                        lh_mean$s1)

      # Fecundity
      # Poison dist. - take mean of N/2 (females) draws to give mean fecundity
      lh$f1 <- lh$f2 <- lh$f3 <- lh$f4 <- ifelse(sum(N*data$p.rep) > 2 & sum(N*data$p.rep) < 500,
                                                 mean(rpois(sum(N*data$p.rep)/2, lh_mean$f2)),
                                                 lh_mean$f2)
    }else {
      lh <- lh_mean
    }

    #---------------------------------------------------------------------------
    # Stochasticity

    # Fecundity
    fs <- f_rand(with(lh, c(f1, f2, f3, f4)), sd = data$f.logsd)
    lh$f1 <- fs[1]; lh$f2 <- fs[2]; lh$f3 <- fs[3]; lh$f4 <- fs[4];

    # Survival
    ss <- s_rand(with(lh, c(s0, s1, s2, s3)), cv = data$M.cv)
    lh$s0 <- ss$ss[1]; lh$s1 <- ss$ss[2]; lh$s2 <- ss$ss[3]; lh$s3 <- ss$ss[4];

    #---------------------------------------------------------------------------
    # Population

    # Projection matrix
    A <- pmx_eval(mx, lh)

    # project the population 1 year ahead.
    if(Catastrophe[t] == 1){
      N <- N * (1 - e.cat[t])
    } else {
      N <- as.vector(A %*% N )
    }

    Nvec[t + 1] <- sum(N)         # Number of mature fish in pop
    s0s <- c(s0s, lh_mean$s0)

    Ns[t + 1] <- list(N)

    lambdas[t] <- Nvec[t + 1]/Nvec[t] # pop growth rate

    fts[t + 1] <- list(fs)
    sts[t + 1] <- list(ss$ss)

  }

  #-----------------------------------------------------------------------------
  # output
  list(pop = as.data.frame(list(year = 0:years,
                                N = Nvec,
                                E = Evec,
                                s0 = c(s0s, NA))),

       N = do.call(rbind, Ns),

       lambdas = lambdas,
       vars = list(
         ft = do.call(rbind, fts),
         st = do.call(rbind, sts)
       ),
       Cat = as.data.frame(list(
         Cat = Catastrophe,
         e.cat = e.cat
       ))

  )
}

#===============================================================================
# Repatriation

repatriation <- function(mx,                # projection matrix expression
                         data,              # life history data
                         lh_mean,           # mean life history data
                         Ninit = 0,         # initial adult population size pop size
                         Nt.vec,            # transfered population as vector of ages 0:tmax
                         s.t,               # survvial rate during translocation
                         t.time,            # when stocking takes place ="pre.spawn" OR "post.spawn"
                         stock.month,       # num. months post spawned stocking takes place
                         stock.max,         # number of stocking events to take place
                         years,             # years to run simulation
                         p.cat              # Probability of castastrophe
){
  #-----------------------------------------------------------------------------

  # needs popbio library
  require(popbio)

  # Castastrophes
  Catastrophe = sample(c(1,0), years, replace = TRUE,
                       prob = c(p.cat / data$gen.time, 1 - p.cat  / data$gen.time))

  # effect on castastrophe on pop size (percent recuction) - scaled Beta dist'n fit from Reed et al. (2003)
  e.cat <- sapply(Catastrophe, function(x) {
    ifelse(x == 0, NA, rbeta(1, shape1 = 0.762, shape2 = 1.5) * (1 - .5) + .5)
  })

  # Initialize parameters
  lh <- lh_mean

  fs <- f_rand(with(lh_mean , c(f1, f2, f3, f4)), sd = data$f.logsd)
  lh$f1 <- fs[1]; lh$f2 <- fs[2]; lh$f3 <- fs[3]; lh$f4 <- fs[4];

  ss <- s_rand(with(lh_mean , c(s0, s1, s2, s3)), cv = data$M.cv)
  lh$s0 <- ss$ss[1]; lh$s1 <- ss$ss[2]; lh$s2 <- ss$ss[3]; lh$s3 <- ss$ss[4];

  # Population matrix
  A <- pmx_eval(mx, lh)

  # Initial population structure
  N <- as.vector(stable.stage(A) * Ninit )

  # initialize output vectors
  Nvec <- rep(NA, years);    #Adult pop vector
  Ns <- list(N)              # age-specific annual population size

  # stock counter
  stock.count <- 0

  #-----------------------------------------------------------------------------
  # loop through years
  for(t in 1:years){

    # stocking pre spawning
    if(t.time == "pre.spawn" & stock.count < stock.max){
      N <- N + Nt.vec * s.t
      stock.count <- stock.count + 1
    }

    #---------------------------------------------------------------------------
    # Density Dependence

    # Allee
    lh$a.f <- sum(N*data$p.rep) ^ 2 / (data$a ^ 2 + sum(N*data$p.rep) ^ 2)
    if(is.finite(lh$a.f) == F) lh$a.f = 0

    # SURVIVAL
    Et <- E_est(lh, N)

    #s0.d <- data$s0.max * exp(-data$b * Et)
    s0.d <- data$s0.max / (1 + data$b * Et)
    if(s0.d < 1e-300) s0.d <- 1e-300

    # Mean survival rate
    lh$s0 <- s0.d

    #---------------------------------------------------------------------------
    # Demographic Stochasticity
    # simlulates random variation in vital rates when pop size is small.
    # make N random drawns for each age class for vital rates. as N increase the
    # draw will be closer to the mean, samller Ns will be more stochastic

    # Survival rate
    # Binomial distribution - Sum N drawn and divide by N to give mean Survival
    lh$s1 <- lh$s2 <- lh$s3 <- ifelse(sum(N) > 1 & sum(N) < 500,
                                      sum(rbinom(sum(N), 1, lh_mean$s1))/sum(N),
                                      lh_mean$s1)

    # Fecundity
    # Poison dist. - take mean of N/2 (females) draws to give mean fecundity
    lh$f1 <- lh$f2 <- lh$f3 <- lh$f4 <- ifelse(sum(N*data$p.rep) > 2 & sum(N*data$p.rep) < 500,
                                               mean(rpois(sum(N*data$p.rep)/2, lh_mean$f2)),
                                               lh_mean$f2)

    #---------------------------------------------------------------------------
    # Stochasticity

    # Fecundity
    fs <- f_rand(with(lh, c(f1, f2, f3, f4)), sd = data$f.logsd)
    lh$f1 <- fs[1]; lh$f2 <- fs[2]; lh$f3 <- fs[3]; lh$f4 <- fs[4];

    # Survival
    ss <- s_rand(means = with(lh, c(s0, s1, s2, s3)), cv = data$M.cv, X = NA)
    lh$s0 <- ss$ss[1]; lh$s1 <- ss$ss[2]; lh$s2 <- ss$ss[3]; lh$s3 <- ss$ss[4];

    #---------------------------------------------------------------------------
    # Population

    # Projection matrix
    A <- pmx_eval(mx, lh)

    # project the population 1 year ahead.
    if(Catastrophe[t] == 1){
      N <- N * (1 - e.cat[t])
    } else {
      N <- as.vector(A %*% N )
    }

    # Stocking - post spawning
    # Stocked fish must survival the year before spawning - included stochasticity
    if(t.time == "post.spawn" & stock.count < stock.max){

      # Demographic stochasticity
      lh.s <- lh
      lh.s$s1 <- lh.s$s2 <- lh.s$s3 <- ifelse(sum(Nt.vec) > 1 & sum(Nt.vec) < 500,
                                        sum(rbinom(sum(Nt.vec), 1, lh_mean$s1))/sum(Nt.vec),
                                        lh_mean$s1)

      # Environmental stochasticity - same residuals as in matrix (X = ss$X)
      ss <- s_rand(with(lh.s, c(s0, s1, s2, s3)), cv = data$M.cv, X = ss$X)
      lh.s$s0 <- ss$ss[1]; lh.s$s1 <- ss$ss[2]; lh.s$s2 <- ss$ss[3]; lh.s$s3 <- ss$ss[4];

      # add stocked fish to pop vector - include mortality scaled to time remaiing in year
      N <- N + Nt.vec * s.t * with(lh.s, c(s1, s2, s3, 0)) ^ ((12 - stock.month)/12)

      # increment stocking counter
      stock.count <- stock.count + 1
    }

    # outputs
    Nvec[t] <- sum(N)         # Number of mature fish in pop

    Ns[t] <- list(N)          # Pop vector for output

  }
  #-----------------------------------------------------------------------------
  # output
  list(pop = as.data.frame(list(year = 1:years,
                                N = Nvec)),

       N = do.call(rbind, Ns)
  )
}

#===============================================================================
# Source Population Harm

# Function to project population size including density dependence effects
source_harm <- function(mx,          # projection matrix expression
                        data,        # life history data
                        lh_mean,     # mean life history data
                        Ninit ,      # initial adult population size pop size
                        Nt.vec,      # transfered population as vector of ages 0:tmax
                        t.time,      # when stocking takes place ="pre.spawn" OR "post.spawn"
                        stock.max,   # number of stocking events to take place
                        years,       # years to run simulation
                        p.cat        # Probability of castastrophe "Length" and or "Survival"
){
  #-----------------------------------------------------------------------------

  # needs popbio library
  require(popbio)

  # Castastrophes
  Catastrophe = sample(c(1,0), years, replace = TRUE,
                       prob = c(p.cat / data$gen.time, 1 - p.cat  / data$gen.time))

  # effect on castastrophe on pop size (percent recuction) - scaled Beta dist'n fit from Reed et al. (2003)
  e.cat <- sapply(Catastrophe, function(x) {
    ifelse(x == 0, NA, rbeta(1, shape1 = 0.762, shape2 = 1.5) * (1 - .5) + .5)
  })

  # Initialize parameters
  lh <- lh_mean

  fs <- f_rand(with(lh_mean , c(f1, f2, f3, f4)), sd = data$f.logsd)
  lh$f1 <- fs[1]; lh$f2 <- fs[2]; lh$f3 <- fs[3]; lh$f4 <- fs[4];

  ss <- s_rand(with(lh_mean , c(s0, s1, s2, s3)), cv = data$M.cv)
  lh$s0 <- ss$ss[1]; lh$s1 <- ss$ss[2]; lh$s2 <- ss$ss[3]; lh$s3 <- ss$ss[4];

  # Population matrix
  A <- pmx_eval(mx, lh)

  # Initial population structure
  N <- as.vector(stable.stage(A) * Ninit)

  # initialize output vectors
  Nvec <- rep(NA, years + 1); Nvec[1] <- sum(N)# * data$p.rep)        # Adult pop vector
  Ns <- list(N)              # age-specific annual population size

  # stock counter
  stock.count <- 0

  #-----------------------------------------------------------------------------
  # loop through years
  for(t in 1:years){

    # stocking pre spawning
    if(t.time == "pre.spawn" & stock.count < stock.max){
      N <- N - Nt.vec
      N <- ifelse(N > 1, N, 0)
      stock.count <- stock.count + 1
    }

    #---------------------------------------------------------------------------
    # Density Dependence

    # Allee Effects
    lh$a.f <- sum(N*data$p.rep) ^ 2 / (data$a ^ 2 + sum(N*data$p.rep) ^ 2)
    if(is.finite(lh$a.f) == F) lh$a.f = 0

    # Survival Density-Dependence
    Et <- E_est(lh, N) # Egg count
    s0.d <- data$s0.max / (1 + data$b * Et)
    if(s0.d < 1e-300) s0.d <- 1e-300

    # Mean survival rate
    lh_mean$s0 <- s0.d

    # Demographic Stochasticity
    # simlulates random variation in vital rates when pop size is small.
    # make N random drawns for each age class for vital rates. as N increase the
    # draw will be closer to the mean, samller Ns will be more stochastic

    # Survival rate
    # Binomial distribution - Sum N drawn and divide by N to give mean Survival
    lh$s0 <- lh_mean$s0
    lh$s1 <- lh$s2 <- lh$s3 <- ifelse(sum(N) > 1 & sum(N) < 500,
                                      sum(rbinom(sum(N), 1, lh_mean$s1))/sum(N),
                                      lh_mean$s1)

    # Fecundity
    # Poison dist. - take mean of N/2 (females) draws to give mean fecundity
    lh$f1 <- lh$f2 <- lh$f3 <- lh$f4 <- ifelse(sum(N*data$p.rep) > 2 & sum(N*data$p.rep) < 500,
                                               mean(rpois(sum(N*data$p.rep)/2, lh_mean$f2)),
                                               lh_mean$f2)

    #---------------------------------------------------------------------------
    # Stochasticity

    # Fecundity
    fs <- f_rand(with(lh_mean , c(f1, f2, f3, f4)), sd = data$f.logsd)
    lh$f1 <- fs[1]; lh$f2 <- fs[2]; lh$f3 <- fs[3]; lh$f4 <- fs[4];

    # Survival
    ss <- s_rand(with(lh_mean , c(s0, s1, s2, s3)), cv = data$M.cv)
    lh$s0 <- ss$ss[1]; lh$s1 <- ss$ss[2]; lh$s2 <- ss$ss[3]; lh$s3 <- ss$ss[4];

    #---------------------------------------------------------------------------
    # Population

    # Projection matrix
    A <- pmx_eval(mx, lh)

    # project the population 1 year ahead.
    if(Catastrophe[t] == 1){
      N <- N * (1 - e.cat[t])
    } else {
      N <- as.vector(A %*% N )
    }
    N <- ifelse(N > 1, N, 0)

    #output
    Nvec[t + 1] <- sum(N) # Number of age-1+ fish in pop
    Ns[t + 1] <- list(N)  # pop vector

    # Stocking - post spawning
    if(t.time == "post.spawn" & stock.count < stock.max){
      N <- N - Nt.vec
      N <- ifelse(N > 1, N, 0)
      stock.count <- stock.count + 1
    }

  }

  #-----------------------------------------------------------------------------
  # output
  list(pop = as.data.frame(list(year = 0:years,
                                N = Nvec
                                )),

       N = do.call(rbind, Ns)
  )
}

#===============================================================================


rm(list=ls())
library(dplyr)
library(ggplot2)
library(tidyr)
library(ggpubr)

# set dataset

dataset <- "Streicher"

setwd(paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset, sep=''))

# Read in data
load(paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset,"/Calcs_",dataset,".RData", sep=''))

# Colors
color_S <- "orange"
color_TP <- "springgreen4"
color_AI <- "#2BB07FFF"
color_SA <- "#38598CFF"
color_SI <- "yellow4"

# Add column to name type of support
mLGL <- mutate(mLGL, supportType = case_when(TvS != 'a' ~ "dGLS"))
mLBF <- mutate(mLBF, supportType = case_when(TvS != 'a' ~ "BF"))

# Want to stack datasets

reformatdf <- function(df,h,h1,s1,keepCols){
  # keepCols is a vector of the locus and support type column indices
  # Grab column number
  c1 <- match(h1,names(df))
  # Grab and rename column, add hypothesis column
  a.df <- df[,append(keepCols,c1)]
  names(a.df)[names(a.df) == h1] <- h
  a.df$Hypothesis <- rep(h1,length(a.df[,1]))
  c <- match(h,names(a.df))
  # Adjust direction of support if needed. ie if column is AIvSA, but you want to know SAvAI
  a.df[,c] <- a.df[,c]*(s1)
  return(a.df)
}

# reformat
AI.g <- bind_rows(reformatdf(mLGL,"AI","AIvSA",1,c(1,14)),
                  reformatdf(mLGL,"AI","AIvSI",1,c(1,14)))

SA.g <- bind_rows(reformatdf(mLGL,"SA","AIvSA",-1,c(1,14)),
                  reformatdf(mLGL,"SA","SAvSI",1,c(1,14)))

SI.g <- bind_rows(reformatdf(mLGL,"SI","AIvSI",-1,c(1,14)),
                  reformatdf(mLGL,"SI","SAvSI",-1,c(1,14)))

AI.b <- bind_rows(reformatdf(mLBF,"AI","AIvSA",1,c(1,14)),
                  reformatdf(mLBF,"AI","AIvSI",1,c(1,14)))

SA.b <- bind_rows(reformatdf(mLBF,"SA","AIvSA",-1,c(1,14)),
                  reformatdf(mLBF,"SA","SAvSI",1,c(1,14)))

SI.b <- bind_rows(reformatdf(mLBF,"SI","AIvSI",-1,c(1,14)),
                  reformatdf(mLBF,"SI","SAvSI",-1,c(1,14)))

#------------------------------------------------------------------------------------------------------------------------------------------------------

# Histogram -----------------------------------------Histogram---------------------------------------------------------------------------------------------------

#------------------------------------------------------------------------------------------------------------------------------------------------------

H <- function(df.g,xval.g,xlablab.g,xtic.g,lines.g,limit.g,bin.g,cc.g,title.g,ytic.g){
  GL_hist <- ggplot(data=df.g, aes(x=xval.g)) +
    #geom_histogram(binwidth = limit.g*0.001, alpha=1, position="dodge", color=cc.g, fill=cc.g)+
    geom_histogram(binwidth = bin.g, alpha=1, position="dodge", color=cc.g, fill=cc.g)+
    theme_classic() +
    theme(plot.title = element_text(hjust = 0.5, size=16),
          axis.text = element_text(size=10, color="black"),
          text = element_text(size=14),
          legend.title = element_text(size = 12),
          legend.text = element_text(size = 10)) +
    labs(y="Number of Loci",x=xlablab.g)  +
    ggtitle(title.g) +
    coord_cartesian(ylim=ytic.g, xlim = xtic.g) +
    scale_x_continuous(breaks = c(0,xtic.g)) +
    scale_y_continuous(breaks = ytic.g) +
    geom_vline(xintercept=lines.g,color=c("black"), linetype="dashed", size=0.5)
    #geom_vline(xintercept=c(0),color=c("black"), linetype="dashed", size=0.2)
  return(GL_hist)
}

# These will stay the same across all graphs

# x lable and where lines are
xlablab.1 <- "dGLS value"
lines.1 <- c(-0.5,0.5)

# Set max X value, and max Y value
max(c(abs(AI.g$AI),abs(SA.g$SA),abs(SI.g$SI)))
limit.1 <- 45
xtic.1 <- c(seq(-limit.1,limit.1,5))
maxloci.1 <- 100
ytic.1 <- seq(0,maxloci.1,10)
bin.1 <- 0.05 # 0.5/10 = 0.05

quartz()
AI.gg <- H(AI.g,AI.g$AI,xlablab.1,xtic.1,lines.1,limit.1,bin.1,color_AI,"AI",ytic.1)
AI.gg
SA.gg <- H(SA.g,SA.g$SA,xlablab.1,xtic.1,lines.1,limit.1,bin.1,color_SA,"SA",ytic.1)
SI.gg <- H(SI.g,SI.g$SI,xlablab.1,xtic.1,lines.1,limit.1,bin.1,color_SI,"SI",ytic.1)

GL <- ggarrange(AI.gg, SA.gg, SI.gg, ncol=1, nrow=3, align="v")
GL

#ggsave(paste(dataset,"_histo_tox_gl.pdf",sep=""), plot=GL,width = 9, height = 9, units = "in", device = 'pdf',bg = "transparent")

# These will stay the same across all graphs

# x lable and where lines are
xlablab.2 <- "2ln(BF) value"
lines.2 <- c(-10,10)

# Set max X value, and max Y value
max(c(abs(AI.b$AI),abs(SA.b$SA),abs(SI.b$SI)))
limit.2 <- 115
xtic.2 <- c(seq(-limit.2,limit.2,10))
maxloci.2 <- 500
ytic.2 <- seq(0,maxloci.2,100)
bin.2 <- 1 # 10/10 = 1

#quartz()
AI.bg <- H(AI.b,AI.b$AI,xlablab.2,xtic.2,lines.2,limit.2,bin.2,color_AI,"AI",ytic.2)
SA.bg <- H(SA.b,SA.b$SA,xlablab.2,xtic.2,lines.2,limit.2,bin.2,color_SA,"SA",ytic.2)
SI.bg <- H(SI.b,SI.b$SI,xlablab.2,xtic.2,lines.2,limit.2,bin.2,color_SI,"SI",ytic.2)

BF <- ggarrange(AI.bg, SA.bg, SI.bg, ncol=1, nrow=3, align="v")
BF

# ggsave(paste(dataset,"_histo_tox_bf.pdf",sep=""), plot=BF,width = 7, height = 9, units = "in", device = 'pdf',bg = "transparent")

#------------------------------------------------------------------------------------------------------------------------------------------------------

# Violin ---------------------------------------------- Violin --------------------------------------------------------------------------------------------------------

#------------------------------------------------------------------------------------------------------------------------------------------------------

V <- function(df.g,xval.g,yval.g,ylablab.g,ytic.g,hline.g,cc.g,title.g){
  GL_violin <- ggplot(df.g, aes(x=xval.g, y=yval.g, fill=xval.g)) +
    geom_violin(trim=TRUE) +
    geom_point(shape = 18,size=0.5, position = position_jitterdodge(), color='black',alpha=1)+
    scale_color_manual(values=cc.g) + scale_fill_manual(values=cc.g) +
    theme_classic() +
    theme(plot.title = element_text(hjust = 0.5, size=16),
          axis.text = element_text(size=10, color="black"),
          text = element_text(size=14),
          legend.position = "none") +
    labs(y=ylablab.g,x="")  +
    ggtitle(title.g) +
    coord_cartesian(ylim=ytic.g) +
    scale_y_continuous(breaks = ytic.g) +
    geom_hline(yintercept=hline.g,color=c("black"), linetype="dashed", size=0.5)
  return(GL_violin)
}

# These will stay the same across all graphs

# x lable and where lines are
ylablab.1 <- "dGLS value"
lines.1 <- c(-0.5,0.5)

# Set max X value, and max Y value
max(c(abs(AI.g$AI),abs(SA.g$SA),abs(SI.g$SI)))
limit.1 <- 10
ytic.1 <- c(seq(-limit.1,limit.1,1))

#quartz()
AI.gg <- V(AI.g,AI.g$supportType,AI.g$AI,ylablab.1,ytic.1,lines.1,color_AI,"AI")
SA.gg <- V(SA.g,SA.g$supportType,SA.g$SA,ylablab.1,ytic.1,lines.1,color_SA,"SA")
SI.gg <- V(SI.g,SI.g$supportType,SI.g$SI,ylablab.1,ytic.1,lines.1,color_SI,"SI")
GL <- ggarrange(AI.gg, SA.gg, SI.gg, ncol=3, nrow=1, align="h")
GL

#ggsave(paste(dataset,"_violin_scaled_tox_gl.pdf",sep=""), plot=GL,width = 9, height = 7, units = "in", device = 'pdf',bg = "transparent")

# These will stay the same across all graphs

# x lable and where lines are
ylablab.2 <- "2ln(BF) value"
lines.2 <- c(-10,10)

# Set max X value, and max Y value
max(c(abs(AI.g$AI),abs(SA.g$SA),abs(SI.g$SI)))
limit.2 <- 40
ytic.2 <- c(seq(-limit.2,limit.2,5))

#quartz()
AI.bg <- V(AI.b,AI.b$supportType,AI.b$AI,ylablab.2,ytic.2,lines.2,color_AI,"AI")
SA.bg <- V(SA.b,SA.b$supportType,SA.b$SA,ylablab.2,ytic.2,lines.2,color_SA,"SA")
SI.bg <- V(SI.b,SI.b$supportType,SI.b$SI,ylablab.2,ytic.2,lines.2,color_SI,"SI")
BF <- ggarrange(AI.bg, SA.bg, SI.bg, ncol=3, nrow=1, align="h")
BF

#ggsave(paste(dataset,"_violin_zoom_tox_bf.pdf",sep=""), plot=BF,width = 9, height = 7, units = "in", device = 'pdf',bg = "transparent")

#------------------------------------------------------------------------------------------------------------------------------------------------------

# BoxPlot ---------------------------------------------- BoxPlot --------------------------------------------------------------------------------------------------------

#------------------------------------------------------------------------------------------------------------------------------------------------------
quartz()
#FAIL
max(c(abs(AI.g$AI),abs(SA.g$SA),abs(SI.g$SI)))
limit.2 <- 20
ytic.2 <- c(seq(-limit.2,limit.2,1))
p <- ggplot(AI.b, aes(x=Hypothesis, y=AI)) +
  geom_boxplot() + coord_cartesian(ylim=ytic.2) +
  scale_y_continuous(breaks = ytic.2)
p

limit.2 <- 2
ytic.2 <- c(seq(-limit.2,limit.2,0.1))
q <- ggplot(AI.g, aes(x=Hypothesis, y=AI)) +
  geom_boxplot() + coord_cartesian(ylim=ytic.2) +
  scale_y_continuous(breaks = ytic.2)
quartz()
q

#------------------------------------------------------------------------------------------------------------------------------------------------------

# Deciles ---------------------------------------------- Deciles --------------------------------------------------------------------------------------------------------

#------------------------------------------------------------------------------------------------------------------------------------------------------

# Set title and input data
df.g <- AI.g
xval.g <- AI.g$AI
xlablab.g <- paste("dGLS - AI - ",dataset,sep="")

df.g <- SA.g
xval.g <- SA.g$SA
xlablab.g <- paste("dGLS - SA - ",dataset,sep="")
#quartz()

df.g <- SI.g
xval.g <- SI.g$SI
xlablab.g <- paste("dGLS - SI - ",dataset,sep="")
#quartz()

########### BFFFF

df.g <- AI.b
xval.g <- AI.b$AI
xlablab.g <- paste("2ln(BF) - AI - ",dataset,sep="")

df.g <- SA.b
xval.g <- SA.b$SA
xlablab.g <- paste("2ln(BF) - SA - ",dataset,sep="")
#quartz()

df.g <- SI.b
xval.g <- SI.b$SI
xlablab.g <- paste("2ln(BF) - SI - ",dataset,sep="")
#quartz()

datSum.g <- ddply(df.g,.(supportType),summarise,
                  qa = quantile(xval.g,0.01),
                  qb = quantile(xval.g,0.05),
                  q1 = quantile(xval.g,0.1),
                  q2 = quantile(xval.g,0.2),
                  q3 = quantile(xval.g,0.3),
                  q4 = quantile(xval.g,0.4),
                  q5a = quantile(xval.g,0.49),
                  q5 = quantile(xval.g,0.5),
                  q5b = quantile(xval.g,0.51),
                  q6 = quantile(xval.g,0.6),
                  q7 = quantile(xval.g,0.7),
                  q8 = quantile(xval.g,0.8),
                  q9 = quantile(xval.g,0.9),
                  qy = quantile(xval.g,0.95),
                  qz = quantile(xval.g,0.99))
datSum.g$NameAlt <- 1:1
datSum.g
tics.g <- seq(-1,1,0.1) # Streicher
tics.g <- seq(-6,6,0.5) # Streicher
tics.g <- seq(-17,17,1) # Streicher

GL3 <- ggplot(datSum.g,aes(ymin = NameAlt - 0.2,ymax = NameAlt + 0.2)) +
  geom_rect(aes(xmin = qa,xmax = qz),fill = "white",colour = "black") +
  geom_rect(aes(xmin = qb,xmax = qy),fill = "lightblue",colour = "black") +
  geom_rect(aes(xmin = q1,xmax = q9),fill = "dodgerblue",colour = "black") +
  geom_rect(aes(xmin = q2,xmax = q8),fill = "blue",colour = "black") +
  geom_rect(aes(xmin = q3,xmax = q7),fill = 'midnightblue',colour = "black") +
  #geom_rect(aes(xmin = q5,xmax = q5),fill = 'midnightblue',colour = "black") +
  theme_classic() +
  theme(axis.line.y=element_blank(),
        axis.ticks.y=element_blank(),
        axis.text.y=element_blank(),
        plot.title = element_text(hjust = 0.5, size=16),
        axis.text = element_text(size=10, color="black"),
        text = element_text(size=14)) +
  labs(x=xlablab.g,y="") +
  coord_cartesian(xlim=tics.g) +
  scale_x_continuous(breaks = tics.g)
#quartz()
GL3

G <- ggarrange(GL1, GL2, GL3, ncol=1, nrow=3, align="v")
#quartz()
G

ggsave(paste(dataset,"_decile_tox_bf.pdf",sep=""), plot=BF,width = 9, height = 7, units = "in", device = 'pdf',bg = "transparent")

# https://stackoverflow.com/questions/46628958/making-a-specific-quantile-plot-in-r
# cool graph but my data is too concentrated in the middle