# plotting half-deep intervals and depth along an assembly

read_scaffold_lengths <- function(lengthsFilename,scaffoldsOfInterest=NULL)
	#
	# Read a file containing scaffold names and lengths. Result is either
	# (a) reduced to scaffolds of interest, in order or (b) sorted by
	# decreasing length. A column is added, giving offsets for which the
	# scaffolds can be arranged along a number line.
	#
	# typical input:
	#	scaffold_100_arrow_ctg1 29829
	#	scaffold_101_arrow_ctg1 29808
	#	scaffold_102_arrow_ctg1 28782
	#	scaffold_103_arrow_ctg1 27584
	#	scaffold_104_arrow_ctg1 27050
	#    ...
	#
	# returns, e.g.
	#	                 name    length    offset
	#	     super_scaffold_1 215872496         0
	#	     super_scaffold_2 165051286 215872496
	#	scaffold_2_arrow_ctg1 125510139 380923782
	#	     super_scaffold_Z  84526827 506433921
	#	scaffold_5_arrow_ctg1  82438829 590960748
	#    ...
	#
	{
	scaffolds = read.table(lengthsFilename,header=F,colClasses=c("character","integer"))
	colnames(scaffolds) <- c("name","length")

	if (!is.null(scaffoldsOfInterest))
		{
		# pick ordered subset
		scaffolds = scaffolds[scaffolds$name %in% scaffoldsOfInterest,]
		scaffoldsToNumber = 1:length(scaffoldsOfInterest)
		names(scaffoldsToNumber) = scaffoldsOfInterest
		scaffolds = scaffolds[order(scaffoldsToNumber[scaffolds$name]),]
		}
	else
		{
		# sort by decreasing length
		scaffolds = scaffolds[order(-scaffolds$length),]
		}

	scaffolds[,"offset"] = rev(sum(as.numeric(scaffolds$length))-cumsum(rev(as.numeric(scaffolds$length))))

	scaffolds;
	}

linearized_scaffolds <- function(scaffolds)
	#
	# Create scaffold-to-number-line mapping; input is of the form returned by
	# read_scaffold_lengths().
	#
	{
	scaffoldToOffset <- scaffolds$offset
	names(scaffoldToOffset) <- scaffolds$name

	scaffoldToOffset
	}

read_depth <- function(depthFilename,scaffoldToOffset=NULL)
	#
	# Read a file containing coverage depth. Typically the depth has been
	# averaged over non-overlapping windows, with each window represented by
	# a single location. Genomic locations are origin-1, and intervals are
	# closed.
	#
	# A scaffold-to-offset can be provided, as would be produced by
	# linearized_scaffolds(). Two columns are added, converting each interval
	# to positions along a number line.
	#
	# typical input:
	#	scaffold_100_arrow_ctg1 1    1    16.727
	#	scaffold_100_arrow_ctg1 1001 1001 19.365
	#	scaffold_100_arrow_ctg1 2001 2001 20.701
	#	scaffold_100_arrow_ctg1 3001 3001 22.764
	#	scaffold_100_arrow_ctg1 4001 4001 20.971
	#    ...
	#
	# returns, e.g.
	#	               scaffold start  end  depth          s          e
	#	scaffold_100_arrow_ctg1     1    1 16.727 1177990031 1177990031
	#	scaffold_100_arrow_ctg1  1001 1001 19.365 1177991031 1177991031
	#	scaffold_100_arrow_ctg1  2001 2001 20.701 1177992031 1177992031
	#	scaffold_100_arrow_ctg1  3001 3001 22.764 1177993031 1177993031
	#	scaffold_100_arrow_ctg1  4001 4001 20.971 1177994031 1177994031
	#    ...
	#
	{
	depth = read.table(depthFilename,header=F,colClasses=c("character","integer","integer","numeric"))
	colnames(depth) <- c("scaffold","start","end","depth")

	if (!is.null(scaffoldToOffset))
		{
		depth = depth[depth$scaffold %in% names(scaffoldToOffset),]
		depth[,"s"] = scaffoldToOffset[depth$scaffold] + depth$start
		depth[,"e"] = scaffoldToOffset[depth$scaffold] + depth$end
		}

	depth
	}

read_halfdeep <- function(halfDeepFilename,scaffoldToOffset=NULL)
	#
	# Read a file containing a list of genomic intervals. The intervals are
	# origin-1 and closed.
	#
	# A scaffold-to-offset can be provided, as would be produced by
	# linearized_scaffolds(). Two columns are added, converting each interval
	# to positions along a number line.
	#
	# typical input:
	#	scaffold_100_arrow_ctg1 9001  10000
	#	scaffold_101_arrow_ctg1 12001 14000
	#	scaffold_103_arrow_ctg1 2001  14000
	#	scaffold_106_arrow_ctg1 1     3000
	#	scaffold_106_arrow_ctg1 19001 20000
	#    ...
	#
	# returns, e.g.
	#	               scaffold start   end          s          e
	#	scaffold_100_arrow_ctg1  9001 10000 1177999031 1178000030
	#	scaffold_101_arrow_ctg1 12001 14000 1178031860 1178033859
	#	scaffold_103_arrow_ctg1  2001 14000 1178110244 1178122243
	#	scaffold_106_arrow_ctg1     1  3000 1178189381 1178192380
	#	scaffold_106_arrow_ctg1 19001 20000 1178208381 1178209380
	#    ...
	#
	{
	halfDeep = read.table(halfDeepFilename,header=F,colClasses=c("character","integer","integer"))
	colnames(halfDeep) <- c("scaffold","start","end")
	if (!is.null(scaffoldToOffset))
		{
		halfDeep = halfDeep[halfDeep$scaffold %in% names(scaffoldToOffset),]
		halfDeep[,"s"] = scaffoldToOffset[halfDeep$scaffold] + halfDeep$start
		halfDeep[,"e"] = scaffoldToOffset[halfDeep$scaffold] + halfDeep$end
		}

	halfDeep
	}

read_percentiles <- function(percentilesFilename)
	#
	# Extract percentile values from a shell script.
	#
	# typical input:
	#	export percentile40=52.698
	#	export percentile50=54.818
	#	export percentile60=56.938
	#	export halfPercentile40=26.349
	#	export halfPercentile50=27.409
	#	export halfPercentile60=28.469
	#
	# returns, e.g.
	#	    percentile40     percentile50     percentile60
	#	          52.698           54.818           56.938
	#	 halfPercentile40 halfPercentile50 halfPercentile60
	#	           26.349           27.409           28.469
	#
	{
	percentilesCommand = paste("cat",percentilesFilename,'| sed "s/^export //" | tr "=" " "')
	percentiles = read.table(pipe(percentilesCommand),header=F,colClasses=c("character","numeric"))
	colnames(percentiles) <- c("name","value")
	percentileToValue <- percentiles$value
	names(percentileToValue) <- percentiles$name

	percentileToValue
	}

halfdeep_plot <- function(scaffolds,depth,halfDeep,percentileToValue,
                          assemblyName="",
                          scaffoldsToPlot=NULL,
                          plotFilename=NULL,
                          tickSpacing=10000000,
                          width=17,height=7,pointsize=18,
                          yLabelSpace=7,
                          maxDepth=NA,
                          scaffoldInterval=NULL)
	#
	# Plot half-deep intervals and depth along an assembly
	#
	# scaffolds:              As returned by read_scaffold_lengths().
	# depth:                  As returned by read_depth().
	# halfDeep:               As returned by read_halfdeep(). If this is NULL,
	#                         no half-deep information is displayed.
	# percentileToValue:      As returned by read_percentiles()
	# assemblyName:           Name of the assembly. This contributes to the
	#                         plain title, and can contribute to the plot
	#                         file name.
	#                         Example: "bAlcTor1.pri.cur.20190613"
	# scaffoldsToPlot=NULL:   A vector of scaffolds to restrict the plot to.
	#                         By default, everything in scaffolds[] is
	#                         plotted.
	# plotFilename=NULL:      File to plot the data to. If this is NULL, the
	#                         data is plotted on the screen.
	# tickSpacing:            Spacing of evenly-spaced ticks along the
	#                         horizontal axis. If this is zero, these ticks
	#                         are inhibited. The default is 10Mbp.
	# width,height,pointsize: These are passed through to whatever function
	#                         creates the plot window.
	# yLabelSpace:            Space below the plot. This can be increased to
	#                         accommodate longer scaffold names.
	# maxDepth:               Depth greater than this is not shown in the plot;
	#                         i.e. the vertical axis stops at this value. By
	#                         default this is 1.5*median depth.
	# scaffoldInterval        subinterval to restrict the plot to. Typically
	#                         this would only be used when only one scaffold
	#                         is to be plotted. This is a (start,end) pair,
	#                         origin-zero, half-open.
	#
	{
	# if we have a scaffold subset, reduce our copy of the data to that subset

	if (!is.null(scaffoldInterval))
		stop("scaffoldInterval is not implemented yet")

	showHalfDeep = !is.null(halfDeep)

	if (!is.null(scaffoldsToPlot))
		{
		# validate the names in the subset

		badNames = scaffoldsToPlot[!(scaffoldsToPlot %in% scaffolds$name)]
		if (length(badNames) > 0)
			stop(paste("bad scaffold name(s):",paste(scaffoldsToPlot,collapse=", ")))

		# pick ordered subset
		scaffolds = scaffolds[scaffolds$name %in% scaffoldsToPlot,]
		scaffoldsToNumber = 1:length(scaffoldsToPlot)
		names(scaffoldsToNumber) = scaffoldsToPlot
		scaffolds = scaffolds[order(scaffoldsToNumber[scaffolds$name]),]
		scaffolds[,"offset"] = rev(sum(as.numeric(scaffolds$length))-cumsum(rev(as.numeric(scaffolds$length))))
		scaffoldToOffset = linearized_scaffolds(scaffolds)

		# reduce to ordered subset
		depth = depth[depth$scaffold %in% names(scaffoldToOffset),]
		depth[,"s"] = scaffoldToOffset[depth$scaffold] + depth$start
		depth[,"e"] = scaffoldToOffset[depth$scaffold] + depth$end

		if (showHalfDeep)
			{
			halfDeep = halfDeep[halfDeep$scaffold %in% names(scaffoldToOffset),]
			halfDeep[,"s"] = scaffoldToOffset[halfDeep$scaffold] + halfDeep$start
			halfDeep[,"e"] = scaffoldToOffset[halfDeep$scaffold] + halfDeep$end
			}
		}

	# fetch percentile values (used only for drawing and labeling)

	depth50        = percentileToValue["percentile50"]
	halfDepthLo    = percentileToValue["halfPercentile40"]
	halfDepthHi    = percentileToValue["halfPercentile60"]
	depthClip      = ifelse(is.na(maxDepth),1.5*depth50,maxDepth)
	depth50Str     = sprintf("%.1f",depth50)
	halfDepthLoStr = sprintf("%.1f",halfDepthLo)
	halfDepthHiStr = sprintf("%.1f",halfDepthHi)
	depthClipStr   = sprintf("%.1f",depthClip)

	# (housekeeping)

	scaffoldTicks = 1 + c(scaffolds$offset,sum(as.numeric(scaffolds$length)))
	scaffoldCenters = (as.numeric(scaffoldTicks[1:nrow(scaffolds)])+as.numeric(scaffoldTicks[2:(nrow(scaffolds)+1)])) / 2
	if (showHalfDeep)
		halfDeepCenters = (as.numeric(halfDeep$s)+as.numeric(halfDeep$e))/2

	xlim = c(1,max(scaffoldTicks))
	ylim = c(0,depthClip)

	depthColor          = if (showHalfDeep) rgb(.6,.6,.6) else "black"
	halfDepthColor      = "black"
	halfDeepMarkerColor = "red"
	depthLimitsColor    = "blue"

	guns = col2rgb(halfDeepMarkerColor) / 255
	halfDeepOverlayColor = rgb(guns[1],guns[2],guns[3],alpha=.3)

	# open plot window or file

	turnDeviceOff = F
	if (is.null(plotFilename))
		{
		quartz(width=width,height=height)
		}
	else
		{
		print(paste("drawing to",plotFilename))
		pdf(file=plotFilename,width=width,height=height,pointsize=pointsize)
		turnDeviceOff = T
		}

	# create empty plot

	if (showHalfDeep)
		{
		title = paste("half-deep intervals (red overlay) in ",assemblyName,
		              "\nmedian=",depth50Str,
		              "   40%ile/2=",halfDepthLoStr,
		              "   60%ile/2=",halfDepthHiStr,
		              sep="")
		ylab  = paste("aligned read depth in 1Kbp windows (gray, clipped at ",depthClipStr,")",sep="")
		}
	else
		{
		title = paste("coverage depth in ",assemblyName,"\nmedian=",depth50Str,sep="")
		ylab  = paste("aligned read depth in 1Kbp windows (clipped at ",depthClipStr,")",sep="")
		}

	par(mar=c(yLabelSpace,4,2.5,0.2)+0.1)     # BLTR
	options(scipen=10)
	plot(NA,xlim=xlim,ylim=ylim,main=title,xaxt="n",xlab="",ylab=ylab)

	# add horizontal axis

	if ((showHalfDeep) && (nrow(halfDeep) > 0))
		{
		axis(1,at=halfDeepCenters,labels=F,line=-0.5,col=halfDeepMarkerColor)                        # interval markers
		axis(1,at=c(-0.2*max(scaffoldTicks),1.2*max(scaffoldTicks)),labels=F,line=-0.5,col="white")  # erase unwanted horizonal 'axis'
		}

	if ((tickSpacing > 0) & (xlim[2]>=tickSpacing))          # equal-spaced ticks
		axis(1,at=seq(tickSpacing,xlim[2],by=tickSpacing),labels=F,col="gray")
	axis(1,at=scaffoldTicks,labels=F,tck=-0.04)              # scaffold ticks
	axis(1,at=scaffoldCenters,tick=F,labels=scaffolds$name,  # scaffold labels
		 las=2,cex.axis=0.7)

	# draw depth as gray, and depth in half-deep intervals as black

	points(depth$s,depth$depth,col=depthColor,pch=19,cex=0.3)

	if (showHalfDeep)
		{
		halfsies = (depth$depth>=halfDepthLo) & (depth$depth<=halfDepthHi)
		points(depth$s[halfsies],depth$depth[halfsies],col=halfDepthColor,pch=19,cex=0.1)
		}

	# draw half-deep intervals as red overlay rectangles; note that R often
	# does a poor job at filling narrow rectangles, so we also draw each
	# rectangle as a centered line; and, because the depth plot will overshoot
	# the upper limit, we multiply that limit by 1.2 here

	if ((showHalfDeep) && (nrow(halfDeep) > 0))
		{
		rect(halfDeep$s,ylim[1],halfDeep$e,ylim[2]*1.2,border=NA,col=halfDeepOverlayColor)  # LBRT

		halfDeepCentersX = matrix(nrow=3,ncol=length(halfDeepCenters))
		halfDeepCentersX[1,] = halfDeepCenters
		halfDeepCentersX[2,] = halfDeepCenters
		halfDeepCentersX[3,] = NA
		dim(halfDeepCentersX) = NULL
		halfDeepCentersY = matrix(nrow=3,ncol=length(halfDeepCenters))
		halfDeepCentersY[1,] = ylim[1]
		halfDeepCentersY[2,] = ylim[2]*1.2
		halfDeepCentersY[3,] = NA
		dim(halfDeepCentersY) = NULL
		lines(halfDeepCentersX,halfDeepCentersY,col=halfDeepOverlayColor)
		}

	# add horizontal lines to show median and half-deep limits

	lines(xlim,c(depth50,depth50),col=depthLimitsColor,lwd=2,lty=2)
	if (showHalfDeep)
		{
		lines(xlim,c(halfDepthHi,halfDepthHi),col=depthLimitsColor,lwd=2,lty=2)
		lines(xlim,c(halfDepthLo,halfDepthLo),col=depthLimitsColor,lwd=2,lty=2)
		}

	text(0,depth50,"median ",adj=1,cex=0.7,col=depthLimitsColor)
	if (showHalfDeep)
		{
		text(0,halfDepthLo,"half-40th ",adj=1,cex=0.7,col=depthLimitsColor)
		text(0,halfDepthHi,"half-60th ",adj=1,cex=0.7,col=depthLimitsColor)
		}

	# close the plot

	if (turnDeviceOff) dev.off()
	}

