# TODO: Add comment
# 
# Author: E.Korsching 10.9.2009, 30.01.2021
###############################################################################


# barplot modules

barplot.ek <- function(x, y, col="blue", col.b=NA, width=1, density=-1, lwd=0.5, adj=0.5, srt=0, layout="v")
{
	# plot bars in an existing plot window
	# x: positions, y: values
	# xlab= x annotation per position,  ylab: y annotation per position
	#   so either a vector with names (for all positions)  or  a number vector (even for seleted positions)
	# col: single color or ready gradient,  col.b: border color or NA
	xlen <- length(x)
	col.l <- length(col)
	if(col.l==1){
		col <- rep(col, xlen)
	}
	for(i in 1:xlen){
		par(adj = 1)
	    if(layout=="v"){
		    xb <- c(x[i]-width/2, x[i]+width/2, x[i]+width/2, x[i]-width/2)
            yb <- c(0, 0, y[i], y[i])
        }else if(layout=="h"){
		    yb <- c(x[i]-width/2, x[i]-width/2, x[i]+width/2, x[i]+width/2)
		    xb <- c(0, y[i], y[i], 0)
		}else{ stop("no layout") }
		polygon(xb, yb, density=density, col=col[i], border=col.b, lwd=lwd)
	}
	return()
}

# carefully study the external and internal parameter
#par(mfrow=c(2,2))
#plot(x=1, y=1, type="b", ylab="", xlab="", xlim=c(0.5,3.5), ylim=c(-0.35,2), tck=F, pch=1, axes=T, cex=1, col="blue")		# !
#barplot.ek(x=c(1,2,3), y=c(0.9,1.2,1.9), col="gray", col.b=NA, width=0.3, density=-1, lwd=0.5, adj=0.5, srt=0, layout="v")
#
#plot(x=1, y=1, type="b", ylab="", xlab="", xlim=c(-0.35,2), ylim=c(0.5,3.5), tck=F, pch=1, axes=T, cex=1, col="blue")		# !
#barplot.ek(x=c(1,2,3), y=c(0.9,1.2,1.9), col="gray", col.b=NA, width=0.3, density=-1, lwd=0.5, adj=0.5, srt=0, layout="h")
#
#plot(x=1, y=1, type="b", ylab="", xlab="", xlim=c(-2,0.35), ylim=c(0.5,3.5), tck=F, pch=1, axes=T, cex=1, col="blue")		# !
#barplot.ek(x=c(1,2,3), y=c(-0.9,-1.2,-1.9), col="gray", col.b=NA, width=0.3, density=-1, lwd=0.5, adj=0.5, srt=0, layout="h")
#
#plot(x=1, y=1, type="b", ylab="", xlab="", xlim=c(0.5,3.5), ylim=c(-2,0.35), tck=F, pch=1, axes=T, cex=1, col="blue")		# !
#barplot.ek(x=c(1,2,3), y=c(-0.9,-1.2,-1.9), col="gray", col.b=NA, width=0.3, density=-1, lwd=0.5, adj=0.5, srt=0, layout="v")
#par(mfrow=c(1,1))




## create color key legend
#    key.step() --> key.pal.forming()  =>  pal.key.p   [create: a palette + key parameter]
#   key.val.to.col() :  <=  pal.key.p  =>  y   [translate the real world values into colors]
#  key.key() :  <=  pal.key.p   [create: a color key]


key.step <- function(x, k.levels=10, color.g=c("red","green"), center.col=NULL, special.col=NULL, invers=FALSE, custom.scale=NULL){
	# calculate grid of step.size mid points - linear : 1-2-3-4  <-1.5-2.5-3.5->
	# custom.scale: set a custom range independent from the data : c(min,max)
	if(!is.null(custom.scale)){
		start <- custom.scale[1]
		end <- custom.scale[2]
	}else{
		start <- min(x, na.rm=TRUE)
		end <- max(x, na.rm=TRUE)
	}
	cat("\n Data min: ",start," max: ",end,"\n")
	step.size <- (end-start)/(k.levels-1)		# because step parts & step+1 colors
	start.o <- start		#save
	
	# first + last bin = one full bin -- check if appropriate 
	start <- start+step.size/2		#initialization
	
	# key parameter
	key.p <- c(start, step.size, start.o, end)
	
	# create color gradient
	pal <- key.pal.forming(key.p, k.levels, color.g, center.col, special.col, invers)
	return(list(pal, key.p))
}


key.pal.forming <- function(key.p, k.levels, color.g, center.col, special.col, invers){
	# create a color gradient
	# key.p: input from key.step()
	# center.col: value from the data range; will be placed in the center of the color gradient
	if(!is.null(center.col)){
		len.color.g <- length(color.g)
		if(len.color.g<=2){
			stop("\n choose an odd number of colors >= 3 -or- set center.col=NULL")
		}
		even.colors <- is.even(len.color.g)
		if(even.colors){
			stop("\n choose an odd number of colors : e.g. color.g=c('red','white','blue') -or- set center.col=NULL")
		}
		len.color.mult <- len.color.g %/% 2
		f.pal1 <- colorRampPalette(color.g[1:(len.color.mult+1)], space="rgb")		#create function 1
		f.pal2 <- colorRampPalette(color.g[(len.color.mult+1):len.color.g], space="rgb")		#create function 2
		
		# which bin is color center
		i <- T
		j <- 1		# counter for center
		while(i){
			if(center.col<key.p[1]){
				i <- F
			}else{
				j <- j+1
				key.p[1] <- key.p[1] + key.p[2]
			}
		}
		
		pal1 <- f.pal1(j)		#generate color plalette 1
		# create now one color more (+2 because k.levels+1) which will be deleted in the next line (to start the gradient in a correct way)
		pal2 <- f.pal2(k.levels-j+2)		#generate color plalette 2
		pal <- c(pal1,pal2[2:(k.levels-j+2)])	#join both
		
	}else{
		f.pal <- colorRampPalette(color.g, space="rgb")		#create function
		pal <- f.pal(k.levels)		#generate color plalette
	}
	
	if(!is.null(special.col)){
		for(i in 1:length(special.col[[1]])){
			pal[special.col[[1]][i]] <- special.col[[2]][i]
		}
	}
	
	# invert col order
	if(invers){ pal <- pal[length(pal):1] }
	
	return(pal)
}


