# Stephen Turner
# http://StephenTurner.us/
# http://GettingGeneticsDone.blogspot.com/

# Daniel Capurso
# UCSF
# http://www.linkedin.com/in/dcapurso

# Last major update: June 10, 2013
# R code for making manhattan plots and QQ plots from plink output files.

### This is for testing purposes. ######################################
# 	set.seed(42)
# 	nchr=22
# 	nsnps=1000
# 	d = data.frame(
# 		SNP=sapply(1:(nchr*nsnps), function(x) paste("rs",x,sep='')),
# 		CHR=rep(1:nchr,each=nsnps),
# 		BP=rep(1:nsnps,nchr),
# 		P=runif(nchr*nsnps)
# 	)
# 	### d[d$SNP=='rs20762',]$P = 1e-29
# 	top_snps = c('rs13895','rs20762')
# 	surrounding_snps = list(	as.character(d$SNP[13795:13995]),
# 							as.character(d$SNP[20662:20862]))
#
# 	pvector = d$P
# 	names(pvector) = d$SNP
#
# 	#CALL:
# 	#manhattan(d,annotate=top_snps,highlight=surrounding_snps)
# 	#qq(pvector,annotate=top_snps,highlight=top_snps)
#########################################################################

# manhattan plot using base graphics
manhattan <- function(dataframe, limitchromosomes=NULL,pt.col=c('gray10','gray50'),pt.bg=c('gray10','gray50'),
	pt.cex=0.45,pch=21,cex.axis=0.95,gridlines=F,gridlines.col='gray83',gridlines.lty=1,gridlines.lwd=1,ymax=8, ymax.soft=T, annotate=NULL,annotate.cex=0.7,annotate.font=3,
	suggestiveline=-log10(1e-5), suggestiveline.col='blue', suggestiveline.lwd=1.5, suggestiveline.lty=1,
	genomewideline=-log10(5e-8), genomewideline.col='red', genomewideline.lwd=1.5, genomewideline.lty=1,
	highlight=NULL,highlight.col=c('green3','magenta'),highlight.bg=c('green3','magenta'),  ...) {
	#============================================================================================
	######## Check data and arguments
    d = na.omit(dataframe) # omit NAs

    if (!("CHR" %in% names(d) & "BP" %in% names(d) & "P" %in% names(d))) stop("Make sure your data frame contains columns CHR, BP, and P")
    if (TRUE %in% is.na(suppressWarnings(as.numeric(d$CHR)))) warning('non-numeric, non-NA entries in CHR column of dataframe. attempting to remove..')
    if (TRUE %in% is.na(suppressWarnings(as.numeric(d$BP)))) warning('non-numeric, non-NA entries in BP column of dataframe. attempting to remove..')
	if (TRUE %in% is.na(suppressWarnings(as.numeric(d$P)))) warning('non-numeric, non-NA entries in P column of dataframe. attempting to remove..')

	d = d[!is.na(suppressWarnings(as.numeric(d$CHR))),] # remove rows with non-numeric, non-NA entries
    d = d[!is.na(suppressWarnings(as.numeric(d$BP))),]
    d = d[!is.na(suppressWarnings(as.numeric(d$P))),]

	if (!is.null(annotate)){
		if ('SNP' %in% names(d)){
			if (FALSE %in% (annotate %in% d$SNP)) stop ("D'oh! Annotate vector must be a subset of the SNP column.")
		} else {
			stop("D'oh! Dataframe must have a column $SNP with rs_ids to use annotate feature.")
		}
	}
	if (!is.numeric(annotate.cex) | annotate.cex<0) annotate.cex=0.7
	if (!is.numeric(annotate.font)) annotate.font=3

	if (is.character(gridlines.col[1]) & !(gridlines.col[1] %in% colors())) gridlines.col = 'gray83'
	if (!is.numeric(pt.cex) | pt.cex<0) pt.cex=0.45
	if (is.character(pt.col) & (FALSE %in% (pt.col %in% colors()))) pt.col = c('gray10','gray50')
	if (is.character(pt.bg) & (FALSE %in% (pt.bg %in% colors()))) pt.bg = F
	if (is.character(highlight.col) & (FALSE %in% (highlight.col %in% colors()))) highlight.col = c('green3','magenta')
	if (is.character(highlight.bg) & (FALSE %in% (highlight.bg %in% colors()))) highlight.bg = F
	if (is.character(suggestiveline.col[1]) & !(suggestiveline.col[1] %in% colors())) suggestiveline.col = 'blue'
	if (is.character(genomewideline.col[1]) & !(genomewideline.col[1] %in% colors())) genomewideline.col = 'red'

    if(!is.null(limitchromosomes)){
    	if (TRUE %in% is.na(suppressWarnings(as.numeric(limitchromosomes)))){
    		stop('limitchromosomes argument is not numeric')
    	} else {
    		d = d[d$CHR %in% as.numeric(limitchromosomes), ]
    	}
    }

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

    # Set positions, ticks, and labels for plotting
    d=subset(d[order(d$CHR, d$BP), ], (P>0 & P<=1)) # sort, and keep only 0<P<=1
    d$logp = -log10(d$P)
    d$pos=NA

    # Ymax
    if(is.na(suppressWarnings(as.numeric(ymax)))){  # not numeric
    	ymax = ceiling(max(-log10(d$P)))
    	warning('non-numeric ymax argument.')
    } else if (as.numeric(ymax) < 0){ 			# negative
    	ymax = ceiling(max(-log10(d$P)))
    	warning('negative ymax argument.')
    }
    if (ymax.soft==T){ #if soft, ymax is just the lower limit for ymax
    	ymax = max(ymax, ceiling(max(-log10(d$P))))

    	# make ymax larger if top annotate SNP is very high
    	if (!is.null(annotate)){
    		annotate.max = max(d[which(d$SNP %in% annotate),]$logp)
    		if ((ymax - annotate.max) < 0.18*ymax){
    			ymax = annotate.max + 0.18*ymax
    		}
    	}
    } #else, ymax = ymax

	## Fix for the bug where one chromosome is missing. Adds index column #####
	d$index=NA
	ind = 0
	for (i in unique(d$CHR)){
		ind = ind + 1
		d[d$CHR==i,]$index = ind
	}
	########

    nchr=length(unique(d$CHR))
    if (nchr==1) {
        d$pos=d$BP
        ticks=floor(length(d$pos))/2+1
        xlabel = paste('Chromosome',unique(d$CHR),'position')
        labs = ticks
    } else {
    	ticks = rep(NA,length(unique(d$CHR))+1)
    	ticks[1] = 0
        for (i in 1:max(d$index)) {
          	d[d$index==i, ]$pos   =    (d[d$index==i, ]$BP - d[d$index==i,]$BP[1]) +1 +ticks[i]
    		ticks[i+1] = max(d[d$index==i,]$pos)
    	}
    	xlabel = 'Chromosome'
    	labs = append(unique(d$CHR),'')
	}

    # Initialize plot
    xmax = max(d$pos) * 1.03
    xmin = max(d$pos) * -0.03
    #ymax = ceiling(ymax * 1.03)
    ymin = -ymax*0.03
    plot(0,col=F,xaxt='n',bty='n',xaxs='i',yaxs='i',xlim=c(xmin,xmax), ylim=c(ymin,ymax),
    		xlab=xlabel,ylab=expression(-log[10](italic(p))),las=1,cex.axis=cex.axis)

	# stagger labels
	blank = rep('',length(labs))
	lowerlabs = rep('',length(labs))
	upperlabs = rep('',length(labs))

	for (i in 1:length(labs)){
		if (i %% 2 == 0){
			lowerlabs[i] = labs[i]
		} else{
			upperlabs[i] = labs[i]
		}
	}

	axis(1,at=ticks,labels=blank,lwd=0,lwd.ticks=1,cex.axis=cex.axis)
	axis(1,at=ticks,labels=upperlabs,lwd=0,lwd.ticks=0,cex.axis=cex.axis,line=-0.25)
	axis(1,at=ticks,labels=lowerlabs,lwd=0,lwd.ticks=0,cex.axis=cex.axis,line=0.25)

	yvals = par('yaxp')
	yinterval = par('yaxp')[2] / par('yaxp')[3]
	axis(2,at= (seq(0,(ymax+yinterval/2),yinterval) - yinterval/2),labels=F,lwd=0,lwd.ticks=1,cex.axis=cex.axis)

    # Gridlines
	if (isTRUE(gridlines)){

		abline(v=ticks,col=gridlines.col[1],lwd=gridlines.lwd,lty=gridlines.lty) #at ticks
		abline(h=seq(0,ymax,yinterval),col=gridlines.col[1],lwd=gridlines.lwd,lty=gridlines.lty) # at labeled ticks
		#abline(h=(seq(0,ymax,yinterval) - yinterval/2),col=gridlines.col[1],lwd=1.0) # at unlabeled ticks
	}

    # Points, with optional highlighting
    pt.col = rep(pt.col,max(d$CHR))[1:max(d$CHR)]
	pt.bg = rep(pt.bg,max(d$CHR))[1:max(d$CHR)]
    d.plain = d
    if (!is.null(highlight)) {
    	if(class(highlight)!='character' & class(highlight)!='list'){
    		stop('"highlight" must be a char vector (for 1 color) or list (for multi color).')
    	}

    	if (class(highlight)=='character'){ #if char vector, make list for consistency in plotting below
    		highlight = list(highlight)
    	}

    	if ('SNP' %in% names(d)){
    		for (i in 1:length(highlight)){
				if (FALSE %in% (highlight[[i]] %in% d$SNP)) stop ("D'oh! Highlight vector/list must be a subset of the SNP column.")
			}
		} else {
			stop("D'oh! Dataframe must have a column $SNP with rs_ids to use highlight feature.")
		}

    	highlight.col = rep(highlight.col,length(highlight))[1:length(highlight)]
		highlight.bg = rep(highlight.bg,length(highlight))[1:length(highlight)]

    	for (i in 1:length(highlight)){
    		d.plain = d.plain[which(!(d.plain$SNP %in% highlight[[i]])), ]
    	}
    }

    icol=1
    for (i in unique(d.plain$CHR)) {
        with(d.plain[d.plain$CHR==i, ],points(pos, logp, col=pt.col[icol],bg=pt.bg[icol],cex=pt.cex,pch=pch,...))
        icol=icol+1
    }

    if (!is.null(highlight)){
    	for (i in 1:length(highlight)){
    		d.highlight=d[which(d$SNP %in% highlight[[i]]), ]
    		with(d.highlight, points(pos, logp, col=highlight.col[i],bg=highlight.bg[i],cex=pt.cex,pch=pch,...))
    	}
    }

    # Significance lines
    if (is.numeric(suggestiveline)) abline(h=suggestiveline, col=suggestiveline.col[1],lwd=suggestiveline.lwd,lty=suggestiveline.lty)
    if (is.numeric(genomewideline)) abline(h=genomewideline, col=genomewideline.col[1],lwd=genomewideline.lwd,lty=genomewideline.lty)

	# Annotate
	if (!is.null(annotate)){
		d.annotate = d[which(d$SNP %in% annotate),]
		text(d.annotate$pos,(d.annotate$logp + 0.019*ymax),labels=d.annotate$SNP,srt=90,cex=annotate.cex,adj=c(0,0.48),font=annotate.font)
	}

	# Box
	box()
}