halfdeep_read_and_plot <- function(lengthsFilename,depthFilename,halfDeepFilename,
                                   percentilesFilename,
                                   plotFilenameTemplate=NULL,
                                   tickSpacing=10000000,
                                   width=17,height=7,pointsize=18,
                                   yLabelSpace=7)
	#
	# Plot half-deep intervals and depth, for several assemblies
	#
	{
	scaffolds = read_scaffold_lengths(lengthsFilename)
	scaffoldToOffset = linearized_scaffolds(scaffolds)
	depth = read_depth(depthFilename,scaffoldToOffset)
	halfDeep = read_halfdeep(halfDeepFilename,scaffoldToOffset)
	percentileToValue = read_percentiles(percentilesFilename)

	halfdeep_plot(scaffolds,depth,halfDeep,percentileToValue,assembly,
	              plotFilenameTemplate=plotFilenameTemplate,
	              tickSpacing=tickSpacing,
                  width=width,height=height,pointsize=pointsize,
                  yLabelSpace=yLabelSpace)
	}

read_control_freec <- function(controlFreecFilename,scaffoldToOffset=NULL)
	#
	# Read a file containing the copy number ouput from ControlFREEC.
	#
	# A scaffold-to-offset can be provided, as would be produced by
	# linearized_scaffolds(). One columns are added, converting each window's
	# on-scaffold position to a position along a number line.
	#
	# typical input:
	#	Chromosome Start Ratio   MedianRatio CopyNumber
	#	SUPER_2    1     42.2814 22.2608     45
	#	SUPER_2    1001  31.0994 22.2608     45
	#	SUPER_2    2001  30.5009 22.2608     45
	#	SUPER_2    3001  26.9936 22.2608     45
	#	SUPER_2    4001  33.8109 22.2608     45
	#	SUPER_2    5001  27.2106 22.2608     45
	#    ...
	#
	# returns, e.g.
	#	scaffold start Ratio   MedianRatio CopyNumber s
	#	SUPER_2     1  42.2814 22.2608     45         200529156
	#	SUPER_2  1001  31.0994 22.2608     45         200530156
	#	SUPER_2  2001  30.5009 22.2608     45         200531156
	#	SUPER_2  3001  26.9936 22.2608     45         200532156
	#	SUPER_2  4001  33.8109 22.2608     45         200533156
	#	SUPER_2  5001  27.2106 22.2608     45         200534156
	#    ...
	#
	{
	controlFreec = read.table(controlFreecFilename,header=T,colClasses=c("character","numeric","numeric","numeric","numeric"))
	colnames(controlFreec) <- c("scaffold","start","Ratio","MedianRatio","CopyNumber")
	if (!is.null(scaffoldToOffset))
		{
		controlFreec = controlFreec[controlFreec$scaffold %in% names(scaffoldToOffset),]
		controlFreec[,"s"] = scaffoldToOffset[controlFreec$scaffold] + controlFreec$start
		}

	controlFreec
	}

control_freec_plot <- function(scaffolds,depth,controlFreec,percentileToValue,
                               assemblyName="",
                               scaffoldsToPlot=NULL,
                               plotFilename=NULL,
                               tickSpacing=10000000,
                               tickLabels=F,
                               width=17,height=7,pointsize=18,
                               yLabelSpace=7,
                               maxDepth=NA,
                               scaffoldInterval=NULL)
	#
	# Plot half-deep intervals and depth along an assembly
	#
	# scaffolds:              As returned by read_scaffold_lengths().
	# depth:                  As returned by read_depth().
	# controlFreec:           As returned by read_control_freec(). If this is
	#                         NULL, no controlFreec copy number information is
	#                         displayed.
	# percentileToValue:      As returned by read_percentiles()
	# assemblyName:           Name of the assembly. This contributes to the
	#                         plain title, and can contribute to the plot
	#                         file name.
	#                         Example: "bAlcTor1.pri.cur.20190613"
	# scaffoldsToPlot=NULL:   A vector of scaffolds to restrict the plot to.
	#                         By default, everything in scaffolds[] is
	#                         plotted.
	# plotFilename=NULL:      File to plot the data to. If this is NULL, the
	#                         data is plotted on the screen.
	# tickSpacing:            Spacing of evenly-spaced ticks along the
	#                         horizontal axis. If this is zero, these ticks
	#                         are inhibited. The default is 10Mbp.
	# tickLabels:             If true, add numeric labels to the horizontal
	#                         axis.
	# width,height,pointsize: These are passed through to whatever function
	#                         creates the plot window.
	# yLabelSpace:            Space below the plot. This can be increased to
	#                         accommodate longer scaffold names.
	# maxDepth:               Depth greater than this is not shown in the plot;
	#                         i.e. the vertical axis stops at this value. By
	#                         default this is 1.5*median depth.
	# scaffoldInterval        subinterval to restrict the plot to. Typically
	#                         this would only be used when only one scaffold
	#                         is to be plotted. This is a (start,end) pair,
	#                         origin-zero, half-open.
	#
	{
	# if we have a scaffold subset, reduce our copy of the data to that subset

	if (!is.null(scaffoldInterval))
		{
		if (is.null(scaffoldsToPlot))
			{
			if (length(scaffoldsToPlot) > 1)
				stop("scaffoldInterval cannot be used with more than one scaffold")
			}
		else
			{
			if (length(unique(scaffolds$name)) > 1)
				stop("scaffoldInterval cannot be used with more than one scaffold")
			}
		}

	showControlFreec = !is.null(controlFreec)

	if (is.null(scaffoldsToPlot))
		{
		scaffoldLen = sum(scaffolds$length)
		}
	else
		{
		# validate the names in the subset

		badNames = scaffoldsToPlot[!(scaffoldsToPlot %in% scaffolds$name)]
		if (length(badNames) > 0)
			stop(paste("bad scaffold name(s):",paste(scaffoldsToPlot,collapse=", ")))

		# pick ordered subset
		scaffolds = scaffolds[scaffolds$name %in% scaffoldsToPlot,]
		scaffoldsToNumber = 1:length(scaffoldsToPlot)
		names(scaffoldsToNumber) = scaffoldsToPlot
		scaffolds = scaffolds[order(scaffoldsToNumber[scaffolds$name]),]
		scaffolds[,"offset"] = rev(sum(as.numeric(scaffolds$length))-cumsum(rev(as.numeric(scaffolds$length))))
		scaffoldToOffset = linearized_scaffolds(scaffolds)

		# reduce to ordered subset
		depth = depth[depth$scaffold %in% names(scaffoldToOffset),]
		depth[,"s"] = scaffoldToOffset[depth$scaffold] + depth$start
		depth[,"e"] = scaffoldToOffset[depth$scaffold] + depth$end

		if (showControlFreec)
			{
			controlFreec = controlFreec[controlFreec$scaffold %in% names(scaffoldToOffset),]
			controlFreec[,"s"] = scaffoldToOffset[controlFreec$scaffold] + controlFreec$start
			}

		scaffoldLen = sum(scaffolds$length[scaffolds$name==scaffoldsToPlot])
		}

	# fetch percentile values (used only for drawing and labeling)

	depth50        = percentileToValue["percentile50"]
	halfDepthLo    = percentileToValue["halfPercentile40"]
	halfDepthHi    = percentileToValue["halfPercentile60"]
	depthClip      = ifelse(is.na(maxDepth),1.5*depth50,maxDepth)
	depth50Str     = sprintf("%.1f",depth50)
	halfDepthLoStr = sprintf("%.1f",halfDepthLo)
	halfDepthHiStr = sprintf("%.1f",halfDepthHi)
	depthClipStr   = sprintf("%.1f",depthClip)

	# (housekeeping)

	scaffoldTicks = 1 + c(scaffolds$offset,sum(as.numeric(scaffolds$length)))
	scaffoldCenters = (as.numeric(scaffoldTicks[1:nrow(scaffolds)])+as.numeric(scaffoldTicks[2:(nrow(scaffolds)+1)])) / 2

	CNSpacing = depthClip / 32

	if (!is.null(scaffoldInterval))
		{
		xlim = scaffoldInterval
		depth = depth[(depth$s>=xlim[1])&(depth$s<=xlim[2]),]
		controlFreec = controlFreec[(controlFreec$s>=xlim[1])&(controlFreec$s<=xlim[2]),]
		scaffoldCenters = (scaffoldInterval[1]+scaffoldInterval[2])/2
		}
	else
		{
		xlim = c(1,max(scaffoldTicks))
		}

	ylim = if (showControlFreec) c(-5*CNSpacing,depthClip) else c(0,depthClip)
	ylimLong = ylim
	ylimLong[1] = ylimLong[1] - CNSpacing

	depthColor       = rgb(.6,.6,.6)
	halfDepthColor   = "black"
	depthLimitsColor = "blue"
	clippedColor     = "red"

	# clipping

	depth$clipped = ifelse(depth$depth<=depthClip,depth$depth,depthClip)
	depth$color   = ifelse(depth$depth<=depthClip,depthColor,clippedColor)

	controlFreec$CNclipped = ifelse(controlFreec$CopyNumber<=2,controlFreec$CopyNumber,3)

	# open plot window or file

	turnDeviceOff = F
	if (is.null(plotFilename))
		{
		quartz(width=width,height=height,pointsize=pointsize)
		}
	else
		{
		print(paste("drawing to",plotFilename))
		pdf(file=plotFilename,width=width,height=height,pointsize=pointsize)
		turnDeviceOff = T
		}

	# create empty plot

	if (assemblyName == "")
		title = paste("Copy Number\n(per ControlFREEC)",sep="")
	else
		title = paste("Copy Number on ",assemblyName,"\n(per ControlFREEC)",sep="")
	ylab = "depth (black/gray) and CN (blue/red)"

	par(mar=c(yLabelSpace,4,2.5,0.2)+0.1)     # BLTR
	options(scipen=10)
	plot(NA,xlim=xlim,ylim=ylim,main=title,xaxt="n",xlab="",ylab=ylab)

	# add horizontal axis

	if ((tickSpacing > 0) & (xlim[2]>=tickSpacing))              # equal-spaced ticks
		{
		leftTick = xlim[1] + (tickSpacing-1) - ((xlim[1] + (tickSpacing-1)) %% tickSpacing)
		ticks = seq(leftTick,xlim[2],by=tickSpacing)
		axis(1,at=ticks,labels=F,col="gray")
		if (tickLabels)
			{
			labeledTicks = ticks[abs(scaffoldCenters-ticks)>=tickSpacing/4]
			axis(1,at=labeledTicks,tick=F,                       # tick labels
			     labels=prettyNum(labeledTicks,big.mark=",",scientific=FALSE),
				 las=2,pos=ylim[1]-0.5,cex.axis=0.5)
			}
		}
	axis(1,at=scaffoldTicks,labels=F,tck=-0.08)                  # scaffold ticks
	axis(1,at=scaffoldCenters,tick=F,labels=scaffolds$name,      # scaffold labels
		 las=2,cex.axis=0.7)

	# draw depth as gray, and depth in half-deep intervals as black

	points(depth$s,depth$clipped,col=depth$color,pch=19,cex=0.3)

	halfsies = (depth$depth>=halfDepthLo) & (depth$depth<=halfDepthHi)
	points(depth$s[halfsies],depth$depth[halfsies],col=halfDepthColor,pch=19,cex=0.1)

	for (ix in 1:length(scaffoldTicks))
		lines(c(scaffoldTicks[ix],scaffoldTicks[ix]),ylimLong,col="black",lwd=1,lty=2)

	# add horizontal lines to show median and half-deep limits

	lines(xlim,c(depth50,depth50),col=depthLimitsColor,lwd=2,lty=2)
	lines(xlim,c(halfDepthHi,halfDepthHi),col=depthLimitsColor,lwd=2,lty=2)
	lines(xlim,c(halfDepthLo,halfDepthLo),col=depthLimitsColor,lwd=2,lty=2)

	text(xlim[1],depth50,    "median ",   adj=1,cex=0.5,col=depthLimitsColor)
	text(xlim[1],halfDepthLo,"half-40th ",adj=1,cex=0.5,col=depthLimitsColor)
	text(xlim[1],halfDepthHi,"half-60th ",adj=1,cex=0.5,col=depthLimitsColor)

	# add controlFreec copy number information
	# from bottom up, rows are copy number = 0, 1, 2, >2

	if (showControlFreec)
		{
		for (cn in -2:-5)
			{
			lines(xlim,c(cn*CNSpacing,cn*CNSpacing),col="red",lty=1)
			text(xlim[1]-0.005*(xlim[2]-xlim[1]),cn*CNSpacing,cex=0.4,adj=1,
			     ifelse(cn==-2,"CN>2",paste("CN=",cn+5,sep="")))
			}
		points(controlFreec$s,(controlFreec$CNclipped-5)*CNSpacing,pch=16,cex=0.5,
			   col=ifelse(controlFreec$CNclipped==1,"blue","red"))
		}

	# close the plot

	if (turnDeviceOff) dev.off()
	}