key.val.to.col <- function(x, pal.key.p, k.levels=10, cex.key=1){
	# translate values to color levels,  centered
	# x: values (vector),  pal.key.p: output of key.step()
	# k.levels: color levels,  cex.key: char size key
	y <- x
	start <- pal.key.p[[2]][3]+pal.key.p[[2]][2]/2		#re-initialization
	if(sum(x<start, na.rm=T)!=0){		#this approach is implicitely dealing with rounding errors at the start and end
		tmp <- x<start
		tmp[is.na(tmp)] <- F	#correct NA to FALSE
		y[tmp] <- pal.key.p[[1]][1]
	}
	for(i in 2:k.levels){
		old <- start
		start <- start + pal.key.p[[2]][2]
		if(i<k.levels){
			if(sum(x>=old & x<start, na.rm=T)!=0){
				tmp <- x>=old & x<start
				tmp[is.na(tmp)] <- F	#correct NA to FALSE
				y[tmp] <- pal.key.p[[1]][i]
			}
		}else{
			if(sum(x>=old, na.rm=T)!=0){		#last step
				tmp <- x>=old
				tmp[is.na(tmp)] <- F	#correct NA to FALSE
				y[tmp] <- pal.key.p[[1]][i]
			}
		}
	}
	return(y)
}


key.key <- function(pal.key.p, cex.key=1, mar=c(0.05,0.05,0.05,0.05), sign.num=2, na.v=F,
		kxc=0.3, key.v.offset=5, full.key=T, k.levels=10, custom.scale=NULL){
	# create color key legend
	# pal.key.p: from key.step()
	par(mar=mar)
	plot(0, 0, xlim=c(0, 4), ylim=c(k.levels+key.v.offset, 0-key.v.offset), type="n", axes=F, xlab="", ylab="")
	
	delta.step <- 1
	dyn.pos <- 1
	kx0 <- 0.5+kxc
	kxe <- 1-kxc
	t.a <- 1.7
	
	old <- pal.key.p[[2]][3]	# for label description
	start <- pal.key.p[[2]][3]+pal.key.p[[2]][2]/2		#re-initialization
	cat("\n old ",old,"  ", start)
	
	# top
	xb <- c(kx0, kx0+kxe, kx0+kxe, kx0)
	yb <- c(dyn.pos-delta.step/2, dyn.pos-delta.step/2, dyn.pos+delta.step/2, dyn.pos+delta.step/2)	
	polygon(xb, yb, density=-1, col=pal.key.p[[1]][1], border=NULL, lwd=0.1)
	text(x=t.a, y=dyn.pos, labels=paste(" >= ",round(old,sign.num)), cex=cex.key, srt=0, adj=0)
	
	old <- start
	start <- start+pal.key.p[[2]][2]
	dyn.pos <- dyn.pos+delta.step
	for(i in 2:(k.levels-1)){
		xb <- c(kx0, kx0+kxe, kx0+kxe, kx0)
		yb <- c(dyn.pos-delta.step/2, dyn.pos-delta.step/2, dyn.pos+delta.step/2, dyn.pos+delta.step/2)	
		polygon(xb, yb, density=-1, col=pal.key.p[[1]][i], border=NULL, lwd=0.1)
		if(full.key){
			text(x=t.a, y=dyn.pos, labels=paste(round(old,sign.num),", <",round(start,sign.num)), cex=cex.key, srt=0, adj=0)
		}
		old <- start
		start <- start+pal.key.p[[2]][2]
		dyn.pos <- dyn.pos+delta.step
	}
	
	# bottom
	xb <- c(kx0, kx0+kxe, kx0+kxe, kx0)
	yb <- c(dyn.pos-delta.step/2, dyn.pos-delta.step/2, dyn.pos+delta.step/2, dyn.pos+delta.step/2)	
	polygon(xb, yb, density=-1, col=pal.key.p[[1]][(k.levels+1)], border=NULL, lwd=0.1)
	text(x=t.a, y=dyn.pos, labels=paste(" <= ", round(pal.key.p[[2]][4],sign.num)), cex=cex.key, srt=0, adj=0)
	
	# missing values
	if(na.v){
		dyn.pos <- dyn.pos+delta.step+1
		xb <- c(kx0, kx0+kxe, kx0+kxe, kx0)
		yb <- c(dyn.pos-delta.step/2, dyn.pos-delta.step/2, dyn.pos+delta.step/2, dyn.pos+delta.step/2)	
		polygon(xb, yb, density=-1, col=col.miss.values, border=NULL, lwd=0.1)
		text(x=t.a, y=dyn.pos, labels=paste("NA"), cex=cex.key, srt=0, adj=0)
	}
	return()
}