## Make a pretty QQ plot of p-values ### Add ymax.soft
qq = function(pvector,gridlines=F,gridlines.col='gray83',gridlines.lwd=1,gridlines.lty=1,confidence=T,confidence.col='gray81',
        # added DE
	pt.cex=0.5,pt.col='black',pt.bg='black',pch=21,abline.col='blue',abline.lwd=1.8,abline.lty=1,ymax=8,ymax.soft=F,title="",lambda="",lambda_1000="",
	#pt.cex=0.5,pt.col='black',pt.bg='black',pch=21,abline.col='red',abline.lwd=1.8,abline.lty=1,ymax=6,ymax.soft=F,
	highlight=NULL,highlight.col=c('green3','magenta'),highlight.bg=c('green3','magenta'),
	annotate=NULL,annotate.cex=0.7,annotate.font=3,cex.axis=0.95,...) {
	#======================================================================================================
	######## Check data and arguments; create observed and expected distributions
	d = suppressWarnings(as.numeric(pvector))
	names(d) = names(pvector)
    d = d[!is.na(d)] # remove NA, and non-numeric [which were converted to NA during as.numeric()]
    d = d[d>0 & d<1] # only Ps between 0 and 1

	if (!is.null(highlight) | !is.null(annotate)){
		if (is.null(names(d))) stop("P-value vector must have names to use highlight or annotate features.")
		d = d[!is.na(names(d))]
		if (!is.null(highlight) & FALSE %in% (highlight %in% names(d))) stop ("D'oh! Highlight vector must be a subset of names(pvector).")
		if (!is.null(annotate) & FALSE %in% (annotate %in% names(d))) stop ("D'oh! Annotate vector must be a subset of names(pvector).")
	}

	d = d[order(d,decreasing=F)] # sort
	o = -log10(d)

    e = -log10( ppoints(length(d) ))
    if (!is.null(highlight) | !is.null(annotate)) names(e) = names(o) = names(d)

	if (!is.numeric(ymax) | ymax<max(o)) ymax <- max(o)

	if (!is.numeric(pt.cex) | pt.cex<0) pt.cex=0.5
	if (!is.numeric(annotate.cex) | annotate.cex<0) annotate.cex=0.7
	if (!is.numeric(annotate.font)) annotate.font=3

	if (is.character(gridlines.col[1]) & !(gridlines.col[1] %in% colors())) gridlines.col = 'gray83'
	if (is.character(confidence.col[1]) & !(confidence.col[1] %in% colors())) confidence.col = 'gray81'
	if (is.character(abline.col[1]) & !(abline.col[1] %in% colors())) abline.col = 'red'

	if (FALSE %in% (pt.col %in% colors() | !is.na(suppressWarnings(as.numeric(pt.col))) )){
		pt.col = 'black'; warning("pt.col argument(s) not recognized. Setting to default: 'black'.")
	}

	if (FALSE %in% (pt.bg %in% colors() | !is.na(suppressWarnings(as.numeric(pt.bg))) )){
		pt.bg = 'black'; warning("pt.bg argument(s) not recognized. Setting to default: 'black'.")
	}

	if (FALSE %in% (highlight.col %in% colors() | !is.na(suppressWarnings(as.numeric(highlight.col))) )){
		highlight.col = 'blue'; warning("highlight.col argument(s) not recognized. Setting to default: 'blue'.")
	}

	if (FALSE %in% (highlight.bg %in% colors() | !is.na(suppressWarnings(as.numeric(highlight.bg))) )){
		highlight.bg = 'blue'; warning("highlight.bg argument(s) not recognized. Setting to default: 'blue'.")
	}

	# Ymax
    if(is.na(suppressWarnings(as.numeric(ymax)))){  # not numeric
    	ymax = ceiling(max(o))
    	warning('non-numeric ymax argument.')
    } else if (as.numeric(ymax) < 0){ 			# negative
    	ymax = ceiling(max(o))
    	warning('negative ymax argument.')
    }
    if (ymax.soft==T){ #if soft, ymax is just the lower limit for ymax
    	ymax = max(ymax, ceiling(max(o)))
    } #else, ymax = ymax

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

	# Initialize plot
	#print('Setting up plot.')
	#print(ymax)
	xspace = 0.078
	xmax = max(e) * 1.019
    xmin = max(e) * -0.035
    #ymax = ceiling(ymax * 1.03)
    ymin = -ymax*0.03
        # added next three lines DE
	#o[o>6.0] <- 6.0
	#ymax=6.0+0.2
	#xmax=6.0+0.2
	plot(0,xlab=expression(Expected~~-log[10](italic(p))),ylab=expression(Observed~~-log[10](italic(p))),
			col=F,las=1,xaxt='n',xlim=c(xmin,xmax),ylim=c(ymin,ymax),bty='n',xaxs='i',yaxs='i',cex.axis=cex.axis)
        # added DE
	axis(side=1,labels=seq(0,6,1),at=seq(0,6,1),cex.axis=cex.axis,lwd=0,lwd.ticks=1)
	#axis(side=1,labels=seq(0,max(e),1),at=seq(0,max(e),1),cex.axis=cex.axis,lwd=0,lwd.ticks=1)

	# Grid lines
	if (isTRUE(gridlines)){
		yvals = par('yaxp')
		yticks = seq(yvals[1],yvals[2],yvals[2]/yvals[3])
		abline(v=seq(0,max(e),1),col=gridlines.col[1],lwd=gridlines.lwd,lty=gridlines.lty)
		abline(h=yticks,col=gridlines.col[1],lwd=gridlines.lwd,lty=gridlines.lty)
	}

	 #Confidence intervals
	 find_conf_intervals = function(row){
	 	i = row[1]
	 	len = row[2]
	 	if (i < 10000 | i %% 100 == 0){
	 		return(c(-log10(qbeta(0.95,i,len-i+1)), -log10(qbeta(0.05,i,len-i+1))))
	 	} else { # Speed up
	 		return(c(NA,NA))
	 	}
	 }

	 # Find approximate confidence intervals
	if (isTRUE(confidence)){
		#print('Plotting confidence intervals.')
		ci = apply(cbind( 1:length(e), rep(length(e),length(e))), MARGIN=1, FUN=find_conf_intervals)
	 	bks = append(seq(10000,length(e),100),length(e)+1)
		# added DE
	 	#bks = append(seq(1000,length(e),10),length(e)+1)
		for (i in 1:(length(bks)-1)){
	 		ci[1, bks[i]:(bks[i+1]-1)] = ci[1, bks[i]]
	 		ci[2, bks[i]:(bks[i+1]-1)] = ci[2, bks[i]]
		}
		colnames(ci) = names(e)
		# Extrapolate to make plotting prettier (doesn't affect intepretation at data points)
		slopes = c((ci[1,1] - ci[1,2]) / (e[1] - e[2]), (ci[2,1] - ci[2,2]) / (e[1] - e[2]))
		extrap_x = append(e[1]+xspace,e) #extrapolate slightly for plotting purposes only
		extrap_y = cbind( c(ci[1,1] + slopes[1]*xspace, ci[2,1] + slopes[2]*xspace), ci)

		# added DE
		polygon(c(extrap_x, rev(extrap_x)), c(extrap_y[1,], rev(extrap_y[2,])),col = confidence.col[1], border = "red")
		#polygon(c(extrap_x, rev(extrap_x)), c(extrap_y[1,], rev(extrap_y[2,])),col = confidence.col[1], border = confidence.col[1])
	}

	# Points (with optional highlighting)
	#print('Plotting data points.')
	fills = rep(pt.bg,length(o))
	borders = rep(pt.col,length(o))
	names(fills) = names(borders) = names(o)
	if (!is.null(highlight)){
		borders[highlight] = rep(NA,length(highlight))
		fills[highlight] = rep(NA,length(highlight))
	}
	points(e,o,pch=pch,cex=pt.cex,col=borders,bg=fills)
	# added DE
	title(main=title)
	text(2,1,paste("lambda=", round(lambda, 3), "; lambda_1000=", round(lambda_1000, 3), "\nN(pvals)=", length(pvector), sep=""), cex=1.5, pos=4)

	if (!is.null(highlight)){
		points(e[highlight],o[highlight],pch=pch,cex=pt.cex,col=highlight.col,bg=highlight.bg)
	}

	#Abline
        # added DE
	#segments(0,0,extrap_x,extrap_y,col=abline.col,lwd=abline.lwd,lty=abline.lty)
	abline(0,1,col=abline.col,lwd=abline.lwd,lty=abline.lty)

	# Annotate SNPs
	if (!is.null(annotate)){
		x = e[annotate] # x will definitely be the same
		y = -0.1 + apply(rbind(o[annotate],ci[1,annotate]),2,min)
		text(x,y,labels=annotate,srt=90,cex=annotate.cex,adj=c(1,0.48),font=annotate.font)
	}
	# Box
	box()
}

# Old ggplot2 code --------------------------------------------------------
#
## manhattan plot using ggplot2
# gg.manhattan = function(dataframe, title=NULL, max.y="max", suggestiveline=0, genomewideline=-log10(5e-8), size.x.labels=9, size.y.labels=10, annotate=F, SNPlist=NULL) {
# library(ggplot2)
#     if (annotate & is.null(SNPlist)) stop("You requested annotation but provided no SNPlist!")
# 	d=dataframe
# 	#limit to only chrs 1-23?
# 	d=d[d$CHR %in% 1:23, ]
# 	if ("CHR" %in% names(d) & "BP" %in% names(d) & "P" %in% names(d) ) {
# 		d=na.omit(d)
# 		d=d[d$P>0 & d$P<=1, ]
# 		d$logp = -log10(d$P)
# 		d$pos=NA
# 		ticks=NULL
# 		lastbase=0
# 		#new 2010-05-10
# 		numchroms=length(unique(d$CHR))
# 		if (numchroms==1) {
# 			d$pos=d$BP
# 		} else {
#
# 			for (i in unique(d$CHR)) {
# 				if (i==1) {
# 					d[d$CHR==i, ]$pos=d[d$CHR==i, ]$BP
# 				}	else {
# 					lastbase=lastbase+tail(subset(d,CHR==i-1)$BP, 1)
# 					d[d$CHR==i, ]$pos=d[d$CHR==i, ]$BP+lastbase
# 				}
# 				ticks=c(ticks, d[d$CHR==i, ]$pos[floor(length(d[d$CHR==i, ]$pos)/2)+1])
# 			}
# 			ticklim=c(min(d$pos),max(d$pos))
#
# 		}
# 		mycols=rep(c("gray10","gray60"),max(d$CHR))
# 		if (max.y=="max") maxy=ceiling(max(d$logp)) else maxy=max.y
# 		if (maxy<8) maxy=8
# 		if (annotate) d.annotate=d[as.numeric(substr(d$SNP,3,100)) %in% SNPlist, ]
# 		if (numchroms==1) {
# 			plot=qplot(pos,logp,data=d,ylab=expression(-log[10](italic(p))), xlab=paste("Chromosome",unique(d$CHR),"position"))
# 		}	else {
# 			plot=qplot(pos,logp,data=d, ylab=expression(-log[10](italic(p))) , colour=factor(CHR))
# 			plot=plot+scale_x_continuous(name="Chromosome", breaks=ticks, labels=(unique(d$CHR)))
# 			plot=plot+scale_y_continuous(limits=c(0,maxy), breaks=1:maxy, labels=1:maxy)
# 			plot=plot+scale_colour_manual(value=mycols)
# 		}
# 		if (annotate) 	plot=plot + geom_point(data=d.annotate, colour=I("green3"))
# 		plot=plot + opts(legend.position = "none")
# 		plot=plot + opts(title=title)
# 		plot=plot+opts(
# 			panel.background=theme_blank(),
# 			panel.grid.minor=theme_blank(),
# 			axis.text.x=theme_text(size=size.x.labels, colour="grey50"),
# 			axis.text.y=theme_text(size=size.y.labels, colour="grey50"),
# 			axis.ticks=theme_segment(colour=NA)
# 		)
# 		if (suggestiveline) plot=plot+geom_hline(yintercept=suggestiveline,colour="blue", alpha=I(1/3))
# 		if (genomewideline) plot=plot+geom_hline(yintercept=genomewideline,colour="red")
# 		plot
# 	}	else {
# 		stop("Make sure your data frame contains columns CHR, BP, and P")
# 	}
# }
#
# ## QQ plot using ggplot2
# gg.qq = function(pvector, title=NULL, spartan=F) {
# 	library(ggplot2)
# 	o = -log10(sort(pvector,decreasing=F))
# 	#e = -log10( 1:length(o)/length(o) )
# 	e = -log10( ppoints(length(pvector) ))
# 	plot=qplot(e,o, xlim=c(0,max(e)), ylim=c(0,max(o))) + stat_abline(intercept=0,slope=1, col="red")
# 	plot=plot+opts(title=title)
# 	plot=plot+scale_x_continuous(name=expression(Expected~~-log[10](italic(p))))
# 	plot=plot+scale_y_continuous(name=expression(Observed~~-log[10](italic(p))))
# 	if (spartan) plot=plot+opts(panel.background=theme_rect(col="grey50"), panel.grid.minor=theme_blank())
# 	plot
# }
#
# ## Make a qq and manhattan plot
# gg.qqman = function(data="plinkresults") {
# 	myqqplot = ggqq(data$P)
# 	mymanplot = ggmanhattan(data)
# 	ggsave(file="qqplot.png",myqqplot,w=5,h=5,dpi=100)
# 	ggsave(file="manhattan.png",mymanplot,width=12,height=9,dpi=100)
# }
#
# ## make qq and manhattan plots for a list of files
# gg.qqmanall= function(command="ls *assoc") {
# 	filelist=system(command,intern=T)
# 	datalist=NULL
# 	for (i in filelist) {datalist[[i]]=read.table(i,T)}
# 	highestneglogp=ceiling(max(sapply(datalist, function(df) max(na.omit(-log10(df$P))))))
# 	print(paste("Highest -log10(P) = ",highestneglogp),quote=F)
# 	start=Sys.time()
# 	for (i in names(datalist)) {
# 		myqqplot=ggqq(datalist[[i]]$P, title=i)
# 		ggsave(file=paste("qqplot-",    i, ".png", sep=""),myqqplot, width=5, height=5,dpi=100)
# 		mymanplot=ggmanhattan(datalist[[i]], title=i, max.y=highestneglogp)
# 		ggsave(file=paste("manhattan-", i, ".png", sep=""),mymanplot,width=12,height=9,dpi=100)
# 	}
# 	end=Sys.time()
# 	print(elapsed<-end-start)
# }


# 2. faza obdelave podatkov: Uvoz

# Uvoz podatkov

dec <- grp <- c()
dec[6:9] <- grp[10:19] <- "."
dec[10:19] <- grp[6:9] <- ","

