#creates 'boxplots' with median and quartiles and potentially precentiles, min and max
#written by Roger Mundry
#version from Oct. 29, 2011
#arguments are
#fac: a vector with levels of a factor (can also be a character or number vector)
#xvar: numerical variable to be boxplotted
#which.q: quantiles defining the box (usually quartiles), the mean line (usually median),
#and the percentiles line (usually 0.025 and 0.975)
#indicate which.q=c(0.025, 0.25, 0.5, 0.75, 0.975) to get median, quartiles and quantiles
#or which.q=c(0, 0.025, 0.25, 0.5, 0.75, 0.975, 1) to get median, quartiles, quantiles, min and max
#main=; ylab=; y.lim: same meaning as in standard plot
#qpch: point character to be used of min and max (in case they are requested)
boxplotteR<-function(fac, xvar, which.q, main="", ylab="", y.lim=NULL, qpch=4, quiet=T, add.x.labels=T, add.n=F, reset.par=T,
	add.y.axis=T, x.at=NULL, edge.width=0.5, cex.axis=0.8, add.points=T, col = NA, pt.col="black", border = NULL, box.lwd=1, level.seq=NULL, level.labels=NULL,
	cex.lab=1, my.par=NULL){
  old.par = par(no.readonly = TRUE)
  #browser()
  if(is.null(my.par)){
		par(mar=c(3, 4.5, 0.2, 0.2), mgp=c(3, 0.5, 0), tcl=-0.25)
	}else{
		par(my.par)
	}
	to.plot=tapply(xvar,fac,quantile,which.q, na.rm=T)
  to.plot=matrix(unlist(to.plot),ncol=length(which.q),byrow=T)
  colnames(to.plot)=which.q
  rownames(to.plot)=levels(as.factor(fac))
	if(length(level.seq)>0){
		to.plot=to.plot[match(rownames(to.plot), level.seq),]
	}else{
		level.seq=rownames(to.plot)
	}
	if(length(level.labels)==0){level.labels=level.seq}
  if(length(y.lim)==0){
    if(add.points){
			y.lim=range(c(to.plot, xvar))
		}else{
			y.lim=range(to.plot)
		}
  }
  
	if(length(x.at)==0){
		xx=sort(unique(as.numeric(as.factor(fac))))
		x.at=xx
	}else{
		xx=sort(x.at)
	}
  #par(mar=c(2, 4.5, 0.5, 0.5))
  if(add.y.axis){
		plot(mean(xx),mean(xvar),xaxt="n", xlab="", xlim=c(min(xx)-edge.width, max(xx)+edge.width), bty="n",
			type="n",ylim=y.lim,las=1, main="", ylab=ylab, cex.axis=cex.axis, cex.lab=cex.lab, xaxs="i")
	}else{
		plot(mean(xx),mean(xvar),xaxt="n", xlab="", xlim=c(min(xx)-edge.width, max(xx)+edge.width), bty="n",
			type="n",ylim=y.lim,las=1, main="", ylab=ylab, cex.axis=cex.axis, yaxt="n", cex.lab=cex.lab)
	}
	if(nchar(main)>0){mtext(text=main, side=3, line=0)}
	hll=(as.vector(xx)[2]-as.vector(xx)[1])/3
  mid.col=(ncol(to.plot)+1)/2
  if(add.points){points(x.at[match(fac, levels(fac))], xvar, pch=19, col=grey(level=0.75, alpha=0.5))}
  if(ncol(to.plot)>=5){segments(x0=xx,x1=xx,y0=to.plot[,mid.col-2],y1=to.plot[,mid.col+2])}
  rect(xleft=xx-hll, xright=xx+hll, ybottom=to.plot[,mid.col-1],ytop=to.plot[,mid.col+1], border=border, col=col, lwd=box.lwd)
  segments(x0=xx-hll,x1=xx+hll,y0=to.plot[,mid.col],y1=to.plot[,mid.col],lwd=2*box.lwd)
  if (ncol(to.plot)==7){
    points(c(xx,xx),c(to.plot[,1],to.plot[,7]),pch=qpch, col=pt.col)
  }
  if(add.x.labels){mtext(text=level.labels, side=1, line=0, at=xx, cex=cex.axis, las=1)}
  if(add.n){
    n=table(fac[!is.na(xvar)])
    #mtext(text="N:", at=0.6, side=1, line=-1, cex=0.75)
    mtext(text=n, at=xx, side=1, line=-1, cex=0.75)
  }
  #mtext(text=sort(unique(fac)), side=1, line=0, at=xx, cex=0.8, las=1)
  if(!quiet){return(to.plot)}
  if(reset.par){par(old.par)}
}