Pts2TreeShp <- function(datafile,shape_dir,shape_name,class_col=8,x_col=1,
                        y_col=2,z_col=3){
#
# A function that takes a pointcloud dataset in csv format and returns
# a ShapeFile of the convex hulls of each tree labelled by a given
# number in class_col. Each shape also has associated x,y,z data of
# the top point of each tree in the dbf file
#
# Data is then saved out to the ShapeFile layer as set by the arguments
# shape_dir and shape_name
#
# Arguments
#
#       datafile:       .csv file of points
#       shape_dir:      name of directory to be created to store ShapeFile data
#       shape_name:     name of ShapeFile layer to be created
#       class_col:      column number containing numerical label for tree
#                       membership of each point (use 0 if not a member of tree)
#       x_col:          column number containing x co-cordinates of each point
#       y_col:          column number containing y co-cordinates of each point
#       z_col:          column number containing z co-cordinates of each point

# Some input checking
if(!is.character(shape_dir)){
        stop('Argument shape_dir must be a string')
}
if(!is.character(shape_name)){
        stop('Argument shape_name must be a string')
}

# get dependencies
if(!require(sp)){
        install.packages('sp')
}
library(sp)
if(!require(rgdal)){
        install.packages('rgdal')
}
library(rgdal)

# read data
data <- read.csv(datafile,header=F)

# remove unclassified points
zero_idx <- which(data[,class_col]==0)
if(length(zero_idx!=0)){
        data <- data[-zero_idx,]
}

# If no points classified then end here
if(nrow(data)==0){
        return(NA)
}

# Get tree indices
tr_ids <- sort(unique(data[,class_col]))

# Set up objects to collect data
all_poly <- list()
x <- numeric(length(tr_ids))
y <- numeric(length(tr_ids))
z <- numeric(length(tr_ids))

# get each tree
for(i in 1:length(tr_ids)){

        #get tree id
        j <- tr_ids[i]

        # Get convex hull indices
        ths_tr <- data[data[,class_col]==j,]
        ths_hl <- chull(ths_tr[,c(x_col,y_col)])
        ths_hl <- c(ths_hl,ths_hl[1])

        # convert to spatial polygon, as an island not hole
        ths_poly <- sp::Polygon(cbind(ths_tr[ths_hl,1],ths_tr[ths_hl,2]),hole=F)
        ths_polys <- sp::Polygons(list(ths_poly),as.character(i))

        # Add to our list
        all_poly[[length(all_poly)+1]] <- ths_polys

        # Get location of tree top
        ths_mxid <- which.max(ths_tr[,z_col])
        x[i] <- max(ths_tr[ths_mxid,x_col])
        y[i] <- max(ths_tr[ths_mxid,y_col])
        z[i] <- max(ths_tr[ths_mxid,z_col])

        # clean up
        rm(ths_tr,ths_hl,ths_poly,ths_polys,ths_mxid)
}

# Compiles all polygons and data in a spdf
all_polys <- sp::SpatialPolygons(all_poly,1:length(tr_ids))
final_polys <- sp::SpatialPolygonsDataFrame(all_polys,
                                            data=data.frame(x=x, y=y,z=z,
                                                            row.names=row.names(all_polys)))

# Save out the result
rgdal::writeOGR(obj=final_polys,dsn=shape_dir,layer=shape_name,driver="ESRI Shapefile")
}


args<-commandArgs(trailingOnly=TRUE)
if(length(args)<2){
	print("Usage: Rscript --vanilla script-branch-clade-analysis.r treefile_to_analyse clade_out all_trees_results")
	quit()
}
print("STARTING analysis with R script")

library(ape)

#-------------------------------------------------
getSubtreeInfo=function(t,cl,out){

	#print("entered getSubtreeInfo")
	# Check if the clade is monophyletic
	check_cl=is.monophyletic(t,cl)
        # Get a subtree structure
        subt=keep.tip(t,cl)

        if(check_cl){
                write.tree(file=out,subt)
                subtree=readLines(out)
        }else{
                subtree="NonMon"
        }

	# Num of edges < 10^(-5) in subclade
	check_e_len=length(which(subt$edge.length[]<0.00001))

	# Check if H, N, D are < 10^(-5)
	x=t$edge.length[which.edge(t,"HUMAN")]
	y=t$edge.length[which.edge(t,"NEANDERTHAL")]
	z=t$edge.length[which.edge(t,"DENISOVAN")]

	check_H_len=ifelse(x<0.00001, TRUE, FALSE)
	check_N_len=ifelse(y<0.00001, TRUE, FALSE)
	check_D_len=ifelse(z<0.00001, TRUE, FALSE)

	check_external=c(check_H_len,check_N_len,check_D_len)

	# Create a list with all info
	clade_info=list("mon" = check_cl, "subtree" = subtree, "edges" = check_e_len, "external" = check_external)
	return(clade_info)
}
#-------------------------------------------------
#print("READING tree")
t=read.tree(args[1])
t_out=args[2]
file_out=args[3]

# Clades of interest
clade=list(
	"c1" = c("HUMAN","NEANDERTHAL","DENISOVAN"),
	"c2"  = c("HUMAN","NEANDERTHAL"),
	"c3"  = c("NEANDERTHAL","DENISOVAN"),
	"c4"  = c("HUMAN","DENISOVAN"),
	"c5" = c("GORGO","PANTR","HUMAN","NEANDERTHAL","DENISOVAN")
)

#print("Checking monophyly of the 5 clades")
check_clade=c(
	is.monophyletic(t,clade$c1),
	is.monophyletic(t,clade$c2),
	is.monophyletic(t,clade$c3),
	is.monophyletic(t,clade$c4),
	is.monophyletic(t,clade$c5)
)

subt_out_1=paste(t_out,"subtr_1",sep=".")
subt_out_2=paste(t_out,"subtr_2",sep=".")

#print("Getting subtree info")
subtree_info_1=getSubtreeInfo(t,clade$c1,subt_out_1)
subtree_info_2=getSubtreeInfo(t,clade$c5,subt_out_2)

edges_other=subtree_info_1$edges-length(which(subtree_info_1$external[]==TRUE))
check_e_len=length(which(t$edge.length[]<0.00001))
tree_newick=readLines(args[1])

#print("outputing results")

sink(file=file_out,append=TRUE)
cat(paste(
	args[1],
	"|",
	paste("cladeHND_",check_clade[1],sep=""),
	ifelse(check_clade[2],"HN",FALSE),
	ifelse(check_clade[3],"ND",FALSE),
	ifelse(check_clade[4],"HD",FALSE),
	subtree_info_1$subtree,
	paste("edgesHND_",subtree_info_1$edges,sep=""),
	paste("H+",subtree_info_1$external[1],sep=""),
	paste("N+",subtree_info_1$external[2],sep=""),
	paste("D+",subtree_info_1$external[3],sep=""),
	paste("other_",edges_other,sep=""),
	"|=====|",
	paste("cladeHNDPPG_",check_clade[5],sep=""),
	subtree_info_2$subtree,
	paste("edgesHNDPPG_",subtree_info_2$edges,sep=""),
	tree_newick,
	paste("edgesTREE_",check_e_len,sep=""),
	'\n',
sep=" "))

sink()


#' Check date format
#'
#' Checks to see if format is YYYY-MM-DD. Also performs a few other date checks.
#'
#' @param date character
#' @keywords WRTDS flow
#' @return condition logical TRUE or FALSE if checks passed or failed
#' @export
#' @examples
#' date <- '1985-01-01'
#' dateFormatCheck(date)
#' dateWrong <- '1999/1/7'
#' dateFormatCheck(dateWrong)
dateFormatCheck <- function(date){  # checks for the format YYYY-MM-DD
  parts <- strsplit(date,"-",fixed=TRUE)
  condition <- FALSE
  if (length(parts[[1]])>1) {
    if (nchar(parts[[1]][1]) == 4 && nchar(parts[[1]][2]) == 2 && nchar(parts[[1]][3]) == 2){
      testYear <- as.numeric(parts[[1]][1])
      testMonth <- as.numeric(parts[[1]][2])
      testDay <- as.numeric(parts[[1]][3])
      if (!is.na(testYear) && !is.na(testMonth) && !is.na(testDay)){
        if (testMonth <= 12 && testDay <= 31){
          condition <- TRUE
        }
      }
    }
  }
  return(condition)
}


# --------------------------------------------------- #
# Author: Marius D. Pascariu
# License: MIT
# Last update: Thu Nov 07 11:33:27 2019
# --------------------------------------------------- #

#' @details
#' To learn more about the package, start with the vignettes:
#' \code{browseVignettes(package = "ungroup")}
#' \insertNoCite{*}{ungroup}
#' @references \insertAllCited{}
#' @importFrom Rcpp sourceCpp
#' @importFrom stats optimise qnorm quantile fitted aggregate nlminb AIC BIC
#' @importFrom utils tail
#' @importFrom MortalitySmooth MortSmooth_bbase
#' @importFrom graphics axis barplot legend lines plot abline par
#' @importFrom rgl axes3d box3d open3d surface3d title3d
#' @importFrom pbapply startpb setpb closepb
#' @import Rdpack
#' @name ungroup
#' @useDynLib ungroup
#' @aliases NULL
#' @docType package
"_PACKAGE"


# R Code
# Ploting the results
# L. Garcia, A. Lorena, M. de Solto 2017
# Ploting the complexity measures

default <- function() {

  par = element_text(size=14, colour="black")

  plot = theme_bw() +
    theme(legend.position="top",
      text=par, axis.text=par, strip.text=par, legend.text=par
    )

  return(plot)
}

distribution <- function(data) {

  data = apply(data[CLASSIFIERS], 1, which.max)
  data = melt(table(CLASSIFIERS[data]))

  pdf("wins1.pdf", width=4, height=4)
    plot = ggplot(data, aes(x=Var1, y=value)) +
      geom_bar(colour="black", fill="white", stat="identity",
        position="dodge", width=0.6) +
      geom_hline(yintercept=0) +
      default() + ylab("Number of wins") +
      xlab("") + guides(fill=FALSE)
    print(plot)
  dev.off()
}

histogram <- function(data) {

  table = data[CLASSIFIERS]
  table = melt(table)

  pdf("wins2.pdf", width=4, height=4)
    plot = ggplot(table, aes(x=variable, y=value)) +
      geom_boxplot() +
      default() + ylab("Accuracy") +
      xlab("")
    print(plot)
  dev.off()
}

boxplot <- function(data) {

  data = data.frame(do.call("rbind", data))
  data$Classifier = rep(CLASSIFIERS, each=141)

  table = melt(data)
  table$group = c(rep("a", 1692), rep("b", 1128))

  pdf("boxplot.pdf", width=8, height=9)
    plot = ggplot(table, aes(x=variable, y=value, fill=group)) +
      geom_boxplot() + facet_wrap( ~ Classifier, ncol=2) +
      default() +scale_fill_manual(values=c("white", "grey")) +
      xlab("") + ylab("MSE") + guides(fill=FALSE) +
      ylim(0, 0.1)
    print(plot)
  dev.off()
}

performance <- function(data, aux) {

  foo = lapply(1:141, function(i) {
    tmp = do.call("rbind", lapply(aux, "[", i,))
    goo = apply(tmp, 2, which.max)
    unlist(data[i,CLASSIFIERS[goo]])
  })

  foo = do.call("rbind", foo)
  foo = apply(foo, 2, sum)
  foo = rbind(foo[1:3] - foo[4], foo[1:3] - foo[5])
  colnames(foo) = REGRESSORS[1:3]
  rownames(foo) = c("Random", "Default")
  foo = foo*100

  table = melt(foo)

  pdf("performance.pdf", width=6, height=4)
    plot = ggplot(table, aes(x=Var2, y=value)) +
      geom_bar(colour="black", fill="white", stat="identity",
        position="dodge", width=0.6) + facet_wrap( ~ Var1, ncol=4) +
      geom_hline(yintercept=0) + default() +
      ylab("Percentage increase of accuracy") + xlab("")
    print(plot)
  dev.off()

}

features <- function(data) {

  aux = do.call("cbind",
    lapply(CLASSIFIERS, function(c) {
      randomForest(formulae(c), data)$importance
    })
  )
  aux = rev(sort(rowMeans(aux)))[1:5]
  table = melt(aux)
  table$Var1 = factor(rownames(table), levels=rownames(table))

  pdf("features.pdf", width=5, height=5)
    plot = ggplot(table, aes(x=Var1, y=value)) +
      geom_bar(colour="black", fill="white", stat="identity",
        position="dodge", width=0.6) + default() +
      theme(axis.text.x=element_text(size=14, angle=90, hjust=1, vjust=0.3)) +
      geom_hline(yintercept=0) +
      ylab("Measure Importance") + xlab("")
    print(plot)
  dev.off()
}


# This function gets certain downstream/upstream genes in given kegg pathways

## === input ===
### file: pathway file name;
### id: list of kegg pathway ids (in the form of hsaXXXXXX)
### gene = NA: default as return all the genes
### direction: 1 for downstream; -1 for upstream
### step = 20: default as all the upstream/downstream genes; if specified, iterate given steps

## == output ===
### genelist: certain downstream/upstream genes in given kegg pathways