nat <- lapply(6:18, function(leto)
  sprintf("podatki/N_%02d.csv", leto) %>%
    read_delim(delim=";", na=c("", "#", "*", "**", "***"), trim_ws=TRUE,
               locale=locale(encoding="UTF-8", decimal_mark=dec[leto],
                             grouping_mark=grp[leto]),
               col_names=FALSE, skip=1) %>% # imena stolpcev se razlikujejo, zato bomo podali svoja
    transmute(leto=2000+leto, occ_code=factor(X1),
              occ_title=str_to_sentence(X2) %>% str_replace("[*]", ""),
              emp=X4, h_mean=X6, a_mean=X7, h_median=X11, a_median=X16)) %>%
  bind_rows(read_csv2("podatki/N_19.csv", na=c("", "#", "*", "**", "***")) %>%
              transmute(leto=2019, occ_code, occ_title, emp=tot_emp,
                        h_mean, a_mean, h_median, a_median)) %>%
  unique() # nekatere vrstice se ponovijo, tako da se teh znebimo

kode<- nat %>% select(occ_code, occ_title) %>%
  group_by(occ_code) %>% slice_head(n=1)

t_e <- nat %>% select(leto,occ_code,emp)

nat.ha <- nat %>% select(occ_code, leto, h_mean, a_mean, h_median, a_median) %>%
  pivot_longer(c(-occ_code, -leto), names_to="podatek_sredina", values_to="vrednost") %>%
  separate(podatek_sredina, c("podatek", "sredina"), sep="_") %>%
  pivot_wider(names_from=podatek, values_from=vrednost)

h_mean_c <- nat.ha %>%
  mutate(state="United States") %>%
  .[c(1,2,6,3,4,5)]

st <- lapply(6:18, function(leto)
  sprintf("podatki/S_%02d.csv", leto) %>%
    read_delim(delim=";", na=c("", "#", "*", "**", "***"),
               locale=locale(encoding="UTF-8", decimal_mark=dec[leto],
                             grouping_mark=grp[leto])) %>%
    transmute(leto=2000+leto, state=STATE, occ_code=OCC_CODE, emp=TOT_EMP,
              h_mean=H_MEAN, a_mean=A_MEAN, h_median=H_MEDIAN, a_median=A_MEDIAN)) %>%
  bind_rows(read_csv2("podatki/S_19.csv", na=c("", "#", "*", "**", "***")) %>%
              transmute(leto=2019, state=area_title, occ_code, emp=tot_emp,
                        h_mean, a_mean, h_median, a_median)) %>% unique()

t_e_s <- st %>% select(leto, state, occ_code, emp)

st.ha <- st %>% select(occ_code, leto, state, h_mean, a_mean, h_median, a_median) %>%
  pivot_longer(c(-occ_code, -leto, -state), names_to="podatek_sredina", values_to="vrednost") %>%
  separate(podatek_sredina, c("podatek", "sredina"), sep="_") %>%
  pivot_wider(names_from=podatek, values_from=vrednost)

# Tabela iz wikipedije:

link <- "https://en.wikipedia.org/wiki/List_of_U.S._states_and_territories_by_GDP_per_capita"
stran <- html_session(link) %>% read_html()
tabela <- stran %>% html_nodes(xpath="//table[@class='wikitable sortable']") %>%
  .[[1]] %>% html_table(dec=",")
tabela[[1]] <- parse_number(tabela[[1]], na="—")
tabela2 <- tabela  %>% drop_na(Rank)
tabela[[1]] <- NULL
tabela <- tabela %>% pivot_longer(2:9, names_to = "leto") %>% rename(GDP=value)
tabela[[2]] <- parse_number(tabela[[2]])
GDP_by_state <- tabela

#   SLABŠI UVOZ
#uvozi <- function(ime_datoteke){
#  ime <- paste0("podatki/", ime_datoteke, ".csv")
#  tabela <- read.csv2(ime, fileEncoding = "UTF-8" , na=c("#","*","**","","***"),) %>%
#    select(1:2, 4,6,7,11,16)
#  return(tabela)
#}
# nat6 <- uvozi("N_06")
#
# nat7 <- uvozi("N_07")
#
# nat8 <- uvozi("N_08")
#
# nat9 <- uvozi("N_09")
#
# nat10 <- uvozi("N_10")
#
# nat11 <- uvozi("N_11")
#
# nat12 <- uvozi("N_12")
#
# nat13 <- uvozi("N_13")
#
# nat14 <- uvozi("N_14")
#
# nat15 <- uvozi("N_15")
#
# nat16 <- uvozi("N_16")
#
# nat17 <- uvozi("N_17")
#
# nat18 <- uvozi("N_18")

# total employment
#
#      employment1 <- function(tabela,leto){
#        total_employment <- tabela %>%
#          select(occ_title,tot_emp) %>%
#          rename(emp=tot_emp) %>%
#          mutate(leto=c(leto)) %>%
#          drop_na(emp) %>%
#          .[c(1,3,2)]
#        return(total_employment)
#      }
#
#      employment2 <- function(tabela,leto){
#        total_employment <- tabela %>%
#          select(OCC_TITLE,TOT_EMP) %>%
#          rename(occ_title=OCC_TITLE, emp=TOT_EMP) %>%
#          mutate(leto=c(leto)) %>%
#          drop_na(emp) %>%
#          .[c(1,3,2)]
#        return(total_employment)
#      }
#
#      total_employment1 <- employment1(nat6,2006)
#
#      total_employment11 <- employment1(nat7,2007)
#
#      total_employment2 <- employment1(nat8,2008)
#
#      total_employment22 <- employment1(nat9,2009)
#
#      total_employment3 <- employment2(nat10,2010)
#
#      total_employment33 <- employment2(nat11,2011)
#
#      total_employment4 <- employment2(nat12,2012)
#
#      total_employment44 <- employment2(nat13,2013)
#
#      total_employment5 <- employment2(nat14,2014)
#
#      total_employment55 <- employment2(nat15,2015)
#
#      total_employment6 <- employment2(nat16,2016)
#
#      total_employment66 <- employment2(nat17,2017)
#
#      total_employment7 <- employment2(nat18,2018)
#
#
#      t_e <- rbind(total_employment1, total_employment2, total_employment3, total_employment4,
#              total_employment5, total_employment6, total_employment7, total_employment11,
#              total_employment22, total_employment33, total_employment44, total_employment55,
#              total_employment66) %>%
#              mutate(emp2=parse_number(emp, locale=locale(decimal_mark = ",",grouping_mark = ".") )) %>%
#              arrange(emp2) %>%
#              select(1,2,4) %>%
#              rename(emp=emp2)

#       # H_MEAN
#
#       hmean1 <- function(tabela,leto){
#         h_mean <- tabela %>%
#           select(occ_title,h_mean) %>%
#           rename(HM=h_mean) %>%
#           mutate(leto=c(leto)) %>%
#           .[c(1,3,2)] %>%
#           drop_na(HM)
#         h_mean$HM <- as.numeric(as.character(h_mean$HM))
#         return(h_mean)
#       }
#
#       hmean2 <- function(tabela,leto){
#         h_mean <- tabela %>%
#           select(OCC_TITLE,H_MEAN) %>%
#           rename(occ_title=OCC_TITLE, HM=H_MEAN) %>%
#           mutate(leto=c(leto)) %>%
#           .[c(1,3,2)] %>%
#           drop_na(HM)
#         return(h_mean)
#       }
#
#
#       h_mean1 <- hmean1(nat6, 2006)
#
#       h_mean11 <- hmean1(nat7, 2007)
#
#       h_mean2 <- hmean1(nat8, 2008)
#
#       h_mean22 <- hmean1(nat9, 2009)
#
#       h_mean3 <- hmean2(nat10,2010)
#
#       h_mean33 <- hmean2(nat11,2011)
#
#       h_mean4 <- hmean2(nat12,2012)
#
#       h_mean44 <- hmean2(nat13,2013)
#
#       h_mean5 <- hmean2(nat14,2014)
#
#       h_mean55 <- hmean2(nat15,2015)
#
#       h_mean6 <- hmean2(nat16,2016)
#
#       h_mean66 <- hmean2(nat17,2017)
#
#       h_mean7 <- hmean2(nat18,2018)
#
#
#       h_mean <- rbind(h_mean1,h_mean2,h_mean3,h_mean4,h_mean6,h_mean7,
#                       h_mean11, h_mean22, h_mean33, h_mean44, h_mean55, h_mean66) %>%
#                     arrange(HM)
#
#       h_mean_c <- h_mean %>%
#         mutate(STATE="United States") %>%
#         rename(OCC_TITLE=occ_title) %>%
#     .[c(4,1,2,3)]

#     # A_MEAN
#
#     amean1 <- function(tabela,leto){
#       a_mean <- tabela %>%
#         select(occ_title,a_mean) %>%
#         rename(AM=a_mean) %>%
#         mutate(leto=c(leto)) %>%
#         drop_na(AM) %>%
#         .[c(1,3,2)]
#       return(a_mean)
#     }
#
#     amean2 <- function(tabela,leto){
#       a_mean <- tabela %>%
#         select(OCC_TITLE,A_MEAN) %>%
#         rename(occ_title=OCC_TITLE, AM=A_MEAN) %>%
#         mutate(leto=c(leto)) %>%
#         drop_na(AM) %>%
#         .[c(1,3,2)]
#       return(a_mean)
#     }
#
#     a_mean1 <- amean1(nat6, 2006)
#
#     a_mean2 <- amean1(nat8, 2008)
#
#     a_mean3 <- amean2(nat10,2010)
#
#     a_mean4 <- amean2(nat12,2012)
#
#     a_mean5 <- amean2(nat14,2014)
#
#     a_mean6 <- amean2(nat16,2016)
#
#     a_mean7 <- amean2(nat18,2018)
#
#     a_mean <- rbind(a_mean1,a_mean2,a_mean3,a_mean4,a_mean5,a_mean6,a_mean7) %>%
#             mutate(AM2=parse_number(AM, locale=locale(decimal_mark = ",",grouping_mark = ".") )) %>%
#             arrange(AM2) %>%
#             select(1,2,4) %>%
#             rename(AM=AM2)
#
# H_MEDIAN

#     hmedian1 <- function(tabela,leto){
#       h_med <- tabela %>%
#         select(occ_title,h_median) %>%
#         rename(HME=h_median) %>%
#         mutate(leto=c(leto)) %>%
#         drop_na(HME) %>%
#         .[c(1,3,2)]
#       return(h_med)
#     }
#
#     hmedian2 <- function(tabela,leto){
#       h_med <- tabela %>%
#         select(OCC_TITLE,H_MEDIAN) %>%
#         rename(occ_title=OCC_TITLE, HME=H_MEDIAN) %>%
#         mutate(leto=c(leto)) %>%
#         drop_na(HME) %>%
#         .[c(1,3,2)]
#       h_med$HME <- as.numeric(as.character(h_med$HME))
#       return(h_med)
#     }
#
#
#
#     h_median1 <- hmedian1(nat6,2006)
#
#     h_median2 <- hmedian1(nat8,2008)
#
#     h_median3 <- hmedian2(nat10,2010)
#
#     h_median4 <- hmedian2(nat12,2012)
#
#     h_median5 <- hmedian2(nat14,2014)
#
#     h_median6 <- hmedian2(nat16,2016)
#
#     h_median7 <- hmedian2(nat18,2018)
#
#     h_med <- h_med <- rbind(h_median1, h_median2, h_median3, h_median4, h_median5, h_median6, h_median7)    %>%
#             arrange(HME)
#
#    # A_MEDIAN
#
#
#    amedian1 <- function(tabela,leto){
#      a_med <- tabela %>%
#        select(occ_title,a_median) %>%
#        rename(AME=a_median) %>%
#        mutate(leto=c(leto)) %>%
#        drop_na(AME) %>%
#        .[c(1,3,2)]
#      return(a_med)
#    }
#
#    amedian2 <- function(tabela,leto){
#      a_med <- tabela %>%
#        select(OCC_TITLE,A_MEDIAN) %>%
#        rename(occ_title=OCC_TITLE, AME=A_MEDIAN) %>%
#        mutate(leto=c(leto)) %>%
#        drop_na(AME) %>%
#        .[c(1,3,2)]
#      return(a_med)
#    }
#
#    a_median1 <- amedian1(nat6,2006)
#
#    a_median2 <- amedian1(nat8,2008)
#
#    a_median3 <- amedian2(nat10,2010)
#
#    a_median4 <- amedian2(nat12,2012)
#
#    a_median5 <- amedian2(nat14,2014)
#
#    a_median6 <- amedian2(nat16,2016)
#
#    a_median7 <- amedian2(nat18,2018)
#
#    a_med <- rbind(a_median1, a_median2, a_median3, a_median4, a_median5, a_median6, a_median7) %>%
#              mutate(AME2=parse_number(AME, locale=locale(decimal_mark = ",",grouping_mark = ".") )) %>%
#              arrange(AME2) %>%
#              select(1,2,4) %>%
#              rename(AME=AME2)
#    # STATE DATA
#
#        uvozi_s1 <- function(ime_datoteke){
#          ime <- paste0("podatki/", ime_datoteke, ".csv")
#          tabela <- read.csv2(ime, fileEncoding = "UTF-8" , na=c("#","*","**","","***"),) %>%
#            select(3,5,7,9,10,14,19)
#          return(tabela)
#        }
#
#        uvozi_s2 <- function(ime_datoteke){
#          ime <- paste0("podatki/", ime_datoteke, ".csv")
#          tabela <- read.csv2(ime, fileEncoding = "UTF-8" , na=c("#","*","**","","***"),) %>%
#            select(3,5,7,11,12,16,21)
#          return(tabela)
#        }
#
#        st6 <- uvozi_s1("S_06")
#
#        st8 <- uvozi_s1("S_08")
#
#        st10 <- uvozi_s2("S_10")
#
#        st12 <- uvozi_s2("S_12")
#
#        st14 <- uvozi_s2("S_14")
#
#        st16 <- uvozi_s2("S_16")
#
#        st18 <- uvozi_s2("S_18")
#
#    # total employment
#
#
#    employment3 <- function(tabela,leto){
#      total_employment_state <- tabela %>%
#        select(STATE,OCC_TITLE,TOT_EMP) %>%
#        rename(emp=TOT_EMP) %>%
#        mutate(leto=c(leto)) %>%
#        .[c(1,3,2,4)] %>%
#        drop_na(emp)
#      return(total_employment_state)
#    }
#
#    total_employment_state_1 <- employment3(st6,2006)
#
#    total_employment_state_2 <- employment3(st8,2008)
#
#    total_employment_state_3 <- employment3(st10,2010)
#
#    total_employment_state_4 <- employment3(st12,2012)
#
#    total_employment_state_5 <- employment3(st14,2014)
#
#    total_employment_state_6 <- employment3(st16,2016)
#
#    total_employment_state_7 <- employment3(st18,2018)
#
#    t_e_s <- rbind(total_employment_state_1,total_employment_state_2,
#            total_employment_state_3, total_employment_state_4,total_employment_state_5,
#            total_employment_state_6,total_employment_state_7) %>%
#            mutate(emp2=parse_number(emp, locale=locale(decimal_mark = ",",grouping_mark = ".") )) %>%
#            arrange(emp2) %>%
#            select(1,3,4,5) %>%
#            rename(emp=emp2)