##mantel like permutation test which shuffles individuals across populations:
cat.mat.corr.2<-function(val.mat, p.class, p.ind, part, exact.thresh=9, n.perm=1000, response=c("quantitative", "categorical"), test.stat=mean){
	measure.test.stat<-function(v.mat, c.mat, part, test.stat){
		if(part=="all-diag"){
			v.mat=c(v.mat[lower.tri(v.mat)],v.mat[upper.tri(v.mat)])
			c.mat=c(c.mat[lower.tri(c.mat)],c.mat[upper.tri(c.mat)])
		}else if(part=="all+diag"){
			v.mat=unlist(c(v.mat))
			c.mat=unlist(c(c.mat))
		}else if(part=="lower"){
			v.mat=as.vector(v.mat[lower.tri(v.mat)])
			c.mat=as.vector(c.mat[lower.tri(c.mat)])
		}else if(part=="upper"){
			v.mat=as.vector(v.mat[upper.tri(v.mat)])
			c.mat=as.vector(c.mat[upper.tri(c.mat)])
		}
		xres=tapply(v.mat, c.mat, FUN=test.stat, na.rm=T)
		total=sum((xres-mean(xres))^2)
		i.res=abs(outer(xres, xres, "-"))
		i.res.names=outer(names(xres), names(xres), function(x, y){paste(x, y, sep=" vs. ")})
		return(data.frame(comparison=c("all", i.res.names[lower.tri(i.res.names)]), value=c(total, i.res[lower.tri(i.res)])))
	}
	convert.mat<-function(mat, part){
		if (part=="lower"){
			xxt=t(mat)
			xxt[lower.tri(xxt)==T]=mat[lower.tri(mat)==T]
			mat=xxt
		}else if(part=="upper"){
			xxt=t(mat)
			mat[lower.tri(mat)==T]=xxt[lower.tri(xxt)==T]
		}
		return(mat)
	}
	if(length(unique(dim(val.mat)))>1){
		stop("matrix isn't square")
	}
	p.class=as.character(p.class)
	p.ind=as.character(p.ind)
	if(length(p.class)!=length(p.ind)){
		stop("length of grouping factor ('p.class') and clusterID ('p.ind') don't match")
	}
	if(length(p.ind)!=nrow(val.mat) | length(p.ind)!=ncol(val.mat)){
		stop("length of clusterID ('p.ind') and matrix dimensions don't match")
	}
	val.mat=val.mat[order(rownames(val.mat)), order(colnames(val.mat))]
	if(any(rownames(val.mat)!=colnames(val.mat))){
		stop("row and column names of matrix don't match")
	}
	p.class=p.class[order(p.ind)]
	p.ind=p.ind[order(p.ind)]
	if(any(rownames(val.mat)!=p.ind)){
		stop("names of matrix and clusterID ('p.ind') don't match")
	}
	to.perm=cbind(class=p.class, ind=p.ind)
	to.perm=to.perm[!duplicated(to.perm), ]
	xx=to.perm[, "class"]
	names(xx)=to.perm[, "ind"]
	to.perm=xx
	cat.mat=outer(as.vector(to.perm[rownames(val.mat)]), as.vector(to.perm[colnames(val.mat)]), "==")
	
	if(part=="upper" | part=="lower"){
    val.mat=convert.mat(val.mat, part)
    cat.mat=convert.mat(cat.mat, part)
  }
  
  if(response=="quantitative"){
    orig=measure.test.stat(v.mat=val.mat, c.mat=cat.mat, part=part, test.stat=test.stat)
  }else{
    orig=data.frame(value=0)
    orig$value=measure.test.stat.cat.resp(v.mat=val.mat, c.mat=cat.mat, part=part)
  }
  mat.size=length(to.perm)
  if(mat.size>exact.thresh){
    appr=1
    all.res=orig$value
  }else{
		stop("don't know what to do")
    #perms=permutations(mat.size,mat.size)
    #n.perm=nrow(perms)
    #all.res=c()
    #appr=0
  }
  for (i in 1:(n.perm-appr)){
    if (appr==1){
      perm=to.perm
      perm[]=sample(as.vector(to.perm), mat.size, replace=F)
    }else{
      new.ind=perms[i,]
    }
    ran.mat=outer(as.vector(perm[rownames(val.mat)]), as.vector(perm[colnames(val.mat)]), "==")
    if(response=="quantitative"){
      all.res=rbind(all.res, measure.test.stat(v.mat=val.mat, c.mat=ran.mat, part=part, test.stat=test.stat)$value)
    }else{
      all.res=rbind(all.res, measure.test.stat.cat.resp(v.mat=val.mat, c.mat=ran.mat, part=part))
    }
  }
  orig=data.frame(orig, P=apply(all.res, 2, function(x){return(sum(x>=x[1]))})/n.perm)
  if(appr==1){method="approximate"}else{method="exact"}
  if(response=="quantitative"){
    return(list(result=orig, method=method, n.perm=n.perm, response=response))
  }else{
    list(result=orig, method=method, n.perm=n.perm, response=response)
  }
}