GetGeneList <- function(file, id, gene = NA, direction = 1, steps = 20) {
  edges.file = read.delim(file, header = T, sep = ",")
  filter = rep(F, dim(edges.file)[1])
  for (i in 1:length(id)) {
    filter = filter | (as.character(edges.file$Source) == id[i])
  }
  filter = filter & !(as.character(edges.file$Type) == "downstream")  # here we don't need "pathway nodes"
  filter = filter & !(as.character(edges.file$Subtype1) == "binding/association") # here we don't consider binding as downstream
  trimmed.file = edges.file[filter,]

  if (is.na(gene)) {
    result = unique(c(as.character(trimmed.file$node1), as.character(trimmed.file$node2)))
  } else {
    # generate matrix representing linkages
    node1.list = as.character(trimmed.file$node1)
    node2.list = as.character(trimmed.file$node2)
    all_nodes = unique(c(node1.list, node2.list))
    linkage.matrix = matrix(0, nrow = length(all_nodes), ncol = length(all_nodes), dimnames = list(all_nodes, all_nodes))
    for (j in 1:dim(trimmed.file)[1]) {
      linkage.matrix[node1.list[j], node2.list[j]] = 1
    }
    # get required genes
    if (direction == -1) {
      linkage.matrix = t(linkage.matrix)
    }
    result = c()
    current_number = 0
    for (cnt in 1:steps) {
      if (length(gene) > 1) {
        gene = colnames(linkage.matrix)[colSums(linkage.matrix[gene,]) > 0]
      } else {
        gene = colnames(linkage.matrix)[linkage.matrix[gene,] == 1]
      }
      result = c(result, gene)
      result = unique(result)
      tmp_cnt = length(result)
      if(current_number == tmp_cnt) {
        break
      } else {
        current_number = tmp_cnt
      }
    }
  }

  result
}


require(rgeos)
require(overpass)
require(rgdal)
require(raster)
library(tidyverse)

basin = c('Indus')

setwd('P:/is-wel/indus/message_indus')

# Grab the basin boundaries
basin.spdf = readOGR( paste( getwd(), 'input', sep = '/' ), 'Indus_bcu', verbose = FALSE )
pids_original <- as.character(basin.spdf@data$PID )
basin.spdf = spTransform( basin.spdf, CRS("+proj=longlat") ) # temp[which(as.character(temp$BASIN) == basin | as.character(temp$PID) == '2256'),] for Karachi basin
basin.sp = gUnaryUnion( basin.spdf )
basin.sp = SpatialPolygons(list(Polygons(Filter(function(f){f@ringDir==1},basin.sp@polygons[[1]]@Polygons),ID=1)))
buff.sp = gBuffer( basin.sp, width=0.1 )
proj4string(basin.sp) = proj4string(basin.spdf)
proj4string(buff.sp) = proj4string(basin.spdf)

# include the riparian countries outside the basin, to have external routes
extra_basin.spdf = readOGR( paste( getwd(), 'input', sep = '/' ), 'indus_extra_basin_rip_countries', verbose = FALSE )
extra_basin.spdf <- extra_basin.spdf[,(3)]
names(extra_basin.spdf) = "PID"
proj4string(extra_basin.spdf) = proj4string(basin.spdf)
extra_basin.spdf = spTransform( extra_basin.spdf, CRS("+proj=longlat") )

# subbasin polygons
basin_pid.spdf <- basin.spdf[,(1)]
mrg.spdf <- rbind(basin_pid.spdf,extra_basin.spdf)
subbasins.sp = gUnaryUnion(mrg.spdf, id = mrg.spdf@data$PID)
subbasins.sp = SpatialPolygons(lapply(1:length(subbasins.sp),function(x){Polygons(Filter(function(f){f@ringDir==1},subbasins.sp@polygons[[x]]@Polygons),ID=x)}))
proj4string( subbasins.sp ) = proj4string( basin.spdf )

# get data from osm if not already available locally
if( !file.exists( paste( 'input/basin_transmission', paste(basin, 'osm_power_lines.shp', sep='_' ), sep = '/' ) ) )
	{

	# Grab electricity transmission data corresponding to extent from basin polygon
	ltypes = c('line','cable','minor_line')
	power_lines = lapply( ltypes, function(ltype){
		ext = paste( '(',paste(bbox(basin.spdf)[2,1] , bbox(basin.spdf)[1,1], bbox(basin.spdf)[2,2], bbox(basin.spdf)[1,2],sep=','),')',sep='')
		pth = paste( '[out:xml][timeout:100];(node["power"="',ltype,'"]',ext,';way["power"="',ltype,'"]',ext,';relation["power"="',ltype,'"]',ext,';);out body;>;out skel qt;', sep = '' )
		frb = overpass_query(pth)
		if( !is.null(frb) )
			{
			proj4string(frb) = proj4string(basin.spdf)
			frb = frb[ which( unlist( row.names(frb) ) %in% unlist( sapply( unlist( row.names( gIntersection( frb, buff.sp , byid=TRUE ) ) ), function(xxx){ unlist( strsplit( xxx, '[ ]') )[1] } ) ) ), 'voltage' ]
			}
		return(frb)
		} )
	names(power_lines) = ltypes
	power_lines[ sapply( power_lines, is.null ) ] = NULL
	power_lines = do.call( rbind, power_lines )

	# Output to shapefile
	writeOGR( power_lines, 'input/basin_transmission', paste(basin,'osm_power_lines',sep='_'),  driver="ESRI Shapefile",  overwrite_layer=TRUE )
	}

# Electricity transmission - stylized St Claire Curve for converting kV to MW
x1 = c(69,138,230,345,500,765)
y1 = 0.8 * c(12,50,140,375,900,2200)
mod1 = nls(y1 ~ a1 + a2*x1 + a3*x1^2, start = list(a1 = 0, a2 = 0, a3 = 1)) # model for converting kV to MW

# Clean up transmission data using an minimum of 66kV and then fit to MW using model
## HOW HAS THE OSM_POWER_LINES.SHP BEEN CREATED? should have the script, for transferrability
basin_pline.sldf = readOGR( 'input/basin_transmission', paste(basin,'osm_power_lines',sep='_') )
basin_pline.sldf = basin_pline.sldf[ -1 * which( is.na(basin_pline.sldf$voltage) ), ]
basin_pline.sldf$voltage = as.numeric( as.character( basin_pline.sldf$voltage ) ) / 1000
basin_pline.sldf = basin_pline.sldf[ which( basin_pline.sldf@data$voltage > 60 ), ]
basin_pline.sldf$MW = unlist( lapply( 1:length(basin_pline.sldf), function(zz){
	return( round( 	coef(mod1)[1] +
					coef(mod1)[2] * basin_pline.sldf@data$voltage[zz] +
					coef(mod1)[3] * basin_pline.sldf@data$voltage[zz]^2 ) )
	} ) )

# Get intersections between spatial lines and basin polygons - t
subbasins.sp = spTransform( subbasins.sp, crs(basin_pline.sldf) )
inters = lapply( 1:length(basin_pline.sldf), function(x){ which( gIntersects(basin_pline.sldf[x,], subbasins.sp,byid=TRUE)) } )

# Initialize matrix tracking connections and installed capacity
electricity_transmission_MW = matrix(data = 0, ncol = length(subbasins.sp), nrow = length(subbasins.sp))
ln = rep(NA,length(inters))
for(x in 1:length(inters))
	{
	res = inters[[x]]
	ln[x] = length(res)
	if( length(res) > 1 )
		{
		if( length(res) == 2 )
			{
			electricity_transmission_MW[ res[1], res[2] ] = electricity_transmission_MW[ res[1], res[2] ] + basin_pline.sldf$MW[x]
			electricity_transmission_MW[ res[2], res[1] ] = electricity_transmission_MW[ res[2], res[1] ] + basin_pline.sldf$MW[x]
			}else
			{
			# Manual check
			# cols = c('red','green','blue','orange')
			# windows()
			# plot(subbasins.sp[c(res)], main = paste('x','=',x,basin_pline.sldf$voltage[x], 'kV',sep=' '), border = 'white',col = cols)
			# plot(basin_pline.sldf,col='gray',add=TRUE)
			# plot(basin_pline.sldf[x,],add=TRUE, col = 'black', lwd = 4)
			# legend('topleft',legend = unlist(lapply(1:length(res),function(ww){paste(res[ww], as.character(basin.spdf@data$BCU[c(res[ww])]), sep = ' - ')})), fill = cols )
			temp = combn(length(res),2)
			for(kkk in 1:ncol(temp))
				{
				line_features = disaggregate(crop( as(basin_pline.sldf[x,],'SpatialLines'), gUnaryUnion( subbasins.sp[ c( res[ temp[1,kkk] ],res[ temp[2,kkk] ] ) ] ) ),byid=TRUE)
				for(lll in 1:length(line_features))
					{
					if( ( length( crop( line_features[lll], subbasins.sp[ c( res[ temp[1,kkk] ]) ] ) ) > 0 ) & ( length( crop( line_features[lll], subbasins.sp[ c( res[ temp[2,kkk] ]) ] ) ) > 0 ) )
						{
						print(temp[,kkk])
						electricity_transmission_MW[ res[ temp[1,kkk] ], res[ temp[2,kkk] ] ] = electricity_transmission_MW[ res[ temp[1,kkk] ], res[ temp[2,kkk] ] ] + basin_pline.sldf@data$MW[x]
						electricity_transmission_MW[ res[ temp[2,kkk] ], res[ temp[1,kkk] ] ] = electricity_transmission_MW[ res[ temp[2,kkk] ], res[ temp[1,kkk] ] ] + basin_pline.sldf@data$MW[x]
						}
					}
				}
			}
		}
}

# update PID naming
electricity_transmission_MW = data.frame( electricity_transmission_MW )
names_et <- c( as.character( basin.spdf$PID), as.character( extra_basin.spdf$PID))
# names(electricity_transmission_MW) = names_et
# row.names(electricity_transmission_MW) = names_et

# instead
pid_mrg<- data.frame( round(coordinates(mrg.spdf),2) ) %>%
  mutate(coords = paste(X1,X2,sep = '.')) %>%
  mutate(pid_4subb = names_et) %>%
  select(coords,pid_4subb)

pid_correspondence<- data.frame( round(coordinates(subbasins.sp),2) ) %>%
  mutate(coords = paste(X1,X2,sep = '.')) %>%
  left_join(pid_mrg) %>%
  select(-X1,-X2)

names(electricity_transmission_MW) = pid_correspondence$pid_4subb
row.names(electricity_transmission_MW) = pid_correspondence$pid_4subb

# Make transmission network
starts = NULL
ends = NULL
mw = NULL
trns.df2 = NULL
for(ii in 1:ncol(electricity_transmission_MW))
	{
	for(jj in ii:ncol(electricity_transmission_MW))
		{
		if(electricity_transmission_MW[ii,jj]>0)
			{
			starts = c(starts,ii)
			ends = c(ends,jj)
			mw = c(mw,electricity_transmission_MW[ii,jj])
			trns.df2 = rbind(trns.df2,data.frame(value = electricity_transmission_MW[ii,jj], tec = paste0(names(electricity_transmission_MW)[ii],'|',row.names(electricity_transmission_MW)[jj]),starts = names(electricity_transmission_MW)[ii], ends = row.names(electricity_transmission_MW)[jj],stringsAsFactors = FALSE ) )
			}
		}
	}

# Get adjacent and downstream bcus
gt = gTouches( basin.spdf, byid=TRUE )
adjacent.list = lapply( 1:length(basin.spdf), function( iii ){ return( basin.spdf@data$PID[ which( gt[,iii] ) ] ) } )
downstream.list = lapply( 1:length(basin.spdf), function( iii ){ if( !is.na( basin.spdf@data$DOWN[iii] ) ){ return( basin.spdf@data$PID[ which( as.character( basin.spdf@data$ID ) == as.character( basin.spdf@data$DOWN[iii] ) ) ] ) }else{ return( 'SINK' ) } } )
names(adjacent.list) = basin.spdf@data$PID
names(downstream.list) = basin.spdf@data$PID
flow_routes = sapply( 1:length( downstream.list ), function( iii ){ paste( names( downstream.list )[[ iii ]], downstream.list[[ iii ]], sep = '|' ) } )
adj1 = unlist( sapply( 1:length( adjacent.list ), function( iii ){ paste( names( adjacent.list )[[ iii ]], adjacent.list[[ iii ]], sep = '|' ) } ) )
adj2 = unlist( sapply( 1:length( adjacent.list ), function( iii ){ paste( adjacent.list[[ iii ]], names( adjacent.list )[[ iii ]], sep = '|' ) } ) )
inds = NULL
for(iii in 1:length(adj2)){ jjj = which( adj1 == adj2[iii] ) ; if( jjj > iii ){ inds = c(inds,jjj) } }
adj3 = unlist( sapply( 1:length( adjacent.list ), function( iii ){ paste( names( adjacent.list )[[ iii ]],'|',adjacent.list[[ iii ]], sep = '' ) } ) )
adjacent_routes = adj3[ -1 * inds ]
export_routes = c( 	"PAK_2|PAK",
                                "PAK_4|PAK",
                                "PAK_5|PAK",
                                "PAK_6|PAK",
                                "PAK_10|PAK",
                                "PAK_12|PAK",
                                "PAK_13|CHN",
                                "CHN_2|CHN",
                                "CHN_1|CHN",
                                "CHN_3|CHN",
                                "AFG_2|AFG",
                                "AFG_1|AFG",
                                "PAK_7|AFG",
                                "PAK_8|AFG",
                                "PAK_10|IND",
                                "IND_4|IND")

library(tmap)
tm_shape(basin.spdf)+
  tm_borders(col = NA, lwd = 1.5, lty = "solid", alpha = NA)+
  tm_polygons(col = 'REGION', lty = "solid", alpha = 0.2)+
  tm_text("PID", size="AREA", root=5)+
  tm_shape(extra_basin.spdf)+
  tm_borders(col = NA, lwd = 2.5, lty = "solid", alpha = NA)+
  tm_text("PID", color = 'red')

all_routes <- c(adjacent_routes,export_routes)
trns_out.df <- data.frame(tec = all_routes, value = 0,stringsAsFactors = F) %>%
  filter(!tec %in% trns.df2$tec) %>%
  bind_rows(trns.df2 %>%   select(tec,value) ) %>%
  mutate(node = gsub('\\|.*','',tec)) %>%
  mutate(year_all = 2015) %>%
  mutate(units='MW') %>%
  select(node,tec,year_all,value,units)

write.csv(trns_out.df,file.path(getwd(),'input/basin_transmission/existing_routes.csv'),row.names = F)