# h. mean by state

#    hmean3 <- function(tabela,leto){
#      hmean_state <- tabela %>%
#        select(STATE,OCC_TITLE,H_MEAN) %>%
#        rename(HM=H_MEAN) %>%
#        mutate(leto=c(leto)) %>%
#        .[c(1,2,4,3)] %>%
#        drop_na(HM)
#      hmean_state$HM <- as.numeric(as.character(hmean_state$HM))
#      return(hmean_state)
#    }
#
#    h_mean_state_1 <- hmean3(st6, 2006)
#
#    h_mean_state_2 <- hmean3(st8, 2008)
#
#    h_mean_state_3 <- hmean3(st10,2010)
#
#    h_mean_state_4 <- hmean3(st12,2012)
#
#    h_mean_state_5 <- hmean3(st14,2014)
#
#    h_mean_state_6 <- hmean3(st16,2016)
#
#    h_mean_state_7 <- hmean3(st18,2018)
#
#    h_mean_s <- rbind(h_mean_state_1, h_mean_state_2,h_mean_state_3,h_mean_state_4,
#                       h_mean_state_5,h_mean_state_6,h_mean_state_7) %>% arrange(HM)
#
#
#    # a. mean. by state
#
#    amean3 <- function(tabela,leto){
#      amean_state <- tabela %>%
#        select(STATE,OCC_TITLE,A_MEAN) %>%
#        rename(AM=A_MEAN) %>%
#        mutate(leto=c(leto)) %>%
#        .[c(1,2,4,3)] %>%
#        drop_na(AM)
#      return(amean_state)
#    }
#
#    a_mean_state_1 <- amean3(st6, 2006)
#
#    a_mean_state_2 <- amean3(st8, 2008)
#
#    a_mean_state_3 <- amean3(st10,2010)
#
#    a_mean_state_4 <- amean3(st12,2012)
#
#    a_mean_state_5 <- amean3(st14,2014)
#
#    a_mean_state_6 <- amean3(st16,2016)
#
#    a_mean_state_7 <- amean3(st18,2018)
#
#    a_mea_s <- rbind(a_mean_state_1, a_mean_state_2, a_mean_state_3, a_mean_state_4,
#                a_mean_state_5, a_mean_state_6, a_mean_state_7) %>%
#                mutate(AM2=parse_number(AM, locale=locale(decimal_mark = ",",grouping_mark = ".") )) %>%
#                arrange(AM2) %>%
#                select(1,2,3,5) %>%
#                rename(AM=AM2)
#
#    # H_MEDIAN
#
#    hmedian3 <- function(tabela,leto){
#      h_median_state <- tabela %>%
#        select(STATE,OCC_TITLE,H_MEDIAN) %>%
#        rename(HME=H_MEDIAN) %>%
#        mutate(leto=c(leto)) %>%
#        drop_na(HME) %>%
#        .[c(1,2,4,3)] %>%
#        drop_na(HME)
#      h_median_state$HME <- as.numeric(as.character(h_median_state$HME))
#      return(h_median_state)
#    }
#
#
#    h_median_state_1 <- hmedian3(st6,2006)
#
#    h_median_state_2 <- hmedian3(st8,2008)
#
#    h_median_state_3 <- hmedian3(st10,2010)
#
#    h_median_state_4 <- hmedian3(st12,2012)
#
#    h_median_state_5 <- hmedian3(st14,2014)
#
#    h_median_state_6 <- hmedian3(st16,2016)
#
#    h_median_state_7 <- hmedian3(st18,2018)
#
#
#    ###### TU JE NEKAJ NAROBE PRI SUMMERISE JE TREBA ŠE POPRAVITI
#
#    h_med_s <- rbind(h_median_state_1, h_median_state_2, h_median_state_3,
#                     h_median_state_4, h_median_state_5, h_median_state_6, h_median_state_7) %>%
#      arrange(HME)
#
#    # A_MEDIAN
#
#    amedian3 <- function(tabela,leto){
#      a_median_state <- tabela %>%
#        select(STATE,OCC_TITLE,A_MEDIAN) %>%
#        rename(AME=A_MEDIAN) %>%
#        mutate(leto=c(leto)) %>%
#        drop_na(AME) %>%
#        .[c(1,2,4,3)]
#      return(a_median_state)
#    }
#
#    a_median_state_1 <- amedian3(st6,2006)
#
#    a_median_state_2 <- amedian3(st8,2008)
#
#    a_median_state_3 <- amedian3(st10,2010)
#
#    a_median_state_4 <- amedian3(st12,2012)
#
#    a_median_state_5 <- amedian3(st14,2014)
#
#    a_median_state_6 <- amedian3(st16,2016)
#
#    a_median_state_7 <- amedian3(st18,2018)
#
#    a_med_s <- rbind(a_median_state_1, a_median_state_2, a_median_state_3,
#              a_median_state_4, a_median_state_5, a_median_state_6, a_median_state_7) %>%
#              mutate(AME2=parse_number(AME, locale=locale(decimal_mark = ",",grouping_mark = ".") )) %>%
#              arrange(AME2) %>%
#              select(1,2,3,5) %>%
#              rename(AME=AME2)
#
#
#    # Tabela iz wikipedije: https://en.wikipedia.org/wiki/List_of_U.S._states_and_territories_by_GDP_per_capita
#
#    link <- "https://en.wikipedia.org/wiki/List_of_U.S._states_and_territories_by_GDP_per_capita"
#    stran <- html_session(link) %>% read_html()
#    tabela <- stran %>% html_nodes(xpath="//table[@class='wikitable sortable']") %>%
#      .[[1]] %>% html_table(dec=",")
#    tabela[[1]] <- parse_number(tabela[[1]], na="—")
#    tabela2 <- tabela  %>% drop_na(Rank)
#    tabela[[1]] <- NULL
#    tabela <- tabela %>% pivot_longer(2:9, names_to = "leto") %>% rename(GDP=value)
#    tabela[[2]] <- parse_number(tabela[[2]])
#    GDP_by_state <- tabela


# ==============================================================================
#                           FUNCTIONS
# ==============================================================================
## Function to produce histrogram in a pairs plot
panel.hist <- function(x, ...) {
  usr <- par("usr"); on.exit(par(usr))
  par(usr = c(usr[1:2], 0, 1.5) )
  h <- hist(x, plot = FALSE)
  breaks <- h$breaks
  nB <- length(breaks)
  y <- h$counts
  y <- y/max(y)
  rect(breaks[-nB], 0, breaks[-1], y, col='blue', cex.main = 0.8,...)
}

## Function to produce kernel density estimate in a pairs plot
panel.density <- function(x, ...) {
  usr <- par("usr"); on.exit(par(usr))
  par(usr = c(usr[1:2], 0, 1.5) )
  den <- density(x, na.rm = T)
  rug(x, ticksize = 0.06, lwd = 1, col = 'red')
  y <- den$y; y <- y/max(y)
  x <- den$x
  lines(x, y)
}

## Function to produce correlation coefficients in a pairs plot
panel.cor <- function(x, y, digits=2, prefix="", cex.cor, ...) {
  usr <- par("usr"); on.exit(par(usr))
  par(usr = c(0, 1, 0, 1))
  r1 <- abs(cor(x, y, use ='pairwise.complete.obs', method = 'pearson'))
  r2 <- abs(cor(x, y, use ='pairwise.complete.obs', method = 'kendall'))
  txt1 <- format(c(r1, 0.123456789), digits=digits)[1]
  txt2 <- format(c(r2, 0.123456789), digits=digits)[1]
  txt1 <- paste('Pearson = ', txt1, sep='')
  txt2 <- paste('Kendall = ',txt2, sep='')
  txt <- paste(prefix, txt1, txt2, sep=" ")
  if(missing(cex.cor)) cex.cor <- 0.8/strwidth(txt)
  #text(0.5, 0.5, txt, cex = 1)
  text(0.5, 0.6, txt1)
  text(0.5, 0.4, txt2)
}

## Function to calculate the deviance (2*likelihood ratio) of two mixed models
pboot<-function(m0,m1){
  s <- simulate(m0)
  L0<-logLik(refit(m0,s))
  L1<-logLik(refit(m1,s))
  2*(L1-L0)
}

imputeLRT <- function(h0, h1, imputed.data.object) {
    if (!(length(fixef(h0)) <  length(fixef(h1))))
        stop("The first argument needs the smaller model.")
    imputed.data.list <- imputed.data.object$imputations
    m <- length(imputed.data.list)
    h0.models <- lapply(imputed.data.list,
                        function (dataset) {
                            update(h0, data = dataset)
                        })
    h0.dev.funs <- lapply(imputed.data.list,
                          function (dataset) {
                              update(h0, data = dataset,
                                     devFunOnly = TRUE)
                          })
    Q.bar.0 <-
        colMeans(do.call(rbind,
                         lapply(h0.models,
                                function (fit) {
                                    c(getME(fit, "theta"), fixef(fit))
                                })))
    h1.models <- lapply(imputed.data.list,
                        function (dataset) {
                            update(h1, data = dataset)
                        })
    h1.dev.funs <- lapply(imputed.data.list,
                          function (dataset) {
                              update(h1, data = dataset,
                                     devFunOnly = TRUE)
                          })
    Q.bar.1 <-
        colMeans(do.call(rbind,
                         lapply(h1.models,
                                function (fit) {
                                    c(getME(fit, "theta"), fixef(fit))
                                })))
    d.prime.m.bar <- mean(unlist(lapply(1:m,
                                        function(i) {
                                            anova(h0.models[[i]],
                                                  h1.models[[i]])$Chisq[2]
                                        })))
    d.L.bar <- mean(unlist(lapply(1:m,
                                  function(i) {
                                      h0.dev.funs[[i]](Q.bar.0) -
                                          h1.dev.funs[[i]](Q.bar.1)
                                  })))
    p0 <- length(Q.bar.0)
    p1 <- length(Q.bar.1)
    k <- p1 - p0
    rL <- (m + 1) / ((m - 1) * k) * (d.prime.m.bar - d.L.bar) # 3.8
    D.L <- d.L.bar / ((1 + rL) * k)                           # 3.7
    v <- k * (m - 1)
    w <- ifelse(v > 4,                                        # 2.7
                4 + (v - 4) * (1 + (1 - v/2) / rL)^2,
                v / 2 * (1 + 1/k) * (1 + 1/rL)^2)
    Pval <- 1 - pf(D.L, k, w)
                                        #  browser()
    return(list(
        D.L = D.L,
        Pval = Pval,
        rL = rL,
        d.L.bar = d.L.bar,
        d.prime.m.bar = d.prime.m.bar,
#    Q.bar.0 = Q.bar.0,
#    Q.bar.1 = Q.bar.1,
        k = k,
        w = w,
        p0 = p0,
        p1 = p1,
        m = m))
}

imputeLRT.c <- cmpfun(imputeLRT)