##functions for pie plot:
make.pie<-function(xarea, fract, resol=100){
	xnames=names(fract)
	if(sum(fract>0)){
		fract=c(0, cumsum(fract/sum(fract)))*2*pi
		radius=sqrt(xarea/pi)
		#browser()
		ires=lapply(1:(length(fract)-1), function(x){
			rads=seq(fract[x], fract[x+1], length.out=resol)
			return(list(x=radius*c(0, sin(rads), 0), y=radius*c(0, cos(rads), 0)))
		})
		#names(ires)=xnames
	}else{
		ires=NULL
	}
	circ=seq(0, 2*pi, length.out=resol)
	circ=list(x=radius*sin(circ), y=radius*cos(circ))
	return(list(polies=ires, circ=circ))
}

pie.plot<-function(x, y, what, prop, size.fac=1, cols, width=7, height=7, xoffs=0.5, yoffs=0.5, my.par=list(mar=c(2, 2, 0.2, 0.2)), reset.par=T){
  old.par = par(no.readonly = TRUE)
	sel=!is.na(x) & !is.na(y) & !is.na(what) & !is.na(prop)
	if(!is.factor(x)){stop("x must be a factor")}
	if(!is.factor(y)){stop("y must be a factor")}
	#if(!is.factor(prop) & !is.numeric(prop)){stop("prop must be numeric")}
	x=x[sel]; y=y[sel]; what=what[sel]; prop=prop[sel]
	#X11(width=width, height=height)
	par(my.par)
	plot(1, 1, xlim=c(1, length(levels(x)))+c(-xoffs, xoffs), ylim=c(1, length(levels(y)))+c(-yoffs, yoffs), 
		type="n", xaxt="n", yaxt="n", xlab="", ylab="")
	to.plot=data.frame(x, y)
	to.plot=to.plot[!duplicated(to.plot), ]
	templ=rep(0, length(levels(what)))
	names(templ)=levels(what)
	#####
	win.h=par()$din[2]
	win.wdt=par()$din[1]/par()$mfrow[2]
	asp=(abs(diff(par()$usr[rev(3:4)]))/(win.h-(par()$mai[1]+par()$mai[3])))/
		(abs(diff(par()$usr[1:2]))/(win.wdt-(par()$mai[2]+par()$mai[4])))
	for(i in 1:nrow(to.plot)){
		sel.what=what[x==to.plot$x[i] & y==to.plot$y[i]]
		sel.prop=prop[x==to.plot$x[i] & y==to.plot$y[i]]
		props=templ
		props[as.character(sel.what)]=sel.prop
		if(any(props>0)){
			xpie=make.pie(xarea=sum(props), fract=props)
			for(j in 1:length(xpie$polies)){
				if(props[j]>0){
					polygon(x=as.numeric(to.plot$x[i])+xpie$polies[[j]]$x*size.fac/asp, y=as.numeric(to.plot$y[i])+xpie$polies[[j]]$y*size.fac, col=cols[j], border=cols[j])
				}
			}#browser()
			polygon(x=as.numeric(to.plot$x[i])+xpie$circ$x*size.fac/asp, y=as.numeric(to.plot$y[i])+xpie$circ$y*size.fac, border="black", col=NA)
		}
	}
	mtext(text=levels(x), side=1, line=0.2, at=1:length(levels(x)))
	mtext(text=levels(y), side=2, line=0.2, at=1:length(levels(y)), las=1)
	if(reset.par){par(old.par)}
}