trueCentroids = gCentroid(basin.spdf,byid=TRUE)
#proj4string(trueCentroids) = "+proj=longlat +ellps=WGS84 +units=m"
trueCentroids <- spTransform(trueCentroids,CRS("+proj=lcc +lat_1=26 +lat_0=26 +lon_0=74 +k_0=0.99878641 +x_0=2743196.4 +y_0=914398.8 +a=6377301.243 +b=6356100.230165384 +towgs84=283,682,231,0,0,0,0 +units=m +no_defs" ))
distp = gDistance(trueCentroids,byid = T)
dist = as.data.frame(distp*gt)

names(dist) = as.character(pid_correspondence$pid_4subb)[1:24]
row.names(dist) = as.character(pid_correspondence$pid_4subb)[1:24]

starts = NULL
ends = NULL
df = NULL
for(ii in 1:ncol(dist))
{
  for(jj in ii:ncol(dist))
  {
    if(dist[ii,jj]>0)
    {
      starts = c(starts,ii)
      ends = c(ends,jj)
      df = rbind(df,data.frame(dist = dist[ii,jj], route = paste0(names(dist)[ii],'|',row.names(dist)[jj]), country = gsub('_.*','',names(dist)[ii])) )
    }
  }
}

#need to add external routes, but can set an average number
library(data.table)
dist.df <- df %>%
	mutate(dist = dist/1000) %>%
	mutate(mean = mean(dist)) %>%
	group_by(country) %>%
	mutate(cnt_mean = mean(dist)) %>%
	ungroup()

dist.out <- dist.df %>%
	select(dist,route) %>%
	rename(tec = route)

write.csv(dist.out,'P:/is-wel/indus/message_indus/input/PID_distances_km.csv',row.names = F)


# This example shows you how to use the R6 class ParameterFile. That being said, it is quite simple to just copy-paste the parameter you want from the logfile type 2 rather than using my ParameterFile interface if you prefer.
# Note that the graph will likely not be good looking. You will need to play around with the ggnet function to get exactly the graph you want. The purpose of this script is just to show you a small example of what you could do to graph parameters that are being printed on the logfile type 2

###########################
##### Instal packages #####
###########################

needed_packages <- c("network", "ggplot2", "GGally")
need_to_install_packages = setdiff(needed_packages, rownames(installed.packages()))
if (length(need_to_install_packages) > 0) {
	cat(paste("I will try to install the following package(s):", paste(need_to_install_packages, collapse=", ")))
  install.packages(need_to_install_packages)
}
for (needed_package in needed_packages)
{
	require(needed_package, character.only=TRUE)
}

###################################
##### Load log file of type 2 #####
###################################

paramFile = ParameterFile$new("/Users/remi/Documents/Biologie/programming/PopGenSimulator/SimBit/log.log")

##########################
##### Get parameters #####
##########################

generations = paramFile$readParameter("__GenerationChange")  # Contains a vector of the generations at which there were temporal changes (with the @G marker)
dispMatrices = paramFile$readDispersalMatrixOverTime()       # Contains a list of dispersal matrix. Each element of the list is for a different @G marker
patchCapacities = paramFile$readParameter("__patchCapacity") # Contains a list of vector of patch capacity. Each element of the list is for a different @G marker

######################################################################################
##### Loop over the generations at which there were changes for those parameters #####
######################################################################################

pdf("DemographyGraphs.pdf")
for (generation_index in 1:length(generations))
{
	dispMatrix    = dispMatrices[[generation_index]]
	patchCapacity = patchCapacities[[generation_index]]
	generation    = generations[generation_index]

	#################
	##### Graph #####
	#################

	net = network(dispMatrix, directed = TRUE)
	#net %v% "patchID" = paste("patch ", 1:nrow(dispMatrix))
	print(ggnet(net, node.alpha=0.5, label = 1:nrow(dispMatrix), weight = patchCapacity, arrow.size = 8, arrow.gap = 0) + ggtitle(paste("From generation", generation)))
}
dev.off()


#' The full human linear model underlying PROGENy
#'
#' HGNC gene symbols in rows, pathways in columns. Pathway activity inference
#' works by matrix multiplication of gene expression with the model.
#'
#' @format The full human model contains 22479 genes, associated pathways,
#' weight and the p-value.
#' \describe{
#'     \item{gene}{gene names in HGNC symbols}
#'     \item{pathway}{names of PROGENy pathways}
#'     \item{weight}{z-scores for a given gene}
#'     \item{p.value}{significance of gene in pathway}
#' }
#' @keywords datasets
#' @name model_human_full
#' @examples get("model_human_full", envir = .GlobalEnv)
#' @source \url{https://www.nature.com/articles/s41467-017-02391-6}
NULL

#' The full mouse linear model underlying PROGENy
#'
#' MGI gene symbols in rows, pathways in columns. Pathway activity inference
#' works by matrix multiplication of gene expression with the model.
#'
#' @format The full mouse model contains 17426 genes, associated pathways,
#' weight and the p-value.
#' \describe{
#'     \item{gene}{gene names in HGNC symbols}
#'     \item{pathway}{names of PROGENy pathways}
#'     \item{weight}{z-scores for a given gene}
#'     \item{p.value}{significance of gene in a pathway}
#' }
#' @keywords datasets
#' @name model_mouse_full
#' @examples get("model_mouse_full", envir = .GlobalEnv)
#' @source \url{https://www.ncbi.nlm.nih.gov/pubmed/31525460}
NULL


## functions for estimate cell counts edited to take matrices rather than mset
## relaxed p value threshold to select probes to 1e-4

library(genefilter)
library(quadprog)

validationCellType <- function(Y, pheno, modelFix, modelBatch=NULL,
                               L.forFstat = NULL, verbose = FALSE){
    N <- dim(pheno)[1]
    pheno$y <- rep(0, N)
    xTest <- model.matrix(modelFix, pheno)
    sizeModel <- dim(xTest)[2]
    M <- dim(Y)[1]

    if(is.null(L.forFstat)) {
        L.forFstat <- diag(sizeModel)[-1,] # All non-intercept coefficients
        colnames(L.forFstat) <- colnames(xTest)
        rownames(L.forFstat) <- colnames(xTest)[-1]
    }

    ## Initialize various containers
    sigmaResid <- sigmaIcept <- nObserved <- nClusters <- Fstat <- rep(NA, M)
    coefEsts <- matrix(NA, M, sizeModel)
    coefVcovs <- list()

    if(verbose)
        cat("[validationCellType] ")
    for(j in 1:M) { # For each CpG
        ## Remove missing methylation values
        ii <- !is.na(Y[j,])
        nObserved[j] <- sum(ii)
        pheno$y <- Y[j,]

        if(j%%round(M/10)==0 && verbose)
            cat(".") # Report progress

        try({ # Try to fit a mixed model to adjust for plate
            if(!is.null(modelBatch)) {
                fit <- try(lme(modelFix, random=modelBatch, data=pheno[ii,]))
                OLS <- inherits(fit,"try-error") # If LME can't be fit, just use OLS
            } else
                OLS <- TRUE

            if(OLS) {
                fit <- lm(modelFix, data=pheno[ii,])
                fitCoef <- fit$coef
                sigmaResid[j] <- summary(fit)$sigma
                sigmaIcept[j] <- 0
                nClusters[j] <- 0
            } else {
                fitCoef <- fit$coef$fixed
                sigmaResid[j] <- fit$sigma
                sigmaIcept[j] <- sqrt(getVarCov(fit)[1])
                nClusters[j] <- length(fit$coef$random[[1]])
            }
            coefEsts[j,] <- fitCoef
            coefVcovs[[j]] <- vcov(fit)

            useCoef <- L.forFstat %*% fitCoef
            useV <- L.forFstat %*% coefVcovs[[j]] %*% t(L.forFstat)
            Fstat[j] <- (t(useCoef) %*% solve(useV, useCoef))/sizeModel
        })
    }
    if(verbose)
        cat(" done\n")
    ## Name the rows so that they can be easily matched to the target data set
    rownames(coefEsts) <- rownames(Y)
    colnames(coefEsts) <- names(fitCoef)
    degFree <- nObserved - nClusters - sizeModel + 1

    ## Get P values corresponding to F statistics
    Pval <- 1-pf(Fstat, sizeModel, degFree)

    out <- list(coefEsts=coefEsts, coefVcovs=coefVcovs, modelFix=modelFix, modelBatch=modelBatch,
                sigmaIcept=sigmaIcept, sigmaResid=sigmaResid, L.forFstat=L.forFstat, Pval=Pval,
                orderFstat=order(-Fstat), Fstat=Fstat, nClusters=nClusters, nObserved=nObserved,
                degFree=degFree)

    out
}

pickCompProbes <- function(rawbetas, cellInd, cellTypes = NULL, numProbes = 50, probeSelect = probeSelect) {
	## p is matrix of beta values
	## cellInd is vector denoting cell type
    splitit <- function(x) {
        split(seq(along=x), x)
    }

 #   p <- getBeta(mSet)
 #   pd <- as.data.frame(colData(mSet))
    if(!is.null(cellTypes)) {
        if(!all(cellTypes %in% as.character(cellInd)))
            stop("elements of argument 'cellTypes' is not part of 'cellInd'")
        keep <- which(as.character(cellInd) %in% cellTypes)
        rawbetas <- rawbetas[,keep]
		cellInd<-cellInd[keep]
    }
    ## make cell type a factor
    cellInd <- factor(cellInd)
    ffComp <- rowFtests(rawbetas, cellInd)
    prof <- sapply(splitit(cellInd), function(i) rowMeans(rawbetas[,i]))
    r <- matrixStats::rowRanges(rawbetas)
    compTable <- cbind(ffComp, prof, r, abs(r[,1] - r[,2]))
    names(compTable)[1] <- "Fstat"
    names(compTable)[c(-2,-1,0) + ncol(compTable)] <- c("low", "high", "range")
    tIndexes <- splitit(cellInd)
    tstatList <- lapply(tIndexes, function(i) {
        x <- rep(0,ncol(rawbetas))
        x[i] <- 1
        return(rowttests(rawbetas, factor(x)))
    })

    if (probeSelect == "any"){
        probeList <- lapply(tstatList, function(x) {
            y <- x[x[,"p.value"] < 1e-4,]
            yAny <- y[order(abs(y[,"dm"]), decreasing=TRUE),]
            c(rownames(yAny)[1:(numProbes*2)])
        })
    } else {
        probeList <- lapply(tstatList, function(x) {
            y <- x[x[,"p.value"] < 1e-4,]
            yUp <- y[order(y[,"dm"], decreasing=TRUE),]
            yDown <- y[order(y[,"dm"], decreasing=FALSE),]
            c(rownames(yUp)[1:numProbes], rownames(yDown)[1:numProbes])
        })
    }

    trainingProbes <- unique(unlist(probeList))
    rawbetas <- rawbetas[trainingProbes,]

    pMeans <- colMeans(rawbetas)
    names(pMeans) <- cellInd

    form <- as.formula(sprintf("y ~ %s - 1", paste(levels(cellInd), collapse="+")))
    phenoDF <- as.data.frame(model.matrix(~cellInd-1))
    colnames(phenoDF) <- sub("cellInd", "", colnames(phenoDF))
    if(ncol(phenoDF) == 2) { # two group solution
        X <- as.matrix(phenoDF)
        coefEsts <- t(solve(t(X) %*% X) %*% t(X) %*% t(rawbetas))
    } else { # > 2 group solution
        tmp <- validationCellType(Y = rawbetas, pheno = phenoDF, modelFix = form)
        coefEsts <- tmp$coefEsts
    }

    out <- list(coefEsts = coefEsts, compTable = compTable,
                sampleMeans = pMeans)
    return(out)
}

projectCellType <- function(Y, coefCellType, contrastCellType=NULL, nonnegative=TRUE, lessThanOne=FALSE){
    if(is.null(contrastCellType))
        Xmat <- coefCellType
    else
        Xmat <- tcrossprod(coefCellType, contrastCellType)

    nCol <- dim(Xmat)[2]
    if(nCol == 2) {
        Dmat <- crossprod(Xmat)
        mixCoef <- t(apply(Y, 2, function(x) { solve(Dmat, crossprod(Xmat, x)) }))
        colnames(mixCoef) <- colnames(Xmat)
        return(mixCoef)
    } else {
        nSubj <- dim(Y)[2]

        mixCoef <- matrix(0, nSubj, nCol)
        rownames(mixCoef) <- colnames(Y)
        colnames(mixCoef) <- colnames(Xmat)

        if(nonnegative){
            if(lessThanOne) {
                Amat <- cbind(rep(-1, nCol), diag(nCol))
                b0vec <- c(-1, rep(0, nCol))
            } else {
                Amat <- diag(nCol)
                b0vec <- rep(0, nCol)
            }
            for(i in 1:nSubj) {
                obs <- which(!is.na(Y[,i]))
                Dmat <- crossprod(Xmat[obs,])
                mixCoef[i,] <- solve.QP(Dmat, crossprod(Xmat[obs,], Y[obs,i]), Amat, b0vec)$sol
            }
        } else {
            for(i in 1:nSubj) {
                obs <- which(!is.na(Y[,i]))
                Dmat <- crossprod(Xmat[obs,])
                mixCoef[i,] <- solve(Dmat, t(Xmat[obs,]) %*% Y[obs,i])
            }
        }
        return(mixCoef)
    }
}


# Creating the functions
showdensity2 <- function(pop, sample=999){
  if(pop@type=="PA"){
    pop_meth <- lapply(1:4, function(x) poppr:::.sampling(pop, ifelse(x !=4, sample, sample*2), type=pop@type, quiet=F, method=x))
  }
  else{
    pop_meth <- lapply(1:4, function(x) poppr:::.sampling(seploc(pop), ifelse(x !=4, sample, sample*2), type=pop@type, quiet=F, method=x))
  }
  df <- NULL
  methlev <- c("Original (multilocus)", "Permutataion", "Parametric Bootstrap", "Non-Parametric Bootstrap")
  invisible(lapply(1:4, function(x) df <<- rbind(df, data.frame(list(Value=unlist(pop_meth[[x]]), Index=rep(c("Ia","rbarD"), each=ifelse(x!=4,sample,sample*2)), Method=rep(methlev[x], sample*ifelse(x!=4,2,4)))))))
  method_plot <- ggplot(data=df, aes(Value, color=Method)) +
    geom_density(aes(fill=Method), alpha=0.1) +
    facet_wrap(. ~ Index, scales="free") + theme_classic()
  print(method_plot)
  return(list(DataFrame=df, Plot=method_plot))
}