GetRaws <- function(df.list, var.codes) {

  # This function takes a list of hilda dataframes (1 for each wave) and hilda
  # variable codes, and returns a tibble in long format of all records, with the
  # hilda code, xwaveid, waveid, and variable value. If complete == TRUE then
  # only records with valid responses in all variables are returned

  require(dplyr)

  for (df in df.list) { # for every wave
    waveid <- substr(colnames(df)[2],1,1) # get the waveid (a, b, c, ..p)
    wave.codes <- paste0(waveid, var.codes) # update the variable codes
    wave.codes <- c('xwaveid', wave.codes) # add xwaveid to track individuals

    col.index <- which(colnames(df) %in% wave.codes) # find the column number
    df.vars <- df[, col.index] # get the columns

    df.vars %<>%
      # select(wave.codes) %>%  # this errors if no columns found
      gather(code, val, -xwaveid) %>%
      mutate(wave = waveid) #-> df.vars

    if (exists('df.long')) {
      df.long <- suppressWarnings(bind_rows(df.long, df.vars))
    } else {
      df.long <- df.vars
    }

  }
  # remove waveid from codes
  df.long %<>%filter(!is.na(code)) %>%mutate_at('code', funs(substring(code, 2, nchar(code)))) #-> df.long

  # # Recode wave as year
  # df.long$wave <- apply(df.long, 1, function(x) (which(letters == x['wave']) + 2000))
  #

  return(df.long)

  }


library(HiCdatR)

gene_frags_raw <- read.table("gene_by_fragment.tsv")
res <- aggregate(V8 ~ V4, FUN=unique, data=gene_frags_raw, simplify=FALSE)
gene_bins <- res$V8
names(gene_bins) <- res$V4

#load our contact matrix and normalize results
f.source.organism.specific.code("../FL1.R")
M <- f.load.one.sample(".", "mapped_contacts_10k_r.txt", 1e4, repetitions=50)

#generate teh gene-by-gene matrix from the contact matrix
#ther _must_ by a faster way to do this...
ngene <- length(gene_bins)
G <- matrix(0, nrow=ngene, ncol=ngene)

for(i in 1:ngene){
  for(j in i:ngene){
    v <- mean(M[ gene_bins[[i]], gene_bins[[j]] ])
    G[i,j] <- v
    G[j,i] <- v
  }
  if( i %% 500 == 0){
      # this takes a while, make sure it is still running...
      message(i)
  }
}

#util functions to work on intervals
genomic_interval <- function(chrom, start, end){
    structure(list(chrom, as.integer(start),as.integer(end)), .Names=c("chrom", "start", "end"))
}

bed_to_interval <- function(row){
    genomic_interval(row[["chrom"]], row[["start"]], row[["end"]])
}

gdist <- function(a,b){
    if(is.null(a) | is.null(b)){
        return(Inf)
    }
    if(a$chrom != b$chrom){
        return(Inf)
    }
    gap <- if (a$end > b$end) a$start - b$end else b$start - a$end
    if(gap <= 0){
        #overlap
        return(0)
    }
    gap
}

frags_dist <- function(fragA, fragB){
    min(sapply(fragA, function(x) sapply(fragB, function(y) gdist(x,y))))
}

genes_full <- read_bed("../../annotation/M3_full.bed")
gene_intervals <- apply( genes_full, 1, bed_to_interval)
gene_intervals_ordered <- gene_intervals[rownames(G)]
ngene <- length(gene_intervals_ordered)
# 1-D genome distance
D <- matrix(0, nrow=ngene, ngene)
for(i in 1:ngene){
   for(j in 1:ngene){
     D[i,j] <- gdist( gene_intervals_ordered[[i]], gene_intervals_ordered[[j]] )
    }
   if(i %% 100 == 0){
     message(i)
    }
}

cuts <- c(0,1, 5000, 20000, 100000, 1e6, 10e6, Inf)

resample_contacts <- function(nsamp, G, D){
    x <- sample(nrow(G), nsamp)
    tapply(G[x,x], cut(D[x,x], breaks=cuts, include.lowest=TRUE), mean,  na.rm=TRUE)
}

plot_v_null <- function(gene_set, G, D,nrep, return_df=TRUE){
    idx <- rownames(G) %in% gene_set
    n <- sum(idx)
    sim <- replicate(nrep, resample_contacts(n, G, D))
    null <- t(apply(sim, 1, quantile, c(0.025, 0.5, 0.975), na.rm=TRUE))
    bin <- cut(D[idx,idx], breaks=cuts, include.lowest=TRUE)
    obs <- tapply(G[idx,idx], bin, mean, na.rm=TRUE)
    df0 <- data.frame(null, obs, as.numeric(table(bin)))
    names(df0) <- c("lower", "median", "upper", "obs", "nobs")
    df0$bin <- 1:(length(cuts)-1)
    print(ggplot(df0, aes(bin, obs, ymax=upper, ymin=lower)) + geom_ribbon(fill="grey80", alpha=0.6) + geom_line() + scale_y_log10())
    if(return_df){
        return(df0)
    }
}

}
```


sum_longitudinal <- function(dat_in, src, tp_vec, var) {
    # populate var list
    if (src != "dyad") {
        label_list <- list(
            continuous ~ "COST Score",
            binary ~ "COST Binary",
            categorical ~ "COST Categorical"
        )
    } else {
        label_list <- list(
            continuous ~ "Difference in COST",
            binary ~ "Difference in Financial Toxicity",
            categorical ~ "Difference in Experience of Financial Toxicity"
        )
    }

    # select var_label from var_list
    if (var == "continuous") {
        label_var <- label_list[[1]]
    } else if (var == "binary") {
        label_var <- label_list[[2]]
    } else if (var == "categorical") {
        label_var <- label_list[[3]]
    } else {
        stop("Var not in Var List for Function")
    }

    # Build summary table
    dat <- dat_in %>%
        filter(src == {{ src }}) %>%
        filter(redcap_event_name %in% tp_vec) %>%
        tbl_summary(
            by = redcap_event_name,
            include = var,
            label = label_var,
            type = list(where(is.logical) ~ "categorical")
        )

    # label p function -> doesn't work right
    if (var == "continuous") {
        dat <- dat %>%
            add_p(test = continuous ~ "paired.t.test", group = partid)
    } else if (var == "binary") {
        dat <- dat %>%
            add_p(test = binary ~ "mcnemar.test", group = partid)
    } else {
        dat <- dat %>%
            add_p(test = categorical ~ "mcnemar.test", group = partid)
    }

    return(dat)
}


# ***********************************************************
# xmeans.r
# ***********************************************************
xmeans <- setRefClass (
	Class = "xmeans",

	contains = c ("s_kmeans", "xmeans_sub"),

	fields = c ("num_split_cluster" = "integer",
				"stack"             = "list",
				"ignore.covar"      = "logical",
				"ISHIOKA"           = "logical",
				"Cluster"           = "integer"),

	methods = list (
		initialize = function (ignore.covar_ = TRUE,
							   ISHIOKA_      = TRUE)
		{
			addPackages ()
			initFields (num_split_cluster = 0L,
						stack             = list (),
						ignore.covar      = ignore.covar_,
						ISHIOKA           = ISHIOKA_)
		},
		ishioka_xmeans = function (DATA_)
		{
			.self$splitData (.self$cleanData (DATA_))
			if (ISHIOKA)
				.self$mergeSplitedData ()
			.self$assignCluster ()
		},
		splitData = function (data)
		{
			# simple x-means
			split_data <- split2Cluster (data, ignore.covar)
			if (split_data$doSPLIT) {
				splitData (split_data$d1)
				splitData (split_data$d2)
			}
			else {
				num_split_cluster          <<- num_split_cluster + 1L
				stack[[num_split_cluster]] <<- data
			}
		},
		mergeSplitedData = function () {
			ind_order           <- .self$getDataSize_order (.self$getDataSize_eachCluster ())
			num_cluster         <- length (ind_order)
			isMerge_eachCluster <- numeric (num_cluster)
			for (i in seq_len (num_cluster - 1)) {
				i_ <- ind_order[sprintf ("%d", i)]
				if (isMerge_eachCluster[i_] == 1)
					next
				for (j in (i+1):num_cluster) {
					j_ <- ind_order[sprintf ("%d", j)]
			 		if (isMerge_eachCluster[j_] == 0) {
						merge_data <- merge2Cluster (stack[[i_]], stack[[j_]])
						if (merge_data$doMERGE) {
							stack[[i_]] <<- merge_data$D
							isMerge_eachCluster[j_] <- 1
							break
						}
					}
				}
			}
			stack             <<- stack [isMerge_eachCluster == 0]
			num_split_cluster <<- length (stack)
		},
		cleanData = function (data_)
		{
			out            <- na.omit (data_ [, sapply (data_, is.numeric)])
			rownames (out) <- 1:nrow (out)
			return (out)
		},
		getDataSize_eachCluster  = function () {
			out <- sapply (stack, nrow)
			return (out)
		},
		getDataSize_order = function (DataSize_eachCluster)
		{
			out <- seq_len (length (DataSize_eachCluster))
			out <- setNames (out, order (DataSize_eachCluster))
			return (out)
		},
		assignCluster = function ()
		{
			out <- numeric (sum (.self$getDataSize_eachCluster ()))
			ind <- lapply (stack, function (d) as.integer (rownames(d)))
			for (i in seq_along (ind))
				out[ind[[i]]] <- i
			Cluster <<- as.integer (out)
		}
	)
)


# Uvoz s spletne strani

library(XML)

# Vrne vektor nizov z odstranjenimi začetnimi in končnimi "prazninami" (whitespace)
# iz vozlišč, ki ustrezajo podani poti.
stripByPath <- function(x, path) {
  unlist(xpathApply(x, path,
                    function(y) gsub("[^[:alnum:] .,;'`‘’!+-/&()\n]", "",
                                     gsub("\\[[^]]*?\\]", "",
                                          gsub("^\\s*(.*?)\\s*$", "\\1", xmlValue(y))))))
}

  uvozi.bike <- function(){
    url.bike <- "http://en.wikipedia.org/wiki/List_of_bicycle_sharing_systems"
    doc.bike <- htmlTreeParse(url.bike, useInternalNodes=TRUE)

# Pobrišemo nevidno vsebino
for (t in getNodeSet(doc.bike, "//span[@style='display:none']|//span[@class='sortkey']")) {
  xmlValue(t) <- ""
}

# Poiščemo vse tabele v dokumentu
tabele <- getNodeSet(doc.bike, "//table")

# Iz druge tabele dobimo seznam vrstic (<tr>) neposredno pod
# trenutnim vozliščem
vrstice <- getNodeSet(tabele[[1]], "./tr")

# Seznam vrstic pretvorimo v seznam (znakovnih) vektorjev
# s porezanimi vsebinami celic (<td>) neposredno pod trenutnim vozliščem
seznam <- lapply(vrstice[2:length(vrstice)], stripByPath, "./td")
seznam <- lapply(seznam, function(x) x[-11])

# Iz seznama vrstic naredimo matriko
matrika <- matrix(unlist(seznam), nrow=length(seznam), byrow=TRUE)

# Imena stolpcev matrike dobimo iz celic glave (<th>) prve vrstice
colnames(matrika) <- gsub("\n", " ", stripByPath(vrstice[[1]], ".//th")[-11])

# Podatke iz matrike spravimo v razpredelnico
return(data.frame(matrika[,1:6],
                  Year.inaugurated = as.numeric(gsub(".*?([0-9]{4}).*", "\\1",
                                                     matrika[,7])),
                  apply(gsub(".*?([0-9]*).*", "\\1",
                             gsub(",", "", matrika[,8:9])), 2, as.numeric)))
}


#example of 'one liners' where its safer to break the explicit syntax rules in the name of style
#turn a DNA sequence into a lower case vector
s2v = function(dna_string) tolower(strsplit(dna_string, "")[[1]])
#turn a vector of DNA sequence into a string
v2s = function(dna_vec) paste(dna_vec, collapse = "")

#get a random DNA nucleotide
#the argument with a default lets this be
#used in solving two problems!
random_bp = function(exclude_base = NULL){
  bps = c('a', 't', 'g', 'c')
  if(!is.null(exclude_base)){
    bps = bps[bps != exclude_base]
  }
  sample(bps, 1)
}

# a simplified version of a function to introduce errors into DNA sequences
#by using functions, I've been able to use the random_bp to accomplish to related
#but different tasks with minimal effort
error_introduce = function(dna_string, global_mutation_rate = 0.01, global_indel_rate = 0.01){

	org_vec = s2v(dna_string)
	new_seq = c()

	for(i in 1:length(org_vec)){
		b = org_vec[[i]]
		prob = runif(1)
	    if(prob < global_mutation_rate){
    			#point mutation
    			new_b = random_bp(exclude_base=b)
    			new_seq = c(new_seq,new_b)
	    } else if ((global_mutation_rate < prob) && (prob<(global_indel_rate+global_mutation_rate))){
          #indel
          in_prob = runif(1)
          if(in_prob<0.5){
            #insertion
            #add the base
            new_seq = c(new_seq, b)
            #insert a base after
            new_seq = c(new_seq, random_bp())
          }else{
            #deletion
            #don't add anything so base is skipped
            #this 'else' statement could be omitted for brevity
          	next
          }
	    }else{
    		  new_seq = c(new_seq, b)
		}
	}

	output = v2s(new_seq)
	return(output)
}

#reusing the 'building blocks' I've made to easily do something else
random_add = function(seq, side = 3 , max = 100){
  #side says where the addition is made
  #1 = front
  #2 = back
  #3 = both
  front_seq = c()
  back_seq = c()
  if(side == 1 || side == 3){
    for(i in 1:sample.int(max, 1)){
      front_seq = c(front_seq, random_bp())
    }
  }
  if(side == 2 || side == 3){
    for(i in 1:sample.int(max, 1)){
      back_seq = c(back_seq, random_bp())
    }
  }
  return(v2s(c(front_seq, seq, back_seq)))
}