##function that reads a file using readLines but eventually returns a data frame (needed because of the weird structure with which the data came)
rcsv.as.rl<-function(file, sep, header){
	xx=readLines(con=file)
	r.data=readLines(con=file)#, header=T, sep="\t", fill=T)
	#the following line is a special for Sonia's weird files:
	#r.data=gsub(x=r.data, pattern="\"\t", replacement="")
	r.data=strsplit(r.data, split=sep, fixed=T)
	max.len=unlist(lapply(r.data, length))
	if(diff(range(max.len))>0){
		max.len=max(max.len)
		r.data=lapply(r.data, function(x){
			if(length(x)<max.len){
				x=c(x, rep("", max.len-length(x)))
			}
			return(x)
		})
	}
	r.data=matrix(unlist(r.data), nrow=length(r.data), byrow=T)
	if(header){
		xnames=r.data[1, ]
		r.data=r.data[-1, ]
		colnames(r.data)=xnames
	}
	xx=apply(r.data!="", 1, sum)
	r.data=r.data[xx>0, ]
	r.data=as.data.frame(r.data)
	return(r.data)
}

##function for determining the cultural FST:
fst<-function(alleles, pops){##this is the revised version
	##determine Pi:
	xx=table(alleles, pops)
	Pi=t(t(xx)/colSums(xx))
	mean.Pi=apply(t(t(Pi)*colSums(xx)), 1, sum)/sum(xx)
	##determine var(Pi):
	var.pi=apply((Pi-mean.Pi)^2, 1, sum)/(ncol(xx)-1)
	##determine FSTi:
	fst.i=var.pi/(mean.Pi*(1-mean.Pi))
	fst.i[fst.i<0]=0
	##and finally the FST:
	#browser()
	fst=sum((mean.Pi*(1-mean.Pi))*fst.i)/sum(mean.Pi*(1-mean.Pi))
	#if(!is.nan(fst) & fst>1){browser()}
	return(fst)
}

##function for determining the cultural FST (asu method):
asu<-function(alleles, pops){
	xx=table(alleles, pops)
	pki=t(t(xx)/colSums(xx))
	ni=colSums(xx)
	N=sum(xx)
	s=ncol(xx)-1
	mean.pk=apply(t(t(pki)*ni), 1, sum)/N
	var.pk=apply(t(ni*t((pki-mean.pk)^2)), 1, sum)/(N*(s-1))
	var.pki=apply(t(ni*t(pki*(1-pki))), 1, sum)/(mean(ni)*(s-1))
	fstk=var.pk/(var.pk+var.pki)
	fst=sum(mean.pk*(1-mean.pk)*fstk)/sum(mean.pk*(1-mean.pk))
	return(fst)
}

##function extracting results (sd) for random effects components of (G)LMM:
boot.extract.fun<-function(x){
	x=as.data.frame(summary(x)$varcor)
	r=x[, "sdcor"]
	names(r)=x[, "grp"]
	return(r)
}