showdensity <- function(pop, sample=999){
  Indexfac <- factor(1:2, levels=1:2, labels=c("I[A]","bar(r)[D]"))
  if(pop@type=="PA"){
    pop_meth <- lapply(1:4, function(x) poppr:::.sampling(pop, sample, type=pop@type, quiet=F, method=x))
  }
  else{
    pop_meth <- lapply(1:4, function(x) poppr:::.sampling(seploc(pop), sample, type=pop@type, quiet=F, method=x))
  }
  df <- NULL
  methlev <- c("Original (multilocus)", "Permutataion", "Parametric Bootstrap", "Non-Parametric Bootstrap")
  invisible(lapply(1:4, function(x) df <<- rbind(df, data.frame(list(Value=unlist(pop_meth[[x]]), Index=rep(Indexfac, each=sample), Method=rep(methlev[x], sample*2))))))
  method_plot <- ggplot(data=df, aes(Value, color=Method)) +
    geom_density(aes(fill=Method), alpha=0.1) +
    geom_rug() +
    facet_wrap(~ Index, nrow=1, scales="free") + theme_classic()
  print(method_plot)
  return(list(DataFrame=df, Plot=method_plot))
}

showplots <- function(x, name){
  cat("|", name,"\n")
  themed <- theme(axis.text.x=element_text(size = 10, angle=45, hjust=1, vjust = 1), legend.position = "bottom")
  thickens <- x + labs(title=paste(name, "over 1000 data sets")) + xlab("Sex Rate") + ylab(name) + themed
#   if(name %in% IndexNames[c(2,10)]){
#   	thickens <- thickens + geom_hline(aes(yintercept = 0.05, color = "red")) + annotate("text", x = 0, y = 0.08, label = "p = 0.05", color = "red") + coord_trans(y = "log2")
#   }
  ggsave(filename=paste(name,"pdf",sep="."), plot=thickens, width = 16, height = 8, units="in", dpi=300)
  return
}
pvalprop.rd <- function(df, alpha=0.05){
  sam <- levels(df$Samp.Size)
  sex <- levels(df$Sex.Rate)
  #cat(sam, "\n")
  #cat(sex, "\n")
  derp <- sapply(sex, function(x, alpha){
    #cat("x:",x,"\n")
    temp <- df[df$Sex.Rate == x, ]
    head(temp)
    vapply(sam, function(y, alpha){
      #cat("y:",y,"\n")
      #res <- sum(temp[temp$Samp.Size == y, ]$p.Ia <= 0.05, na.rm=TRUE)
      res <- sum(temp[temp$Samp.Size == y, ]$p.rD <= alpha, na.rm=TRUE)
      return(res)
    }, 1, alpha)
  }, alpha)
  rownames(derp) <- sam
  return(derp)
}
pvalprop.Ia <- function(df, alpha=0.05){
  sam <- levels(df$Samp.Size)
  sex <- levels(df$Sex.Rate)
  #cat(sam, "\n")
  #cat(sex, "\n")
  derp <- sapply(sex, function(x, alpha){
    #cat("x:",x,"\n")
    temp <- df[df$Sex.Rate == x, ]
    head(temp)
    vapply(sam, function(y, alpha){
      #cat("y:",y,"\n")
      res <- sum(temp[temp$Samp.Size == y, ]$p.Ia <= alpha, na.rm=TRUE)
      #res[2] <- sum(temp[temp$Samp.Size == y, ]$p.rD <= 0.05, na.rm=TRUE)
      return(res)
    }, 1, alpha)
  }, alpha)
  rownames(derp) <- sam
  return(derp)
}

splitbymethod <- function(meth, index, alpha=0.05){
  mlist <- NULL
  mlist$ml <- meth[meth$Method == levels(meth$Method)[1], ]
  mlist$perm <- meth[meth$Method == levels(meth$Method)[2], ]
  mlist$pb <- meth[meth$Method == levels(meth$Method)[3], ]
  mlist$npb <- meth[meth$Method == levels(meth$Method)[4], ]
  if(index=="Ia"){
    lapply(mlist, pvalprop.Ia, alpha)
  }
  else{
    lapply(mlist, pvalprop.rd, alpha)
  }
}

# Starting the script

library(poppr)
library(ggplot2)
x <- getfile(mult=TRUE, pattern="^final.+?csv$")
setwd(x$path)
an <- lapply(x$files, read.table, header=TRUE)

#==============================================================================#
# Edit this for the number of methods you use.
#
methan <- lapply(1:4, function(y) cbind(an[[y]], list(Method=rep(y, 40000))))
meth <- rbind(methan[[1]], methan[[2]], methan[[3]], methan[[4]])
#
# Got it?
#==============================================================================#

meth$Sex.Rate <- round(meth$Sex.Rate, 5)
meth$Sex.Rate <- factor(meth$Sex.Rate)
meth$Method <- factor(meth$Method)
meth$Samp.Size <- factor(paste("n =",meth$Samp.Size))
meth$Samp.Size <- factor(meth$Samp.Size, levels(meth$Samp.Size)[c(1,3:4,2)])

#==============================================================================#
# Hey, this is where you should make sure that you have the correct methods.
#
methlev <- c("Original (multilocus)", "Permutataion", "Parametric Bootstrap", "Non-Parametric Bootstrap")
samlev <- levels(meth$Samp.Size)
sexlev <- levels(meth$Sex.Rate)
#
#
#==============================================================================#

levels(meth$Method) <- methlev
IndexNames <- c("I[A]", "I[A] p-value", "Resampled I[A] min", "Resampled Ia max", "Resampled Ia median", "Resampled Ia mean", "Resampled Ia variance",
                "Resampled Ia standard deviation", "rbarD", "rbarD p-value", "Resampled rbarD min", "Resampled rbarD max", "Resampled rbarD median", "Resampled rbarD mean",
                "Resampled rbarD variance", "Resampled rbarD standard deviation")
names(IndexNames) <- names(meth)[10:25]
Plots <- NULL
cat("\n\nCreating Plots\n\n")

themes <-  theme_bw() +
  theme(legend.position = "bottom",
        axis.text.x = element_text(angle = 45, hjust=1, vjust=1, family = "Helvetica"),
        axis.text.y = element_text(family = "Helvetica"),
        axis.title = element_text(size = rel(2)),
        panel.grid.major.x = element_blank(),
        strip.background = element_rect(color = "black", fill = "white"),
        strip.text = element_text(face = "bold", family = "Helvetica"),
        plot.title = element_text(face = "bold", size = rel(2), vjust = 1,
                                  family = "Helvetica"))

theme2 <- theme_bw() +
  theme(legend.position = c(1, 1),
        legend.justification = c(1, 1),
        legend.title = element_text(size = rel(1), family = "Helvetica"),
        axis.text.x = element_text(angle = 45, hjust=1, vjust=1, family = "Helvetica"),
        axis.text.y = element_text(family = "Helvetica"),
        axis.title.y = element_text(angle = 0, face = "bold", size = rel(2)),
        axis.title.x = element_text(angle = 0, face = "bold", size = rel(2)),
        panel.grid.major.x = element_blank(),
        plot.title = element_text(face = "bold", size = rel(2), vjust = 1,
                                  family = "Helvetica")
        )

theme3 <- theme_bw() +
  theme(#legend.position = c(0, 1),
        #legend.justification = c(0, 1),
        legend.position = "top",
        legend.title = element_text(size = rel(1), family = "Helvetica"),
        axis.text.x = element_text(angle = 45, hjust=1, vjust=1, family = "Helvetica"),
        axis.text.y = element_text(family = "Helvetica"),
        axis.title.y = element_text(angle = 90, face = "bold", size = rel(2)),
        axis.title.x = element_text(angle = 0, face = "bold", size = rel(2)),
        panel.grid.major.x = element_blank(),
        plot.title = element_text(face = "bold", size = rel(2), vjust = 1,
                                  family = "Helvetica")
  )

meth2 <- meth[-which(is.na(meth$rbarD)), ]

Iagrey <- ggplot(meth2, aes_string(x = "Sex.Rate", y = "Ia", fill = "Samp.Size")) + geom_boxplot(outlier.shape = 20, outlier.size = 1, notch = TRUE) + theme_bw() + labs(y = expression(I[A])) + xlab("Sex Rate") + theme2 + labs(fill = "Sample Size") + scale_fill_grey(start = 0.4, end = 1) #+ labs(title = expression(paste(I[A], " over 1000 data sets")), size = rel(2), face = "bold")

rbarDgrey <- ggplot(meth2, aes_string(x = "Sex.Rate", y = "rbarD", fill = "Samp.Size")) + geom_boxplot(outlier.shape = 20, outlier.size = 1, notch = TRUE) + labs(y = expression(bar(r)[d])) + xlab("Sex Rate") + theme2 + labs(fill = "Sample Size") + scale_fill_grey(start = 0.4, end = 1) #+ labs(title = expression(paste(bar(r)[d], " over 1000 data sets")), size = rel(2), face = "bold")

Iapvalgrey <- ggplot(meth2[meth2$Method == levels(meth2$Method)[2], ], aes_string(x = "Sex.Rate", y = "p.Ia", fill = "Samp.Size")) + geom_boxplot(outlier.shape = 20, outlier.size = 1) + labs(y = expression(paste(I[A], " p-value (log scale)"))) + xlab("Sex Rate") + theme3 + labs(fill = "Sample Size") + scale_fill_grey(start = 0.4, end = 1) + coord_trans(y = "log2") + geom_hline(aes(yintercept = 0.05), linetype = 2) + annotate("text", x = 0, y = 0.04, label = "p = 0.05")

rbarDpvalgrey <- ggplot(meth2[meth2$Method == levels(meth2$Method)[2], ], aes_string(x = "Sex.Rate", y = "p.rD", fill = "Samp.Size")) + geom_boxplot(outlier.shape = 20, outlier.size = 1) + labs(y = expression(paste(bar(r)[d], " p-value (log scale)"))) + xlab("Sex Rate") + theme3 + labs(fill = "Sample Size") + scale_fill_grey(start = 0.4, end = 1) + coord_trans(y = "log2") + geom_hline(aes(yintercept = 0.05), linetype = 2) + annotate("text", x = 0, y = 0.04, label = "p = 0.05")

E5grey <- ggplot(meth2, aes_string(x = "Sex.Rate", y = "E.5", fill = "Samp.Size")) + geom_boxplot(outlier.shape = 20, outlier.size = 1, notch = TRUE) + theme_bw() + labs(y = expression(E[5])) + xlab("Sex Rate") + theme3 + labs(fill = "Sample Size") + scale_fill_grey(start = 0.4, end = 1) #+ labs(title = expression(paste(E[5], " over 1000 data sets")), size = rel(2), face = "bold")

Hexpgrey <- ggplot(meth2, aes_string(x = "Sex.Rate", y = "Hexp", fill = "Samp.Size")) + geom_boxplot(outlier.shape = 20, outlier.size = 1, notch = TRUE) + theme_bw() + labs(y = "Expected Heterozygosity") + xlab("Sex Rate") + theme3 + labs(fill = "Sample Size") + scale_fill_grey(start = 0.4, end = 1) #+ labs(title = expression(paste(E[5], " over 1000 data sets")), size = rel(2), face = "bold")

Hgrey <- ggplot(meth2, aes_string(x = "Sex.Rate", y = "H", fill = "Samp.Size")) + geom_boxplot(outlier.shape = 20, outlier.size = 1, notch = TRUE) + theme_bw() + labs(y = "Shannon-Wiener Index") + xlab("Sex Rate") + theme3 + labs(fill = "Sample Size") + scale_fill_grey(start = 0.4, end = 1) #+ labs(title = expression(paste(E[5], " over 1000 data sets")), size = rel(2), face = "bold")

Ggrey <- ggplot(meth2, aes_string(x = "Sex.Rate", y = "G", fill = "Samp.Size")) + geom_boxplot(outlier.shape = 20, outlier.size = 1, notch = TRUE) + theme_bw() + labs(y = "Stoddart and Taylor's Index") + xlab("Sex Rate") + theme3 + labs(fill = "Sample Size") + scale_fill_grey(start = 0.4, end = 1) #+ labs(title = expression(paste(E[5], " over 1000 data sets")), size = rel(2), face = "bold")

Mgrey <- ggplot(meth2, aes_string(x = "Sex.Rate", y = "MLG", fill = "Samp.Size")) + geom_boxplot(outlier.shape = 20, outlier.size = 1, notch = TRUE) + theme_bw() + labs(y = "Multilocus genotypes") + xlab("Sex Rate") + theme3 + labs(fill = "Sample Size") + scale_fill_grey(start = 0.4, end = 1) #+ labs(title = expression(paste(E[5], " over 1000 data sets")), size = rel(2), face = "bold")

quantsrd <- lapply(levels(meth2$Sex.Rate), function(x) lapply(levels(meth2$Samp.Size), function(y){
  p <- shapiro.test(meth2[meth2$Sex.Rate == x & meth2$Samp.Size == y & meth2$Method == methlev[1], ]$rbarD)$p.value
  derp <- qqnorm(meth2[meth2$Sex.Rate == x & meth2$Samp.Size == y & meth2$Method == methlev[1], ]$rbarD, main = paste("rbarD, p-value:",p,"\nSample Size:",y,"Sex Rate:",x))
  qqline(derp$y)
}))

kruskalrd <- sapply(levels(meth2$Sex.Rate), function(x){
  kruskal.test(meth2[meth2$Sex.Rate == x &
                       meth2$Method == methlev[1], ]$p.rD,
               meth2[meth2$Sex.Rate == x &
                       meth2$Method == methlev[1], ]$Samp.Size)$p.value
})

kruskalia <- sapply(levels(meth2$Sex.Rate), function(x){
  kruskal.test(meth2[meth2$Sex.Rate == x &
                       meth2$Method == methlev[1], ]$p.Ia,
               meth2[meth2$Sex.Rate == x &
                       meth2$Method == methlev[1], ]$Samp.Size)$p.value
})
kruskal <- data.frame(list(Ia = kruskalia,rbarD = kruskalrd))