dna_string = "ctctacttgatttttggtgcatgagcaggaatagttggaatagctttaagtttactaattcgcgctgaactaggtcaacccggatctcttttaggggatgatcagatttataatgtgatcgtaaccgcccatgcctttgtaataatcttttttatggttatacctgtaataattggtggctttggcaattgacttgttcctttaataattggtgcaccagatatagcattccctcgaataaataatataagtttctggcttcttcctccttcgttcttacttctcctggcctccgcaggagtagaagctggagcaggaaccggatgaactgtatatcctcctttagcaggtaatttagcacatgctggcccctctgttgatttagccatcttttcccttcatttggccggtatctcatcaattttagcctctattaattttattacaactattattaatataaaacccccaactatttctcaatatcaaacaccattatttgtttgatctattcttatcaccactgttcttctactccttgctctccctgttcttgcagccggaattacaatattattaacagaccgcaacctcaacactacattctttgaccccgcagggggaggggacccaattctctatcaacactta"
error_introduce(dna_string)

error_introduce("ctctacttgatttttggtgcatgagcaggaatagttggaatagctttaagt")

#you can put those nice little pipes you make into a function to turn
#them into simple and reusable one liners!
library(tidyverse)
#this is matt's code from last week that uses mtcars to make a new col
mutate_df = function(df){
  df %>%
    mutate(NEW_COLUMN = mpg + cyl) %>%
    rename(new_column_new_you = NEW_COLUMN) %>%
    # rename can also be used to change the names of fixed positions
    arrange(hp) %>%
    dplyr::select(-new_column_new_you)

  return(df)
}

#all the detail is abstracted away to just this!
new_df = mutate_df(mtcars)


getwd()
workingDir <- "/home/luke/Documents/E_FEM_clean/E_FEM"
setwd(workingDir)

require(haven)
require(dplyr)

baseline <- read_dta('output/ELSA_Baseline/ELSA_Baseline_summary.dta')

cohort <- read_dta('output/ELSA_cohort/ELSA_cohort_summary.dta')

###
commit3 <- read_dta('output/COMMIT_cSmoken3/COMMIT_cSmoken3_summary.dta')

commit30 <- read_dta('output/COMMIT_cSmoken30/COMMIT_cSmoken30_summary.dta')

## Visualise the 3% intervention
plot(cohort$year, cohort$n_smoken_all, type='l', col='red')
lines(commit3$year, commit3$n_smoken_all, col='green')

plot(commit3$year, commit3$p_smoken_all, type='l', col='green')
lines(cohort$year, cohort$p_smoken_all, col='red')

plot(commit3$year, commit3$n_lunge_all, type='l', col='green')
lines(cohort$year, cohort$n_lunge_all, col='red')

plot(commit3$year, commit3$p_lunge_all, type='l', col='green')
lines(cohort$year, cohort$p_lunge_all, col='red')

plot(commit3$year, commit3$p_cancre_all, type='l', col='green')
lines(cohort$year, cohort$p_cancre_all, col='red')

plot(commit3$year, commit3$p_diabe_all, type='l', col='green')
lines(cohort$year, cohort$p_diabe_all, col='red')

## Visualise the 30% intervention
plot(cohort$year, cohort$n_smoken_all, type='l', col='red')
lines(commit30$year, commit30$n_smoken_all, col='green')

plot(commit30$year, commit30$p_smoken_all, type='l', col='green')
lines(cohort$year, cohort$p_smoken_all, col='red')

plot(commit30$year, commit30$n_lunge_all, type='l', col='green')
lines(cohort$year, cohort$n_lunge_all, col='red')

plot(commit30$year, commit30$p_cancre_all, type='l', col='green')
lines(cohort$year, cohort$p_cancre_all, col='red')

plot(commit30$year, commit30$p_diabe_all, type='l', col='green')
lines(cohort$year, cohort$p_diabe_all, col='red')

## Now work with the PSmoke_stopMult intervention
smoke_stop <- read_dta('output/Smoke_Stop_Cohort150/Smoke_Stop_Cohort150_summary.dta')

plot(smoke_stop$year, smoke_stop$p_smoken_all, type='l', col='green')
lines(cohort$year, cohort$p_smoken_all, col='red')

plot(smoke_stop$year, smoke_stop$n_smoken_all, type='l', col='green')
lines(cohort$year, cohort$n_smoken_all, col='red')

plot(smoke_stop$year, smoke_stop$p_lunge_all, type='l', col='green')
lines(cohort$year, cohort$p_lunge_all, col='red')

plot(smoke_stop$year, smoke_stop$p_cancre_all, type='l', col='green')
lines(cohort$year, cohort$p_cancre_all, col='red')

plot(smoke_stop$year, smoke_stop$p_diabe_all, type='l', col='green')
lines(cohort$year, cohort$p_diabe_all, col='red')

plot(smoke_stop$year, smoke_stop$n_smoke_stop_all, type='l', col='green')
lines(cohort$year, cohort$n_smoke_stop_all, col='red')

###########
smoke_stop_pop <- read_dta('output/Smoke_Stop_Pop/Smoke_Stop_Pop_summary.dta')

plot(smoke_stop_pop$year, smoke_stop_pop$p_smoken_all, type='l', col='green')
lines(baseline$year, baseline$p_smoken_all, col='red')

plot(smoke_stop_pop$year, smoke_stop_pop$n_smoken_all, type='l', col='green')
lines(baseline$year, baseline$n_smoken_all, col='red')

plot(smoke_stop_pop$year, smoke_stop_pop$p_lunge_all, type='l', col='green')
lines(baseline$year, baseline$p_lunge_all, col='red')

plot(smoke_stop_pop$year, smoke_stop_pop$p_cancre_all, type='l', col='green')
lines(baseline$year, baseline$p_cancre_all, col='red')

plot(smoke_stop_pop$year, smoke_stop_pop$p_diabe_all, type='l', col='green')
lines(baseline$year, baseline$p_diabe_all, col='red')

###########
SmokeStopInt <- read_dta('output/SmokeStopIntervention/SmokeStopIntervention_summary.dta')

plot(SmokeStopInt$year, SmokeStopInt$p_smoken_all, type='l', col='green')
lines(cohort$year, cohort$p_smoken_all, col='red')

plot(SmokeStopInt$year, SmokeStopInt$n_smoken_all, type='l', col='green')
lines(cohort$year, cohort$n_smoken_all, col='red')

plot(SmokeStopInt$year, SmokeStopInt$p_lunge_all, type='l', col='green')
lines(cohort$year, cohort$p_lunge_all, col='red')

plot(SmokeStopInt$year, SmokeStopInt$p_cancre_all, type='l', col='green')
lines(cohort$year, cohort$p_cancre_all, col='red')

plot(SmokeStopInt$year, SmokeStopInt$p_diabe_all, type='l', col='green')
lines(cohort$year, cohort$p_diabe_all, col='red')

tmp <- SmokeStopInt$m_endpop_all / SmokeStopInt$m_endpop_all[1]
tmp2 <- cohort$m_endpop_all / cohort$m_endpop_all[1]

plot(SmokeStopInt$year, tmp, type='l', col='green')
lines(cohort$year, tmp2, col='red')

#################################################
smoke_stop_init <- read_dta('output/Smoke_Stop_Cohort_Init/Smoke_Stop_Cohort_Init_summary.dta')

plot(smoke_stop_init$year, smoke_stop_init$p_smoken_all, type='l', col='green')
lines(cohort$year, cohort$p_smoken_all, col='red')

plot(smoke_stop_init$year, smoke_stop_init$n_smoken_all, type='l', col='green')
lines(cohort$year, cohort$n_smoken_all, col='red')

plot(smoke_stop_init$year, smoke_stop_init$p_lunge_all, type='l', col='green')
lines(cohort$year, cohort$p_lunge_all, col='red')

plot(smoke_stop_init$year, smoke_stop_init$p_cancre_all, type='l', col='green')
lines(cohort$year, cohort$p_cancre_all, col='red')

plot(smoke_stop_init$year, smoke_stop_init$p_diabe_all, type='l', col='green')
lines(cohort$year, cohort$p_diabe_all, col='red')


# -*- coding: utf-8 -*-

#' Created on Fri Apr 13 15:38:28 2018
#' R version 3.4.3 (2017-11-30)
#'
#' @group   Group 2, DM2 2018 Semester 2
#' @author: Martins T.
#' @author: Mendes R.
#' @author: Santos R.
#'

# Libs --------------------------------------------------------------------
options(warn=-1)
source("src/packages.r")
include_packs(c("dygraphs","d3heatmap","rockchalk","forcats","rJava",
                "xlsxjars","xlsx","tidyverse","stringi","stringr","ggcorrplot",
                "sm","lubridate","magrittr","ggplot2","openxlsx","RColorBrewer",
                "psych","treemap","data.table","pROC","class",'gmodels','klaR',
                "C50","caret",'gmodels',"DMwR","recipes","epiR","pubh","leaps",
                "MASS","gbm","autoimage","randomForest","settings","factoextra"
                ,"dummies","ROCR","neuralnet","sparseLDA","adabag","RWeka",
                "Metrics","lattice"))

# Performance on ROC Comparison --------------------------------------------------------------

#Linear Models Comparison
files <- paste("models/",list.files(path="models/", pattern ="glm|lda"),sep="")
for (i in 1:length(files)){load(files[i])};rm(i)
#Log Models Comparison -------------------------------------------------------

Lresults <- resamples(list("Log 13"=glm13,
                           "Log 10"=glm10,
                           "Log 7"=glm7))
                           # ,
                           # "Lda 13"=lda13,
                           # "Lda 10"=lda10,
                           # "Lda 7"=lda7))

# Boxplot
png(filename="presentations/LOGmodels.png",width=1000, height=750)
bwplot(Lresults, scales=list(cex=1.5,x="free",tck=c(0,0), y=list(cex=3)), main="LOG Models Comparison")
dev.off()

bwplot(Lresults , scales=list(cex=1.5,x="free",tck=c(0,0), y=list(cex=3)),
       main="Log Models Comparison")

#Lda Models Comparison -------------------------------------------------------

Lresults <- resamples(list(
                          "Lda 13"=lda13,
                          "Lda 10"=lda10,
                          "Lda 7"=lda7))

# Boxplot
png(filename="presentations/LDAmodels.png",width=1000, height=750)
bwplot(Lresults, scales=list(cex=1.5,x="free",tck=c(0,0), y=list(cex=3)), main="LDA Models Comparison")
dev.off()

bwplot(Lresults , scales=list(cex=1.5,x="free",tck=c(0,0), y=list(cex=3)),
       main="LDA Models Comparison")

#Non-Linear Models Comparison
files <- paste("models/",list.files(path="models/", pattern ="svm|nn"),sep="")
for (i in 1:length(files)){load(files[i])};rm(i)
#SVM Models Comparison -------------------------------------------------------

NLresults <- resamples(list("Svm 13"=svm13,
                           "Svm 10"=svm10,
                           "Svm 7"=svm7))
                           # ,
                           # "NN 13"=nn13,
                           # "NN 10"=nn10,
                           # "NN 7"=nn7))
# Boxplot
png(filename="presentations/SVMmodels.png",width=1000, height=750)
bwplot(NLresults,  main="SVM Models Comparison",
       scales=list(cex=1.5,x="free",tck=c(0,0), y=list(cex=3)))
dev.off()

bwplot(NLresults,  main="SVM Models Comparison",
       scales=list(cex=1.5,x="free",tck=c(0,0), y=list(cex=3)))

#NN Models Comparison -------------------------------------------------------

NLresults <- resamples(list(
                            "NN 13"=nn13,
                            "NN 10"=nn10,
                            "NN 7"=nn7))
# Boxplot
png(filename="presentations/NNmodels.png",width=1000, height=750)
bwplot(NLresults,  main="NN Models Comparison",
       scales=list(cex=1,x="free",tck=c(0,0), y=list(cex=3)))
dev.off()

bwplot(NLresults,  main="NN Models Comparison",
       scales=list(cex=1,x="free",tck=c(0,0), y=list(cex=3)))

#Ensemble Models Comparison
files <- paste("models/",list.files(path="models/", pattern ="cart|rf"),sep="")
for (i in 1:length(files)){load(files[i])};rm(i)
#CART Models Comparison -------------------------------------------------------

Eresults <- resamples(list("CART 13"=cart13,
                           "CART 10"=cart10,
                           "CART 7"=cart7))
                           # ,
                           # "RF 13"=rf13,
                           # "RF 10"=rf10,
                           # "RF 7"=rf7))
# Boxplot
png(filename="presentations/CARTModels.png",width=1000, height=750)
bwplot(Eresults, scales=list(cex=1,x="free",tck=c(0,0), y=list(cex=3)), main="CART Models Comparison")
dev.off()

bwplot(Eresults, scales=list(cex=1,x="free",tck=c(0,0), y=list(cex=3)), main="CART Models Comparison")

#RF Models Comparison -------------------------------------------------------

Eresults <- resamples(list(
                           "RF 13"=rf13,
                           "RF 10"=rf10,
                           "RF 7"=rf7))
# Boxplot
png(filename="presentations/RFModels.png",width=1000, height=750)
bwplot(Eresults, scales=list(cex=1,x="free",tck=c(0,0), y=list(cex=3)), main="RF Models Comparison")
dev.off()

bwplot(Eresults, scales=list(cex=1,x="free",tck=c(0,0), y=list(cex=3)), main="RF Models Comparison")

#Final Models Comparison -------------------------------------------------------

Eresults <- resamples(list(
  "SVM 13"=svm13,
  "NN 10"=nn10,
  "NN 7"=nn7))
# Boxplot
png(filename="presentations/FinalModels.png",width=1000, height=750)
bwplot(Eresults, scales=list(cex=1,x="free",tck=c(0,0), y=list(cex=3)), cex.axis = 3,main="Final Models Comparison")
dev.off()

bwplot(Eresults, scales=list(cex=1,x="free",tck=c(0,0), y=list(cex=3)), main="Final Models Comparison")


dir_script <- '2020-08-31-jsa-type-v2/'
source(paste0(dir_script, "subset.r"))

dir_figs <- "C:/Users/ejysoh/Dropbox/msc-thesis/research/thesis-amended-v1/figs-tables/"

df_describers <- get_des()
df_describers <- df_describers[spp_N_1st_auth_s >=1]

dim(df_describers)
names(df_describers)

df_describers[, c("ns_spp_N", "spp_N", "syn_spp_N")]

p1 <- ggplot(df_describers, aes(spp_N)) +
    geom_histogram(binwidth=1) +
    scale_x_continuous(breaks=seq(0, 100, 10), limits=c(0, 100)) +
    theme_minimal() +
    xlab("\nNumber of species described (valid species and synonyms)") +
    ylab("Number of PTEs")

dim(df_describers[spp_N<=10])[1]/dim(df_describers)[1]

ggsave(paste0(dir_figs, 'fig.ch1-hist.png'), p1, units="cm", width=21, height=8, dpi=300)

age <- df_describers[!is.na(dob.describer), c("dob.describer", "min")]
age$age_at_first_pub <- as.integer(age$min) - as.integer(age$dob.describer)
p2 <- ggplot(age, aes(age_at_first_pub)) +
    geom_histogram(binwidth=1) +
    # scale_x_continuous(minbreaks=seq(0, 100, 10), limits=c(0, 100)) +
    theme_minimal() +
    xlab("\nAge of first species description") + # includes valid species and synonyms
    ylab("Number of PTEs")

median(age$age_at_first_pub)
length(age$age_at_first_pub)

ggsave(paste0(dir_figs, 'fig.ch1-hist-age.png'), p2, units="cm", width=10, height=8, dpi=300)

age_at_death <- df_describers[!(is.na(dob.describer) |is.na(dod.describer)), c("dob.describer", "dod.describer")]
age_at_death$age <-
    as.integer(age_at_death$dod.describer) - as.integer(age_at_death$dob.describer)

duration <- df_describers[, c("min", "max")]
duration$duration_career <-
    as.integer(duration$max) - as.integer(duration$min)

summary(duration$duration_career)

p3 <- ggplot(duration, aes(duration_career)) +
    geom_histogram(binwidth=1) +
    # scale_x_continuous(minbreaks=seq(0, 100, 10), limits=c(0, 100)) +
    theme_minimal() +
    xlab("\nDuration between first and last species description (years)") + # includes valid species and synonyms
    ylab("Number of PTEs")

ggsave(paste0(dir_figs, 'fig.ch1-hist-career.png'), p3, units="cm", width=21, height=8, dpi=300)

duration <- df_describers[!(is.na(dob.describer) |is.na(dod.describer)), c("min", "max")]
duration$duration_career <-
    as.integer(duration$max) - as.integer(duration$min)

summary(duration$duration_career)

p4 <- ggplot(duration, aes(duration_career)) +
    geom_histogram(binwidth=1) +
    # scale_x_continuous(minbreaks=seq(0, 100, 10), limits=c(0, 100)) +
    theme_minimal() +
    xlab("\nDuration between first and last species description (years)") + # includes valid species and synonyms
    ylab("Number of PTEs")

ggsave(paste0(dir_figs, 'fig.ch1-hist-career-w-dod.png'), p4, units="cm", width=21, height=8, dpi=300)


rm(list = ls())

library(shiny)
library(htmlwidgets)
library(C3)
library(FrissIntroJSBasic)
library(plyr)

FrissHeader <- list(
  tags$a(href = "http://friss.eu/en",
         tags$img(src="friss.svg", id = "FrissLogo")
  ),
  singleton(includeCSS("www/friss.css")),
  singleton(includeScript("www/style.js")),
  singleton(includeCSS("www/app.css"))
)

# Load help contents
helpData <- read.csv("help.csv")

###
### get some fake data: random walk with drift
###

# see http://stackoverflow.com/questions/24272862/generate-random-walk-with-drift-and-or-trend-in-r

getSeries <- function( n = 100, drift = 0.1, walk = 4, scale = 100){
  y <- scale * cumsum(rnorm(n= n, mean = drift, sd=sqrt(walk)))
  return(y + abs(min(y)))
}

# make sure we get the same data each time
set.seed(100)

# helpers to center text
h3c <- function(text){
  h3(text, style = "text-align:center")
}

h4c <- function(text){
  h4(text, style = "text-align:center")
}


library(testit)

# Data
data <- kornbrot_table1
data_long <- reshape(
  data = kornbrot_table1,
  direction = "long",
  varying = c("placebo", "drug"),
  v.names = c("time"),
  idvar = "subject",
  times = c("placebo", "drug"),
  timevar = "treatment",
  new.row.names = seq_len(prod(length(c("placebo", "drug")), nrow(kornbrot_table1)))
)
data_long$subject <- factor(data_long$subject)
data_long$treatment <- factor(data_long$treatment, levels = c("placebo", "drug"))

#-------------------------------------------------------------------------------
# Argument checks return errors
#-------------------------------------------------------------------------------
assert(
  "rdt() errors if 'data' is not data.frame.",
  has_error(rdt(data = 1, formula = placebo ~ drug))
)
assert(
  "rdt() errors if 'formula' is not a formula.",
  has_error(rdt(data = data, formula = data))
)
assert(
  "rdt() errors if 'zero.method' is incorrect.",
  has_error(rdt(data = data, formula = placebo ~ drug, zero.method = "wilcoxon"))
)
assert(
  "rdt() errors if 'distribution' is incorrect.",
  has_error(rdt(data = data, formula = placebo ~ drug, distribution = "exactt"))
)
assert(
  "rdt() errors if 'alternative' is incorrect.",
  has_error(rdt(data = data, formula = placebo ~ drug, alternative = "lesser"))
)
assert(
  "rdt() errors if variable names not found in 'data'.",
  has_error(rdt(data = data, formula = placebo ~ drug2))
)
assert(
  "rdt() errors if y~x formula is misformed.",
  has_error(rdt(data = data, formula = placebo ~ drug + subject))
)
assert(
  "rdt() errors if y~x|block formula has extra variable.", {

  tmp <- data_long
  tmp$xtra <- seq_len(nrow(data_long))

  has_error(rdt(data = tmp, formula = time ~ treatment + xtra | subject))
})
assert(
  "rdt() errors if y~x|block formula uses wrong block.", {

  tmp <- data_long
  tmp$xtra <- seq_len(nrow(data_long))

  has_error(rdt(data = tmp, formula = time ~ treatment | xtra))
})
assert(
  "rdt() errors if y~x|block formula has more than 2 blocking factors.", {

  tmp <- data_long
  tmp$treatment <- factor(c("a", rep("b", 12), rep("c", 13)))

  has_error(rdt(data = tmp, formula = time ~ treatment | treatment))
})

#-------------------------------------------------------------------------------
# p-value matches Kornbrot 1990
#-------------------------------------------------------------------------------
assert(
  "rdt() returns expected p-value for wide format data.", {

  res <- rdt(
    data = data,
    formula = placebo ~ drug,
    alternative = "greater",
    distribution = "asymptotic"
  )
  isTRUE(all.equal(res$p.value, 0.1238529, tolerance = 1e-6))
})

assert(
  "rdt() returns expected p-value for transformed wide format data.", {

  res <- rdt(
    data = data,
    formula = I(60/placebo) ~ I(60/drug),
    alternative = "less",
    distribution = "asymptotic"
  )
  isTRUE(all.equal(res$p.value, 0.1238529, tolerance = 1e-6))
})

assert(
  "rdt() returns expected p-value for long format data.", {

  res <- rdt(
    data = data_long,
    formula = time ~ treatment | subject,
    alternative = "greater",
    distribution = "asymptotic"
  )
  isTRUE(all.equal(res$p.value, 0.1238529, tolerance = 1e-6))
})

assert(
  "rdt() returns expected p-value for transformed long format data.", {

  res <- rdt(
    data = data_long,
    formula = I(60/time) ~ treatment | subject,
    alternative = "less",
    distribution = "asymptotic"
  )
  isTRUE(all.equal(res$p.value, 0.1238529, tolerance = 1e-6))
})

#-------------------------------------------------------------------------------
# Blocking handles random rows
#-------------------------------------------------------------------------------
assert(
  "rdt() blocking correctly handles random rows.", {

  data_long2 <- data_long[sample(seq_len(nrow(data_long)), nrow(data_long)), ]

  res1 <- rdt(
    data = data_long,
    formula = time ~ treatment | subject
  )
  res2 <- rdt(
    data = data_long2,
    formula = time ~ treatment | subject
  )

  isTRUE(all.equal(res1$p.value, res2$p.value))
})

#-------------------------------------------------------------------------------
# Return summaries are correct
# 1. Formula
#     - y ~ x
#     - y ~ x | block
# 2. Alternative
#     - two.sided
#     - greater
#     - less
# 3. Distribution
#     - exact
#     - asymptotic
#     - approximate
# 4. zero.method
#     - Wilcoxon
#     - Pratt
#-------------------------------------------------------------------------------
assert(
  "rdt() returns correct formula.", {

  # Formula
  res <- rdt(
    data = data,
    formula = placebo ~ drug
  )
  res2 <- rdt(
    data = data_long,
    formula = time ~ treatment | subject
  )

  res$formula == "placebo ~ drug" &
    res2$formula == "time ~ treatment | subject"
})

assert(
  "rdt() returns correct alternative.", {

  # Formula
  res <- rdt(
    data = data,
    formula = placebo ~ drug,
    alternative = "two.sided"
  )
  res2 <- rdt(
    data = data,
    formula = placebo ~ drug,
    alternative = "greater"
  )
  res3 <- rdt(
    data = data,
    formula = placebo ~ drug,
    alternative = "less"
  )

  res$alternative == "True location shift of ranks (placebo - drug) is not equal to 0" &
    res2$alternative == "True location shift of ranks (placebo - drug) is greater than 0" &
    res3$alternative == "True location shift of ranks (placebo - drug) is less than 0"
})

assert(
  "rdt() returns correct distribution.", {

  # Formula
  res <- rdt(
    data = data,
    formula = placebo ~ drug,
    distribution = "exact"
  )
  res2 <- rdt(
    data = data,
    formula = placebo ~ drug,
    distribution = "asymptotic"
  )
  res3 <- rdt(
    data = data,
    formula = placebo ~ drug,
    distribution = "approximate"
  )

  res$method == "Kornbrot's Rank Difference Test using the Exact Wilcoxon-Pratt Signed-Rank Test" &
    res2$method == "Kornbrot's Rank Difference Test using the Asymptotic Wilcoxon-Pratt Signed-Rank Test" &
    res3$method == "Kornbrot's Rank Difference Test using the Approximate Wilcoxon-Pratt Signed-Rank Test"
})

assert(
  "rdt() returns correct zero-difference method.", {

  # Formula
  res <- rdt(
    data = data,
    formula = placebo ~ drug,
    zero.method = "Wilcoxon"
  )
  res2 <- rdt(
    data = data,
    formula = placebo ~ drug,
    zero.method = "Pratt"
  )

  res$method == "Kornbrot's Rank Difference Test using the Asymptotic Wilcoxon Signed-Rank Test" &
    res2$method == "Kornbrot's Rank Difference Test using the Asymptotic Wilcoxon-Pratt Signed-Rank Test"
})


##CTE534_Gráficos=group
##Imagen=raster
##Banda=number 1
##showplots
library(ggplot2)

qplot(c(Imagen[[Banda]][]), geom="histogram") +
          xlab(names(Imagen[[Banda]])) +
          ylab("Frecuencia")


##  1. Occurrence points ####

## Get occurrence points, set up modelling area

setwd("")

# sirgas for BR
sirgas <- "+proj=poly +lat_0=0 +lon_0=-54 +x_0=5000000 +y_0=10000000 +ellps=GRS80 +towgs84=0,0,0,0,0,0,0 +units=m +no_defs"
wgs <- "+proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0" # as in arcgis

library(sf)
options(sf_max.plot=1)

## import points
pcl.all <- read.csv("occ/Paraclaravis.csv", stringsAsFactors = F)
str(pcl.all)