lapply(names(meth)[10:25], function(derp){
  cat("|", derp,"\n")
  Plots[[derp]] <<- ggplot(meth, aes_string(x = "Sex.Rate", y = derp, fill = "Method")) +
    #geom_violin(trim=FALSE) +
    geom_boxplot(outlier.shape = 20, outlier.size = 1, notch = TRUE) +
    facet_wrap(~ Samp.Size, nrow = 2) +
  	themes +
  	ylab(IndexNames[derp]) +
  	xlab("Sex Rate")
  return(0)
  })
names(Plots) <- IndexNames

cat("\n\nPrinting Plots (May take a little while)\n\n")
invisible(lapply(IndexNames, function(x) showplots(Plots[[x]], x)))

cat("\n\nCreating the Probability of Rejection plots...rbarD\n\n")
rd.tot <- splitbymethod(meth, "rbarD", alpha=0.05)
rd.comb <- NULL
Ia.comb <- NULL
lapply(rd.tot, function(x) rd.comb <<- rbind(rd.comb, x))
rd.comb <- as.vector(rd.comb/1000)

rd.df <- data.frame(list(Percent_Reject = rd.comb,
                         Samp.Size = rep(levels(meth$Samp.Size), 10*length(methlev)),
                         Sex.Rate = rep(levels(meth$Sex.Rate), each=4*length(methlev)),
                         Method = rep(rep(levels(meth$Method), each=4), 10))
                    )
rd.df$Sex.Rate <- factor(rd.df$Sex.Rate, levels(rd.df$Sex.Rate)[c(1,9:10,2:8)])
rd.df$Samp.Size <- factor(rd.df$Samp.Size, levels(rd.df$Samp.Size)[c(1,3:4,2)])
rd.df$Method <- factor(rd.df$Method, methlev)

cat("\n\nCreating the Probability of Rejection plots...Ia\n\n")

Ia.tot <- splitbymethod(meth, "Ia", alpha=0.05)
lapply(Ia.tot, function(x) Ia.comb <<- rbind(Ia.comb, x))
Ia.comb <- as.vector(Ia.comb/1000)
Ia.df <- data.frame(list(Percent_Reject = Ia.comb,
                         Samp.Size = rep(levels(meth$Samp.Size), 10*length(methlev)),
                         Sex.Rate = rep(levels(meth$Sex.Rate), each=4*length(methlev)),
                         Method = rep(rep(levels(meth$Method), each=4), 10))
                    )
Ia.df$Sex.Rate <- factor(Ia.df$Sex.Rate, levels(Ia.df$Sex.Rate)[c(1,9:10,2:8)])
Ia.df$Samp.Size <- factor(Ia.df$Samp.Size, levels(Ia.df$Samp.Size)[c(1,3:4,2)])
Ia.df$Method <- factor(Ia.df$Method, methlev)

png("Probability_of_Rejection%03d.png", width=1024, height=1225)
rd.plot <- ggplot(rd.df, aes(x = Sex.Rate, y = Percent_Reject, color=Method))
rd.plot <- rd.plot + geom_point() + geom_hline(aes(yintercept=0.050), color="red") +
  geom_hline(aes(yintercept=0.950), color="blue") + facet_grid(Samp.Size ~ .) +
  labs(title=expression(paste("Probability of Rejecting the Null Hypothesis with ", bar(r)[D]))) +
  xlab("Sex Rate") + ylab("Probability of Null Hypothesis Rejection") +
  annotate("text", x = 1, y = 0.10, label="5% rejection", color="red") +
  annotate("text", x = 10, y = 0.90, label="95% rejection", color="blue")
print(rd.plot + geom_line(aes(group = Method)) + theme_bw())

Ia.plot <- ggplot(Ia.df, aes(x = Sex.Rate, y = Percent_Reject, color=Method))
Ia.plot <- Ia.plot + geom_point() + geom_hline(aes(yintercept=0.050), color="red") +
  geom_hline(aes(yintercept=0.950), color="blue") + facet_grid(Samp.Size ~ .) +
  labs(title=expression(paste("Probability of Rejecting the Null Hypothesis with ", I[A]))) +
  xlab("Sex Rate") + ylab("Probability of Null Hypothesis Rejection") +
	annotate("text", x = 1, y = 0.10, label="5% rejection", color="red") +
  annotate("text", x = 10, y = 0.90, label="95% rejection", color="blue")
print(Ia.plot + geom_line(aes(group = Method)) + theme_bw())

rd.plot.method <- ggplot(rd.df, aes(x = Sex.Rate, y = Percent_Reject, color=Samp.Size))
rd.plot.method <- rd.plot.method + geom_point() + geom_hline(aes(yintercept=0.050), color="red") +
  geom_hline(aes(yintercept=0.950), color="blue") + facet_grid(Method ~ .) +
  labs(title=expression(paste("Probability of Rejecting the Null Hypothesis with ", bar(r)[D]))) +
  xlab("Sex Rate") + ylab("Probability of Null Hypothesis Rejection") +
  annotate("text", x = 1, y = 0.10, label="5% rejection", color="red") +
  annotate("text", x = 10, y = 0.90, label="95% rejection", color="blue")
print(rd.plot.method + geom_line(aes(group = Samp.Size)) + theme_bw())

Ia.plot.method <- ggplot(Ia.df, aes(x = Sex.Rate, y = Percent_Reject, color=Samp.Size))
Ia.plot.method <- Ia.plot.method + geom_point() + geom_hline(aes(yintercept=0.050), color="red") +
  geom_hline(aes(yintercept=0.950), color="blue") + facet_grid(Method ~ .) +
  labs(title=expression(paste("Probability of Rejecting the Null Hypothesis with ", I[A]))) +
  xlab("Sex Rate") + ylab("Probability of Null Hypothesis Rejection") +
  annotate("text", x = 1, y = 0.10, label="5% rejection", color="red") +
  annotate("text", x = 10, y = 0.90, label="95% rejection", color="blue")
print(Ia.plot.method + geom_line(aes(group = Samp.Size)) + theme_bw())
dev.off()

#==============================================================================#
#=====================================ROC PLOTS================================#
#alphacut <- c(seq(0,0.2,0.001), seq(0.3,1,0.1))
# alphacut <- seq(0,1,0.001)
# nalpha <- length(alphacut)
#
#
# cat("Constructing Ia ROC data. This will take a while....\n")
# print(system.time(Ia.tot2 <- lapply(alphacut, function(x) splitbymethod(meth, "Ia", alpha=x))))
# cat("Constructing rbarD ROC data. Again, this will take a while...\n")
# print(system.time(rd.tot2 <- lapply(alphacut, function(x) splitbymethod(meth, "rbarD", alpha=x))))
# Ia.comb2 <- NULL
# rd.comb2 <- NULL
# cat("Combining data sets...\n")
# print(system.time(lapply(Ia.tot2, function(y) lapply(y, function(x) Ia.comb2 <<- rbind(Ia.comb2, x)))))
# print(system.time(lapply(rd.tot2, function(y) lapply(y, function(x) rd.comb2 <<- rbind(rd.comb2, x)))))
#
#
#
# Ia.comb2 <- as.vector(Ia.comb2/1000)
# Ia.df2 <- data.frame(list(Percent_Reject = Ia.comb2,
#                          Samp.Size = rep(rep(levels(meth$Samp.Size), 10*length(methlev)), nalpha),
#                          Sex.Rate = rep(rep(levels(meth$Sex.Rate), each=4*length(methlev)), each=nalpha),
#                          Method = rep(rep(rep(levels(meth$Method), each=4), 10), nalpha))
# )
# Ia.df2$Sex.Rate <- factor(Ia.df2$Sex.Rate, levels(Ia.df2$Sex.Rate)[c(1,9:10,2:8)])
# Ia.df2$Samp.Size <- factor(Ia.df2$Samp.Size, levels(Ia.df2$Samp.Size)[c(1,3:4,2)])
# Ia.df2$Method <- factor(Ia.df2$Method, methlev)
# Ia.df2$alpha <- rep(rep(alphacut, each = 16), 10)
# Ia.df2n <- Ia.df2[Ia.df2$Sex.Rate == 1, ]
# Ia.df2 <- Ia.df2[Ia.df2$Sex.Rate != 1, ]
# #nullidx <- unlist(lapply(unique(Ia.df2n$alpha), function(x) rep(which(Ia.df2n$alpha == x), 9)))
# #Ia.df2$Null_Percent <- Ia.df2n$Percent_Reject[nullidx]
# Ia.df2$Null_Percent <- rep(Ia.df2n$Percent_Reject, 9)
# write.csv(Ia.df2, file="Ia_ROC.csv", row.names=FALSE)
#
# rd.comb2 <- as.vector(rd.comb2/1000)
# rd.df2 <- data.frame(list(Percent_Reject = rd.comb2,
#                           Samp.Size = rep(rep(levels(meth$Samp.Size), 10*length(methlev)), nalpha),
#                           Sex.Rate = rep(rep(levels(meth$Sex.Rate), each=4*length(methlev)), each=nalpha),
#                           Method = rep(rep(rep(levels(meth$Method), each=4), 10), nalpha))
# )
# rd.df2$Sex.Rate <- factor(rd.df2$Sex.Rate, levels(rd.df2$Sex.Rate)[c(1,9:10,2:8)])
# rd.df2$Samp.Size <- factor(rd.df2$Samp.Size, levels(rd.df2$Samp.Size)[c(1,3:4,2)])
# rd.df2$Method <- factor(rd.df2$Method, methlev)
# rd.df2$alpha <- rep(rep(alphacut, each = 16), 10)
# rd.df2n <- rd.df2[rd.df2$Sex.Rate == 1, ]
# rd.df2 <- rd.df2[rd.df2$Sex.Rate != 1, ]
# #nullidx <- unlist(lapply(unique(rd.df2n$alpha), function(x) rep(which(rd.df2n$alpha == x), 9)))
# #rd.df2$Null_Percent <- rd.df2n$Percent_Reject[nullidx]
# rd.df2$Null_Percent <- rep(rd.df2n$Percent_Reject, 9)
# write.csv(rd.df2, file="rd_ROC.csv", row.names=FALSE)

#==============================================================================#
# Reading in and printing ROC curves
#==============================================================================#

Ia.df2 <- read.csv("Ia_ROC.csv", header=TRUE)
Ia.df2$Sex.Rate <- factor(Ia.df2$Sex.Rate, levels(meth$Sex.Rate))
Ia.df2$Samp.Size <- factor(Ia.df2$Samp.Size, levels(meth$Samp.Size))
Ia.df2$Method <- factor(Ia.df2$Method, methlev)

library(pracma)
samlev <- levels(Ia.df2$Samp.Size)

Ia.plot <- ggplot(Ia.df2, aes(x = Null_Percent, y = Percent_Reject, xlim=1))
Ia.plot <- Ia.plot +
  # geom_point(aes(color=Method, alpha=alpha)) +
  geom_line(aes(color=Method, linetype=Samp.Size)) +
  facet_wrap(~ Sex.Rate, nrow=3) +
  # facet_grid(Sex.Rate ~ Samp.Size) +
  labs(title=expression(paste("ROC analysis of ", I[A]))) +
  xlab("False Positive Fraction") + ylab("True Positive Fraction")
print(Ia.plot + theme_classic())
ggsave("ROCIa.pn", width=12, height=6, units="in")
rd.df2 <- read.csv("rd_ROC.csv", header=TRUE)
rd.df2$Sex.Rate <- factor(rd.df2$Sex.Rate, levels(meth$Sex.Rate))
rd.df2$Samp.Size <- factor(rd.df2$Samp.Size, levels(meth$Samp.Size))
rd.df2$Method <- factor(rd.df2$Method, methlev)

rd.plot <- ggplot(rd.df2, aes(x = Null_Percent, y = Percent_Reject, xlim=1))
rd.plot <- rd.plot +
#  geom_point(aes(color=Method, alpha=alpha)) +
  geom_line(aes(color=Method, linetype=Samp.Size)) +
  facet_wrap(~ Sex.Rate, nrow=3) +
#  facet_grid(Sex.Rate ~ Samp.Size) +
  labs(title=expression(paste("ROC analysis of ", bar(r)[D]))) +
  xlab("False Positive Fraction") + ylab("True Positive Fraction")
print(rd.plot + theme_classic())
ggsave("ROCrd.png", width=12, height=6, units="in")

#==============================================================================#
# Constructing data for ANOVA of the area under the ROC curve
#==============================================================================#

AUC.rd <- lapply(levels(rd.df2$Sex.Rate), function(w) sapply(methlev, function(x) sapply(samlev, function(y) trapz(rd.df2[rd.df2$Samp.Size == y & rd.df2$Method == x & rd.df2$Sex.Rate == w, ]$Null_Percent, rd.df2[rd.df2$Samp.Size == y & rd.df2$Method == x & rd.df2$Sex.Rate == w, ]$Percent_Reject))))

names(AUC.rd) <- levels(rd.df2$Sex.Rate)
AUC.rd.df <- data.frame(list(AUC = unlist(AUC.rd), Method = rep(rep(methlev, each=4), 10), Sex.Rate=rep(names(AUC.rd), each=16), Samp.Size = rep(rep(samlev, 4), 10)))

AUC.Ia <- lapply(levels(Ia.df2$Sex.Rate), function(w) sapply(methlev, function(x) sapply(samlev, function(y) trapz(Ia.df2[Ia.df2$Samp.Size == y & Ia.df2$Method == x & Ia.df2$Sex.Rate == w, ]$Null_Percent, Ia.df2[Ia.df2$Samp.Size == y & Ia.df2$Method == x & Ia.df2$Sex.Rate == w, ]$Percent_Reject))))

names(AUC.Ia) <- levels(Ia.df2$Sex.Rate)
AUC.Ia.df <- data.frame(list(AUC = unlist(AUC.Ia), Method = rep(rep(methlev, each=4), 10), Sex.Rate=rep(names(AUC.Ia), each=16), Samp.Size = rep(rep(samlev, 4), 10)))

AUC.rd.df <- read.table("rd_AUROCC.csv", sep = ",", head = TRUE)
AUC.Ia.df <- read.table("Ia_AUROCC.csv", sep = ",", head = TRUE)

Ia.TP <- aov(Percent_Reject ~ Sex.Rate + Samp.Size * Method, data=Ia.df2)
Ia.FP <- aov(Null_Percent ~ Sex.Rate + Samp.Size*Method, data=Ia.df2)
Ia.ROC.aov <- aov(AUC ~ Sex.Rate + Samp.Size + Method, data=AUC.Ia.df)
rd.TP <- aov(Percent_Reject ~ Sex.Rate + Samp.Size + Method, data=rd.df2)
rd.FP <- aov(Null_Percent ~ Sex.Rate + Samp.Size + Method, data=rd.df2)
rd.ROC.aov <- aov(AUC ~ Sex.Rate + Samp.Size + Method, data=AUC.rd.df)

#==============================================================================#
# Comparing the different methods using the original data set with the kruskal
# wallace test.
#

kruskalia.samp <- sapply(levels(meth2$Sex.Rate), function(x) sapply(samlev, function(y){
  kruskal.test(meth2[meth2$Sex.Rate == x & meth2$Samp.Size == y, ]$p.Ia,
               meth2[meth2$Sex.Rate == x & meth2$Samp.Size == y, ]$Method)$p.value
}))

kruskalrd.samp <- sapply(levels(meth2$Sex.Rate), function(x) sapply(samlev, function(y){
  kruskal.test(meth2[meth2$Sex.Rate == x & meth2$Samp.Size == y, ]$p.rD,
               meth2[meth2$Sex.Rate == x & meth2$Samp.Size == y, ]$Method)$p.value
}))

library(lawstat)
levene.boot <- c(
  `AUC for Ia` = levene.test(AUC.Ia.df$AUC, AUC.Ia.df$Method)$p.value,
  `AUC for rbarD` = levene.test(AUC.rd.df$AUC, AUC.rd.df$Method)$p.value,
  `False Positive rbarD` = levene.test(rd.df2$Null_Percent, rd.df2$Method)$p.value,
  `True Positive rbarD` = levene.test(rd.df2$Percent_Reject, rd.df2$Method)$p.value,
  `False Positive Ia` = levene.test(Ia.df2$Null_Percent, Ia.df2$Method)$p.value,
  `True Positive Ia` = levene.test(Ia.df2$Percent_Reject, Ia.df2$Method)$p.value,
  `p-value Ia` = levene.test(meth2$p.Ia, meth2$Method)$p.value,
  `p-value rbarD` = levene.test(meth2$p.rD, meth2$Method)$p.value
)

kruskal.boot <- c(
  `AUC for Ia` = kruskal.test(AUC.Ia.df$AUC, AUC.Ia.df$Method)$p.value,
  `AUC for rbarD` = kruskal.test(AUC.rd.df$AUC, AUC.rd.df$Method)$p.value,
  `False Positive rbarD` = kruskal.test(rd.df2$Null_Percent, rd.df2$Method)$p.value,
  `True Positive rbarD` = kruskal.test(rd.df2$Percent_Reject, rd.df2$Method)$p.value,
  `False Positive Ia` = kruskal.test(Ia.df2$Null_Percent, Ia.df2$Method)$p.value,
  `True Positive Ia` = kruskal.test(Ia.df2$Percent_Reject, Ia.df2$Method)$p.value,
  `p-value Ia` = kruskal.test(meth2$p.Ia, meth2$Method)$p.value,
  `p-value rbarD` = kruskal.test(meth2$p.rD, meth2$Method)$p.value
)

levene.no.boot <- c(
  `AUC for Ia` = levene.test(AUC.Ia.df[AUC.Ia.df$Method != methlev[4], ]$AUC, AUC.Ia.df[AUC.Ia.df$Method != methlev[4], ]$Method)$p.value,
  `AUC for rbarD` = levene.test(AUC.rd.df[AUC.rd.df$Method != methlev[4], ]$AUC, AUC.rd.df[AUC.rd.df$Method != methlev[4], ]$Method)$p.value,
  `False Positive rbarD` = levene.test(rd.df2[rd.df2$Method != methlev[4], ]$Null_Percent, rd.df2[rd.df2$Method != methlev[4], ]$Method)$p.value,
  `True Positive rbarD` = levene.test(rd.df2[rd.df2$Method != methlev[4], ]$Percent_Reject, rd.df2[rd.df2$Method != methlev[4], ]$Method)$p.value,
  `False Positive Ia` = levene.test(Ia.df2[Ia.df2$Method != methlev[4], ]$Null_Percent, Ia.df2[Ia.df2$Method != methlev[4], ]$Method)$p.value,
  `True Positive Ia` = levene.test(Ia.df2[Ia.df2$Method != methlev[4], ]$Percent_Reject, Ia.df2[Ia.df2$Method != methlev[4], ]$Method)$p.value,
  `p-value Ia` = levene.test(meth2[meth2$Method != methlev[4], ]$p.Ia, meth2[meth2$Method != methlev[4], ]$Method)$p.value,
  `p-value rbarD` = levene.test(meth2[meth2$Method != methlev[4], ]$p.rD, meth2[meth2$Method != methlev[4], ]$Method)$p.value
)

kruskal.no.boot <- c(
`AUC for Ia` = kruskal.test(AUC.Ia.df[AUC.Ia.df$Method != methlev[4], ]$AUC, AUC.Ia.df[AUC.Ia.df$Method != methlev[4], ]$Method)$p.value,
`AUC for rbarD` = kruskal.test(AUC.rd.df[AUC.rd.df$Method != methlev[4], ]$AUC, AUC.rd.df[AUC.rd.df$Method != methlev[4], ]$Method)$p.value,
`False Positive rbarD` = kruskal.test(rd.df2[rd.df2$Method != methlev[4], ]$Null_Percent, rd.df2[rd.df2$Method != methlev[4], ]$Method)$p.value,
`True Positive rbarD` = kruskal.test(rd.df2[rd.df2$Method != methlev[4], ]$Percent_Reject, rd.df2[rd.df2$Method != methlev[4], ]$Method)$p.value,
`False Positive Ia` = kruskal.test(Ia.df2[Ia.df2$Method != methlev[4], ]$Null_Percent, Ia.df2[Ia.df2$Method != methlev[4], ]$Method)$p.value,
`True Positive Ia` = kruskal.test(Ia.df2[Ia.df2$Method != methlev[4], ]$Percent_Reject, Ia.df2[Ia.df2$Method != methlev[4], ]$Method)$p.value,
`p-value Ia` = kruskal.test(meth2[meth2$Method != methlev[4], ]$p.Ia, meth2[meth2$Method != methlev[4], ]$Method)$p.value,
`p-value rbarD` = kruskal.test(meth2[meth2$Method != methlev[4], ]$p.rD, meth2[meth2$Method != methlev[4], ]$Method)$p.value
)

levene.df <- data.frame(list(`With Non-Parametric Bootstrap` = levene.boot, `Without Non-Parametric Bootstrap` = levene.no.boot))

kruskal.df <- data.frame(list(`With Non-Parametric Bootstrap` = kruskal.boot, `Without Non-Parametric Bootstrap` = kruskal.no.boot))

summary(Ia.TP)
summary(Ia.FP)
summary(Ia.ROC.aov)
summary(rd.TP)
summary(rd.FP)
summary(rd.ROC.aov)
#==============================================================================#

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

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

# Creating plots looking at the differences between max values of distribution
# and observed values.

rddiff <- ggplot(meth, aes(x = (rbarD - Rd.max), y = rbarD, color = Sex.Rate))

Iadiff <- ggplot(meth, aes(x = (Ia - Ia.max), y = Ia, color = Sex.Rate))

cat("Printing Observed vs. Distance from maximum value...\n")

png("Distances%d.png", width=1024, height=1225)
print(rddiff + geom_point() + facet_grid(Method ~ Samp.Size) + labs(title="Distance of observed value from theoretical distribution maximum") + ylab(expression(bar(r)[D])) + xlab(expression(bar(r)[D] - paste(scriptstyle(max), bar(r)[D]))) + theme_classic())

print(rddiff + geom_point() + facet_grid(Sex.Rate ~ Method + Samp.Size) + labs(title="Distance of observed value from theoretical distribution maximum") + ylab(expression(bar(r)[D])) + xlab(expression(bar(r)[D] - paste(scriptstyle(max), ,bar(r)[D]))) + theme_bw())

print(Iadiff + geom_point() + facet_grid(Method ~ Samp.Size) + labs(title="Distance of observed value from theoretical distribution maximum") + ylab(expression(I[A])) + xlab(expression(I[A] - paste(scriptstyle(max), I[A]))) + theme_bw())

print(Iadiff + geom_point() + facet_grid(Sex.Rate ~ Method + Samp.Size) + labs(title="Distance of observed value from theoretical distribution maximum") + ylab(expression(I[A])) + xlab(expression(I[A] - paste(scriptstyle(max), I[A]))) + theme_bw())
dev.off()

# Standard Deviations from the mean
rddiff_sd <- ggplot(meth, aes(x = (rbarD / Rd.sd), y = (rbarD), color=Sex.Rate))
Iadiff_sd <- ggplot(meth, aes(x = (Ia / Ia.sd), y = (Ia), color=Sex.Rate))

cat("Printing plots of Observed vs. SD ratio...\n")

png("SDplots%d.png", width=1024, height=1225)
print(
rddiff_sd + geom_point() + facet_grid(Method ~ Samp.Size) + labs(title="Observed/SD(Observed)
 vs.
 Observed") + ylab(expression(bar(r)[D])) + xlab(expression(frac(bar(r)[D],SD(bar(r)[D])))) + theme_bw()
)

print(
rddiff_sd + geom_point() + facet_grid(Sex.Rate ~ Method + Samp.Size) + labs(title="Observed/SD(Observed)
 vs.
 Observed") + ylab(expression(bar(r)[D])) + xlab(expression(frac(bar(r)[D],SD(bar(r)[D])))) + theme_bw()
)

print(
Iadiff_sd + geom_point() + facet_grid(Method ~ Samp.Size) + labs(title="Observed/SD(Observed)
 vs.
 Observed") + ylab(expression(I[A])) + xlab(expression(frac(I[A],SD(I[A])))) + theme_bw()
)

print(
Iadiff_sd + geom_point() + facet_grid(Sex.Rate ~ Method + Samp.Size) + labs(title="Observed/SD(Observed)
 vs.
 Observed") + ylab(expression(I[A])) + xlab(expression(frac(I[A],SD(I[A])))) + theme_bw()
)
dev.off()

# Standard Deviations from the SD
rddiff_mn <- ggplot(meth, aes(x = (rbarD / Rd.sd), y = (Rd.sd), color=Sex.Rate))
Iadiff_mn <- ggplot(meth, aes(x = (Ia / Ia.sd), y = (Ia.sd), color=Sex.Rate))

cat("Printing SD vs SD Ratio...\n")

png("SDplots_2_%d.png", width=1024, height=1225)

print(rddiff_mn + geom_point() + facet_grid(Method ~ Samp.Size) + labs(title="Observed (units = standard deviations) \n vs. \n Standard Deviation") + ylab(expression(SD(bar(r)[D]))) + xlab(expression(frac(bar(r)[D],SD(bar(r)[D])))) + theme_bw())

print(rddiff_mn + geom_point() + facet_grid(Sex.Rate ~ Method + Samp.Size) + labs(title="Observed (units = standard deviations) \n vs. \n Standard Deviation") + ylab(expression(SD(bar(r)[D]))) + xlab(expression(frac(bar(r)[D],SD(bar(r)[D])))) + theme_bw())

print(Iadiff_mn + geom_point() + facet_grid(Method ~ Samp.Size) + labs(title="Observed (units = standard deviations) \n vs. \n Standard Deviation") + ylab(expression(SD(I[A]))) + xlab(expression(frac(I[A],SD(I[A])))) + theme_bw())

print(Iadiff_mn + geom_point() + facet_grid(Sex.Rate ~ Method + Samp.Size) + labs(title="Observed (units = standard deviations) \n vs. \n Standard Deviation") + ylab(expression(SD(I[A]))) + xlab(expression(frac(I[A],SD(I[A])))) + theme_bw())
dev.off()

# Analyzing at alpha == 0.05

meth95 <- meth[which(meth$p.rD == 0.05 | meth$p.Ia == 0.05), ]

rddiff95 <- ggplot(meth95, aes(x = (rbarD - Rd.max), y = rbarD, color = Sex.Rate))
Iadiff95 <- ggplot(meth95, aes(x = (Ia - Ia.max), y = Ia, color = Sex.Rate))
rddiff95_sd <- ggplot(meth95, aes(x = (rbarD / Rd.sd), y = (Rd.sd), color=Sex.Rate))
Iadiff95_sd <- ggplot(meth95, aes(x = (Ia / Ia.sd), y = (Ia.sd), color=Sex.Rate))

ggsave(rddiff95 + geom_point() + facet_grid(Method ~ Samp.Size) + labs(title="Distance of observed value from theoretical distribution maximum \n at p = 0.05") + ylab(expression(bar(r)[D])) + xlab(expression(bar(r)[D] - paste(scriptstyle(max), ,bar(r)[D]))) + theme_bw(), file="rddiff95.png", width=8, height=9.57)
ggsave(
Iadiff95 + geom_point() + facet_grid(Method ~ Samp.Size) + labs(title="Distance of observed value from theoretical distribution maximum \n at p = 0.05") + ylab(expression(I[A])) + xlab(expression(I[A] - paste(scriptstyle(max), I[A]))) + theme_bw(), file="Iadiff95.png", width=8, height=9.57)

print(
rddiff95_sd + geom_point() + facet_grid(Method ~ Samp.Size) + labs(title="Observed/SD(Observed)
 vs.
 Observed") + ylab(expression(bar(r)[D])) + xlab(expression(frac(bar(r)[D],SD(bar(r)[D])))) + theme_bw()
)
print(
rddiff95_sd + geom_point() + facet_grid(Sex.Rate ~ Method + Samp.Size) + labs(title="Observed/SD(Observed)
 vs.
 Observed") + ylab(expression(bar(r)[D])) + xlab(expression(frac(bar(r)[D],SD(bar(r)[D])))) + theme_bw()
)
print(
Iadiff95_sd + geom_point() + facet_grid(Method ~ Samp.Size) + labs(title="Observed/SD(Observed)
 vs.
 Observed") + ylab(expression(I[A])) + xlab(expression(frac(I[A],SD(I[A])))) + theme_bw()
)
print(
Iadiff95_sd + geom_point() + facet_grid(Sex.Rate ~ Method + Samp.Size) + labs(title="Observed/SD(Observed)
 vs.
 Observed") + ylab(expression(I[A])) + xlab(expression(frac(I[A],SD(I[A])))) + theme_bw()
)