pcl <- subset(pcl.all, !is.na(Lat) | !is.na(Lon))
str(pcl)
summary(pcl)

plot(pcl$Lon, pcl$Lat, asp = 1)

# convert to sf
pcl.sf <- st_as_sf(pcl, coords = c("Lon", "Lat"), crs = wgs)

# write to shapefile
# st_write(pcl.sf, "gis/wgs/pcl.shp")

table(cut(pcl$Year, 8))
barplot(table(cut(pcl$Year, 8)))

getData("ISO3")

cty <- c("PRY", "BRA", "ARG")
cty1List <- list()
cty0List <- list()

for(i in seq_along(cty)){

  cty1.sp <- raster::getData("GADM", country = cty[i], path = "gis/wgs", level = 1)
  cty0.sp <- raster::getData("GADM", country = cty[i], path = "gis/wgs", level = 0)

  cty1 <- st_as_sf(cty1.sp)
  cty0 <- st_as_sf(cty0.sp)

  cty1 <- st_transform(cty1, wgs)
  cty0 <- st_transform(cty0, wgs)

  cty1List[[i]] <- cty1
  cty0List[[i]] <- cty0

  rm(cty1.sp, cty0.sp, cty1, cty0)

}

cty1 <- do.call(rbind, cty1List)
cty0 <- do.call(rbind, cty0List)

cty1.sir <- st_transform(cty1, sirgas)
cty0.sir <- st_transform(cty0, sirgas)

rm(cty1List, cty0List, i, cty1, cty0)

cty0

plot(st_geometry(cty0), col = NA)
plot(st_geometry(pcl.sf), col = "darkred", pch= 20, add = T)

plot(st_geometry(pcl.sf), col = "darkred", pch= 20, add = F)
plot(st_geometry(cty0), col = NA, add = T)

## Make sure all points are within ecoregion, country, etc
## convert all to sirgas (check UTM  cells if applicable)

pcl.sir <- st_transform(pcl.sf, sirgas)

# Make model area
# import BL shapefile
## Downloaded from IUCN - requires permission from Birdlife
bl <- st_read("gis/wgs/claravis_geof_BL.shp")
bl.sirgas <- st_transform(bl, sirgas)
# plot(st_geometry(bl), add = T)

# buffer around unioned points
pcl.buff <- st_buffer(st_convex_hull(st_union(pcl.sir)), dist = 50000)

plot(st_geometry(pcl.sir), col = "darkred", pch= 20, add = F)
plot(st_geometry(cty0.sir), col = NA, add = T)
plot(st_geometry(pcl.buff), col = NA, add = T)

plot(st_geometry(bl.sirgas), border = "darkgreen", add = T)

## add to BL extnte (union BL first)
aoi <- st_buffer(st_convex_hull(st_union(st_union(bl.sirgas), pcl.buff)), 5000)

## get extents form pcl.buff for aoi
aoi
plot(aoi, add = T, border = "blue")

st_bbox((aoi))

aoi.ext <- adjExt(st_bbox(aoi), d = 1000, outF = "Extent")

r <- raster(aoi.ext, crs = sirgas, res = 1000)
r

r[] <- 1

msk.aoi <- raster::mask(r, st_as_sf(aoi))
plot(msk.aoi)

save(pcl.sir, msk.aoi, cty1.sir, cty0.sir, bl.sirgas, file = "gis/occ_aoi.rdata")

## EOO in different time bands
load("gis/occ_aoi.rdata")

ch_all <- st_convex_hull(st_union(pcl.sir))

st_area(ch_all) / 1000000
# 834,642.8 # km2

ch_1990 <- st_convex_hull(st_union(subset(pcl.sir, Year >= 1990)))
st_area(ch_1990) /1000000
# 277,650 km2
sum(pcl.sir$Year >= 1990) # 14

ch_2005 <- st_convex_hull(st_union(subset(pcl.sir, Year >= 2005)))
st_area(ch_2005) / 1000000
# 95,045.97 km
sum(pcl.sir$Year >= 2005) # 6

st_write(ch_all, "gis/s_sir/ch_all.shp")
st_write(ch_2005, "gis/s_sir/ch_2005.shp", delete_layer = T)
st_write(ch_1990, "gis/s_sir/ch_1990.shp", delete_layer = T)

## Absence data...
## from ebird_zeros_v3_2020_pcl.r
load("occ/ebird/ebird_absences.rdata") # ebd.zf, ebird.data, ebird.a
rm(ebd.zf)
# ebird.a is sf object of just PWGD absences

## cut to study areas
msk.aoi
plot(msk.aoi)
aoi.Ind <- raster::extract(msk.aoi, ebird.a)
table(aoi.Ind, useNA = "always")
head(aoi.Ind==1)

# filter just in study area
ebird.aoi <- ebird.a[!is.na(aoi.Ind),]

plot(ebird.aoi, add = T, pch = ".")

save(ebird.aoi, file = "ebirdAbsences_in_aoi.rdata")

st_write(ebird.aoi, "gis/s_sir/absences_aoi.shp", delete_layer = TRUE)

barplot(table(ebird.aoi$year), las = 2)

table(cut(ebird.aoi$year, breaks = c(0, 1990, 2000, 2010, 2020)))


# install.packages("devtools", dependencies = TRUE, INSTALL_opts = '--no-lock')
# install.packages("rjson")
# library(devtools)

# if("devtools" %in% rownames(installed.packages()) == FALSE) {
#     install.packages("devtools", dependencies = TRUE, INSTALL_opts = '--no-lock')
# }
# library("devtools")
#if("SPEI" %in% rownames(installed.packages()) == FALSE) {
#    install.packages('SPEI', dependencies = TRUE, INSTALL_opts = '--no-lock')
#}
library("SPEI")
#if("rjson" %in% rownames(installed.packages()) == FALSE) {
#    install.packages("rjson", dependencies = TRUE, INSTALL_opts = '--no-lock')
#}
library("rjson")

args <- commandArgs(trailingOnly = TRUE)
name <- args[1]
lat <- as.numeric(args[2])

rcp <- c("rcp26", "rcp45", "rcp85")
years <- c(2050, 2100)
speiData <- data.frame(matrix(ncol = 7, nrow = 60))
colnames(speiData) <- c("date", paste0("rcp26", "_", years), paste0("rcp45", "_", years), paste0("rcp85", "_", years))
speiData["date"] <- format(seq(as.Date("2046-01-01"), as.Date("2050-12-01"), "month"), "%Y-%m")

# Calculate potential evapotranspiration using penman for a combined time frame
# between 2046 - 2050 and 2096 - 2100
for(r in rcp) {
    for(year in years) {
        data <- fromJSON(file = file.path("./portfolio/climate_risk_dash/data/temp", paste0(name, "_", r, "_", year, ".json")))
        pen <- penman(Tmin = data$tasmin, Tmax = data$tasmax, U2 = data$sfcWind, lat = lat, Rs = data$rsds, RH = data$hurs, P = data$ps)
        p <- data$pr - pen
        speiData[paste0(r, "_", year)] <- spei(p, 12)$fitted
        print(year)
    }
}
write.csv(speiData, file = file.path("./portfolio/climate_risk_dash/report", paste0(name, "_speiData.csv")))


source('https://raw.githubusercontent.com/laurencelin/Date_analysis/master/LIB_dailytimeseries3.R')
source('https://raw.githubusercontent.com/laurencelin/Date_analysis/master/LIB_misc.r')
source('https://raw.githubusercontent.com/laurencelin/R-coded-scripts-for-RHESSys-calibration/master/LIB_RHESSys_modelBehavior7.R')
source('https://raw.githubusercontent.com/laurencelin/R-coded-scripts-for-RHESSys-calibration/master/LIB_RHESSys_modelFittness7.R')
source('https://raw.githubusercontent.com/laurencelin/R-coded-scripts-for-RHESSys-calibration/master/LIB_RHESSys_modelPlot_7.r')
library(MASS)

## -------------------------------------------------------------------------------------------------------------------------------------------------------------
arg=commandArgs(T)

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

startingDate=as.Date("1990-10-1") #,
endingDate=as.Date("2011-9-30") #,
period=seq.Date(from=startingDate, to=endingDate ,by="day")

calobs_ = read.csv(paste('path',sep=""),stringsAsFactors=F);
calobsNonZero = sapply(calobs_[,'mmd'],can.be.numeric) & !is.na(calobs_[,'mmd']) & calobs_[,'mmd']> 0 & sapply(calobs_[,'mmd'],can.be.numeric);
calobs = calobs_[calobsNonZero,]
calobs.date0 = as.Date(paste(calobs$day, calobs$month, calobs$year,sep="-"),format="%d-%m-%Y")

rhessys_SingleFile = read.table("path",header=T,skip=0,sep=' ')

	rhessys_SingleFile.date=as.Date(paste(rhessys_SingleFile$day, rhessys_SingleFile$month, rhessys_SingleFile$year,sep="-"),format="%d-%m-%Y")
	plotTime = intersectDate(list(rhessys_SingleFile.date, calobs.date0, period)) ## "2010-10-01" "2017-09-30"
	rhessys.dtsm = match(plotTime, rhessys_SingleFile.date)
	calobs.dtsm = match(plotTime, calobs.date0)
	DTStable = dailyTimeSeries(plotTime)
	matchYears = range(DTStable$wy)

	w = modelFittness( as.numeric(calobs[calobs.dtsm,'mmd']), rhessys_SingleFile[rhessys.dtsm,], DTStable);
	round(w$FittnessList,2)

	##---------------------------------------- Diagnosis
	dev.new(width=14, height=8)
	layout(matrix(1:4,nrow=4));
	par(mar=c(0,3,1,3))
	plot(plotTime, rhessys_SingleFile[rhessys.dtsm,'precip'], col='lightblue', lwd=2,type='l', ylab='',xaxt='n',bty='n', ylim=rev(range(rhessys_SingleFile[rhessys.dtsm,'precip'])))
	abline(h=0)
	par(new = TRUE)
	plot(plotTime, rhessys_SingleFile[rhessys.dtsm,'tmin'], col=t_col('lightblue1'), bty='l',lty=2, type='l', ylim=c(-20,40), yaxt='n', bty='n',xaxt='n')
	lines(plotTime, rhessys_SingleFile[rhessys.dtsm,'tmax'], col= t_col('lightpink'), lty=2)
	lines(plotTime, rhessys_SingleFile[rhessys.dtsm,'tavg'], col= t_col('gray'))
	abline(h=0, lty=2, col='gray')
	axis(4)
	par(mar=c(0,3,0,3))
	upper = max(rhessys_SingleFile[rhessys.dtsm,'streamflow'],calobs[calobs.dtsm,'mmd'])
	lower = min(rhessys_SingleFile[rhessys.dtsm,'streamflow'],calobs[calobs.dtsm,'mmd'])
	plot(plotTime, rhessys_SingleFile[rhessys.dtsm,'streamflow'], col='blue', lwd=2,type='l', ylab='', ylim=c(lower ,upper),bty='n',xaxt='n')
	lines(plotTime, calobs[calobs.dtsm,'mmd'], col='red')
	lines(plotTime, rhessys_SingleFile[rhessys.dtsm,'pet'], col='gray')
	lines(plotTime, rhessys_SingleFile[rhessys.dtsm,'evap']+rhessys_SingleFile[rhessys.dtsm,'trans'], col='green')
	lines(plotTime, rhessys_SingleFile[rhessys.dtsm,'X.sat_area'], lty=2,col=gray(0.8))
	lines(plotTime, rhessys_SingleFile[rhessys.dtsm,'snowpack'],col='lightblue')
	par(mar=c(0,3,0,3))
	plot(plotTime, rhessys_SingleFile[rhessys.dtsm,'sat_def_z'],type='l', ylab='',xaxt='n',bty='n', ylim=rev(range(rhessys_SingleFile[rhessys.dtsm,'sat_def_z'])))
	par(mar=c(3,3,0,3))
	upper = max(rhessys_SingleFile[rhessys.dtsm,'streamflow'],calobs[calobs.dtsm,'mmd'])
	lower = min(rhessys_SingleFile[rhessys.dtsm,'streamflow'],calobs[calobs.dtsm,'mmd'])
	plot(plotTime, calobs[calobs.dtsm,'mmd'], col='red', type='l',log='y',bty='l', ylim=c(lower ,upper))
	lines(plotTime, rhessys_SingleFile[rhessys.dtsm,'streamflow'], col='blue' )
	lines(plotTime, rhessys_SingleFile[rhessys.dtsm,'baseflow'], col='darkblue',lty=2 )
	##----------------------------------------


##CTE534_Composite=group
##Imagen=raster
##Azul=number 1
##Verde=number 2
##Rojo=number 3
##Stretch=selection linear;histograma
##showplots
RGB <- raster::stack(Imagen[[Rojo]], Imagen[[Verde]], Imagen[[Azul]])
if (Stretch == 0) {
raster::plotRGB(RGB, axes =TRUE, stretch = "lin", main = "Composición en Color Verdadero")
box()
grid(lwd=1, col="black")
} else if (Stretch == 1) {
raster::plotRGB(RGB, axes =TRUE, stretch = "hist", main = "Composición en Color Verdadero")
box()
grid(lwd=1, col="black")
}