#########################################################################################
###### This file provides functions implement the Consonant Likelihood Ratio Test  ######
###### for multiple endpoints problem.                                             ######
###### Copyright(c) 2011 Bushi Wang.                                               ######
###### Modified May 3, 2011, version 1.0.1                                         ######
###### This code is distributed WITHOUT ANY WARRANTY.                              ######
#########################################################################################
###### Modified May 24, 2011, version 1.0.2                                        ######
###### In this version, .CLRT.PS4.test has been modified to return p-value and cv. ######
#########################################################################################
###### Modified September 19, 2011, version 1.1.0                                  ######
###### Build R package clrt.                                                       ######
#########################################################################################

# The program is only for the case with one primary and one secondary endpoint problem.
# Comparing k-1 doses of study drug with a control.

# If m is the number of endpoints, we restrict m=2.

# The natural partition divides the parameter space into (m+1)^(k-1)=26 pieces for k=4.
#   Thus there are 26 null hypotheses to test. The null distribution of the parameter
#   of interest in all 26 hypotheses are identical, which assumes there is no dose effect
#   for both primary and secondary endpoints.

# We first generate simu=10^5 datasets, each contains k=4 groups of 2-by-1 vectors,
#   each group represent the patients receiving a paticular dose. Thus the number
#   of vectors in each group is the number of patients in this group.

# Next we calculate the LRT for each of these simu=10^5 datasets. Each LRT is a
#   26-by-1 vector indicating test statistic for each null hypothesis.

# In order to inplement the power of Consonant likelihood ratio test, we generate
#   powersimu=10^5 datasets following some senario with dose effect and known
#   correlation between endpoints. Then put each one of this powersimu=10^5
#   dataset into the original simulated dataset and calculate the p-value according
#   to the complete consonant adjustment. Thus we get powersimu=10^5 p-values each
#   one a 26-by-1 vector.

# For each of the powersimu=10^5 26-by-1 p-values, find the 2-by-k inference matrix.
#   Average among the powersimu=10^5 inference matrix we get the power.

.Constraint<-function(label,k=4){
	# label is a length k-1 vector indicating the label of an intersection hypothesis.
	# It follows the definition as in Table 1 and 2.
    hnullp<-hnulls<-matrix(0,nrow=k-1,ncol=k)
    for(i in 1:(k-1)){
        if(label[i]==1){
            hnullp[i,c(k,i)]<-c(1,-1)     # \Theta_i^{e_i}
        }else if(label[i]==2){
            hnulls[i,c(k,i)]<-c(1,-1)
        }
    }
    return(list('hnullp'=t(hnullp),'hnulls'=t(hnulls)))
}

.naturalpartition<-function(k=4,m=2,balanced=F){
    #k is the number of treatment arms, including control.
    nhypo<-(m+1)^(k-1)-1
    npmtrx<-matrix(NA,nrow=nhypo+1,ncol=k-1)
    for(a in 1:(k-1))npmtrx[,a]<-as.numeric(sapply(1:(m+1),function(x)rep(x,(m+1)^(k-1-a))))
    npmtrx<-npmtrx[1:nhypo,]
    # npmtrx gives all the possible labelings of intersection hypotheses

    if(balanced){
		# In the case of balanced treatment arms, the computation of critical constants can be greatly
		# 	simplified by sharing the same values among certain intersection hypohteses.
		# For example, hypothesis H_121 and H_112 will use the same critical value.
        labmtrx<-t(apply(npmtrx,1,sort))
        diff.label<-rep(1,nhypo)
        unique.label<-list()
        for(i in 1:nhypo){
            if(diff.label[i]==0){
                unique.label[[i]]<-0;
                next;
            }
            unique.label[[i]]<-which(sapply(1:nhypo,function(x)all(labmtrx[x,]==labmtrx[i,])))
            diff.label[ unique.label[[i]] ]<-0
        }
        balanced<-unique.label
    }

    # Some general definition, specified below.
	Comp.Amat<-list()
    component.array<-list()
    row.ind<-list()
    active.array<-list()
    if(k>3)col.ind<-lapply(1:(k-2),function(x)matrix(nrow=choose(k-1,x+1),ncol=choose(x+1,x)))

	for(cross in 1:(k-1)){
        component.array[[cross]]<-array(m+1,dim=c(m^cross,k-1,choose(k-1,cross)))
		# component.array also gives the labeling of all intersection hypotheses.
		# However, we may locate certain intersection hypothesis through component.array
        matrix.comb<-combn(k-1,cross)
        active.array[[cross]]<-matrix(NA,nrow=m^cross,ncol=cross)
        for(a in 1:cross)active.array[[cross]][,a]<-as.numeric(sapply(1:m,function(x)rep(x,m^(cross-a))))
        # active.array[[cross]] gives the possible combination of endpoints in a "cross"-way intersection.

		for(i in 1:choose(k-1,cross))component.array[[cross]][,matrix.comb[,i],i]<-active.array[[cross]]
        # component.array[[cross]] is an array, which consists of "choose(k-1,cross)" matrices.
		#	The number "cross" indicates how many original hypotheses involved in the intersection.
		#	Each matrix, for example, component.array[[cross]][,,1], has each row a label for one paticular
		#	intersection. The number of rows in each matrix is m^cross.
		Comp.Amat[[cross]]<-list()
        # Comp.Amat are the constraint matrix for the component hypothesis.
		# It provide guidance on how to compute the restricted MLEs and the likelihood ratio statistics.
		# Comp.Amat[[1]] contain the constraint matrix for all the elementary hypotheses
		# Comp.Amat[[2]] contain the constraint matrix for all 2 way intersection hypotheses
		# 	ect... up to k-1.
		for(i in 1:choose(k-1,cross)){
            Comp.Amat[[cross]][[i]]<-list()
            for(j in 1:m^cross) Comp.Amat[[cross]][[i]][[j]]<-.Constraint(label=component.array[[cross]][j,,i],k=k)
        }

		# The list row.ind and col.ind tells how to perform the consonant adjustment.
		# Read the instruction in function .rNull.dist for definitions on ComponentLRT first.
		# Since each intersection hypothesis is located by one cell in the matrix of ComponentLRT[[1]][,,i],
		#	ComponentLRT[[2]][,,i], and ComponentLRT[[3]][,,i] for the ith replication, we give the index of those
		#	intersection hypotheses that needs to be tested in consonance adjustment.

		# For example, a three way intersection hypothesis H_121, will be located in ComponentLRT[[3]].
		#	According to active.array[[3]], it is on the 3rd row of ComponentLRT[[3]]. And ComponentLRT[[3]][,,i] only
		#	has one column. So the index for H_121 is ComponentLRT[[3]][3,1,i].
		# To reject H_121, we need to also reject at least two of H_123, H_131 and H_321. They are associated with three
		#	indices in ComponentLRT.
		# First, since they are all two-way intersections, they all located in ComponentLRT[[2]].
		#	row.ind[[2]][3,]=c(2,1,3) gives the three row index of these hypotheses,
		#	col.ind[[2]][1,]=c(1,2,3) gives the three col index of these hypotheses.
		#	They are ComponentLRT[[2]][2,1,i], ComponentLRT[[2]][1,2,i] and ComponentLRT[[2]][3,3,i].
		if(cross>1){
            row.ind[[cross-1]]<-matrix(NA,nrow=m^cross,ncol=cross)
            combn.mat<-combn(cross,cross-1)
            for(a in 1:m^cross)for(b in 1:cross)
                row.ind[[cross-1]][a,b]<-which(sapply(1:m^(cross-1),function(x)all(active.array[[cross-1]][x,1:(cross-1),drop=F]==active.array[[cross]][a,combn.mat[,b]])))
            combn.mat<-combn(k-1,cross-1)
            for(a in 1:nrow(col.ind[[cross-1]]))
                col.ind[[cross-1]][a,]<-which(sapply(1:choose(k-1,cross-1),function(x)all(combn.mat[,x]%in%combn(k-1,cross)[,a])))
        }
    }
    return(list('matrix'=npmtrx,'Comp.Amat'=Comp.Amat,'component.array'=component.array,'row.ind'=row.ind,'col.ind'=col.ind,'balanced'=balanced))
}

# LR compute the likelihood ratio statistics for each intersection hypothesis.
library(quadprog)
.LR<-function(Amat,k=4,m=2,Ybar,sigma,n=rep(50,4)){
    # Ybar is a m-by-k matrix, the last column in Ybar is the control.
	# sigma is a length m vector, includes stdev of each endpoint.
	# Amat is the constraint matrix for certain dose-endpoint combination from Comp.Amat
    sigma<-sum(n-1)*sigma^2
    ynullp<-solve.QP(Dmat=diag(n),dvec=diag(n)%*%Ybar[1,],Amat=Amat$hnullp)$solution
    ynulls<-solve.QP(Dmat=diag(n),dvec=diag(n)%*%Ybar[2,],Amat=Amat$hnulls)$solution
    LR<-( sigma[1]*sigma[2]
         /(sigma[1]+sum(n*(Ybar[1,]-ynullp)^2))/(sigma[2]+sum(n*(Ybar[2,]-ynulls)^2)) )^(-sum(n)/2)
    # To the power of -sum(n)/2 so that reject the null if LR > critical value.
    return(LR)
}

# .rNull.dist generate samples from the null distribution and compute their test statistics.
library(mvtnorm)
.rNull.dist<-function(n=rep(50,4),simu=10^5,rho=0){
    # n is the sample size for each dose. It is a vector of length 4, the last elements is the control.
    # The number of doses in this example, including control, is 4.
    # The number of endpoints is fixed at 2, for this function.
    k<-length(n)
    balanced<-(length(unique(n[1:(k-1)]))==1)
    NP<-.naturalpartition(k=k,m=2,balanced=balanced)
    # Generate null distribution
    sigma<-matrix(nrow=simu,ncol=2)
    Ybar<-array(dim=c(2,k,simu))
    ComponentLRT<-list()
    for(cross in 1:(k-1)) ComponentLRT[[cross]]<-array(dim=c(2^cross,choose(k-1,cross),simu))
    # ComponentLRT[[cross]] is a 2^cross * choose(k-1,cross) * simu array, where simu is the replication.
	# In the case of 4 treatment groups and 2 endpoints,
	#	ComponentLRT[[1]] is 2 by choose(3,1)=3 matrix, each cell is a one-way intersection hypothesis with
	#		index of the form x33, 3x3 or 33x. The x can be 1 or 2 for two endpoints, thus two rows.
	#	ComponentLRT[[2]] is 4 by choose(3,2)=3 matrix, each cell indicates a two-way intersection hypothesis
	#		with index of the form xx3, x3x or 3xx. The xx can be 11, 12, 21 and 22 from two endpoints, thus
	#		there are 4 rows.
	#	ComponentLRT[[3]] is 8 by choose(3,3)=1 matrix, each cell indicates a three-way intersection hypothesis
	#		with index of the form xxx. The xxx comes for two endpoints combinations.

	# Each intersection hypothesis fits into one cell of the matrix in ComponentLRT[[1]][,,i], ComponentLRT[[2]][,,i],
	#	and ComponentLRT[[3]][,,i] for the ith replication. There are in total 26 of them.

	# The following piece of code comes from Normal random variable generating function.
	# To same computation time, part of the repeating computation is done here only once.
    retval<-list()
    VC<-matrix(rho,nrow=2,ncol=2)+(1-rho)*diag(2)
    for(i in 1:k){
        altersigma<-VC/n[i]
        ev<-eigen(altersigma, symmetric = TRUE)
        retval[[i]] <- ev$vectors %*% diag(sqrt(ev$values), length(ev$values)) %*% t(ev$vectors)
    }

    for(i in 1:simu){
            sigma[i,]<-rchisq(2,df=sum(n-1))/sum(n-1)
            # sigma[i,] is the pooled estimate of the standard deviation, it is a vector
            #   of length 2, corresponding to each endpoint.

            Ybar[,,i]<-sapply(1:k,function(x)matrix(rnorm(2), nrow = 1) %*% retval[[x]])
            # 2 by 4 matrix, the last column is the control.

            for(cross in 1:(k-1))
                #ComponentLRT[[cross]][,,i]<-sapply(1:choose(k-1,cross),function(j)sapply(1:2^cross,function(x) .LR(Amat=NP$Comp.Amat[[cross]][[j]][[x]],k=k,m=2,Ybar=Ybar[,,i],sigma=sigma[i,],n=n)))
                for(j in 1:choose(k-1,cross))
                    ComponentLRT[[cross]][,j,i]<-sapply(1:2^cross,function(x) .LR(Amat=NP$Comp.Amat[[cross]][[j]][[x]],k=k,m=2,Ybar=Ybar[,,i],sigma=sigma[i,],n=n))
			# Compute all the likelihood ratio statistics. For some reason, it is faster to use a for loop.
    }
    return(list('ComponentLRT'=ComponentLRT,'NP'=NP,'n'=n,'simu'=simu))
}

#t<-proc.time()[1]
#set.seed(10)
#PS4.null<-.rNull.dist(n=rep(50,4),simu=10^3)
#proc.time()[1]-t

# .rAlternative.dist generate samples from alternative/true distribution and compute likelihood ratio statistics.
# It returns several statistics for different uses.
#	ComponentLRT is used by consonant likelihood ratio test
#	tstat is used by Dunnett gatekeeping procedure
#	DP.object is used by Decision path partition testing
#	NP, scenario, powersimu and delta is carried out to identify the problem.
.rAlternative.dist<-function(n=rep(50,4),powersimu=10^5,rho=0.3,delta=c(0,0),scenario=matrix(0,nrow=2,ncol=3)){
    # delta is the difference between treatment and control that we want to detect.
	k<-length(n)
    balanced<-(length(unique(n[1:(k-1)]))==1)
    NP<-.naturalpartition(k=k,m=2,balanced=balanced)

    sigma<-matrix(nrow=powersimu,ncol=2)
    Ybar<-array(dim=c(2,k,powersimu))
    ComponentLRT<-list()
	tstat<-array(dim=c(2,k-1,powersimu))
    # tstat is the t statistics used in Dunnett Gatekeeping procedure.
	for(cross in 1:(k-1)) ComponentLRT[[cross]]<-array(dim=c(2^cross,choose(k-1,cross),powersimu))
    if(length(delta)!=2)stop("delta should be of the same length as the number of endpoints!")
    trtmean<-cbind(scenario,delta)

    retval<-list()
    VC<-matrix(rho,nrow=2,ncol=2)+(1-rho)*diag(2)
    for(i in 1:k){
        altersigma<-VC/n[i]
        ev<-eigen(altersigma, symmetric = TRUE)
        retval[[i]] <- ev$vectors %*% diag(sqrt(ev$values), length(ev$values)) %*% t(ev$vectors)
    }

    object<-list()
    for(i in 1:powersimu){
            sigma[i,]<-rchisq(2,df=sum(n-1))/sum(n-1)
            # sigma[i,] is the pooled estimate of the standard deviation, it is a vector
            #   of length 2, corresponding to each endpoint.

            Ybar[,,i]<-sapply(1:k,function(x) sweep(matrix(rnorm(2), nrow = 1) %*% retval[[x]], 2, trtmean[,x], "+") )
            # 2 by 4 matrix, the last column is the control

            for(cross in 1:(k-1))
                for(j in 1:choose(k-1,cross))
                    ComponentLRT[[cross]][,j,i]<-sapply(1:2^cross,function(x) .LR(Amat=NP$Comp.Amat[[cross]][[j]][[x]],k=k,m=2,Ybar=Ybar[,,i],sigma=sigma[i,],n=n))

    }
    return(list('ComponentLRT'=ComponentLRT,'NP'=NP,'scenario'=scenario,'delta'=delta,'powersimu'=powersimu))
}

#t<-proc.time()[1]
#PS4.alter<-.rAlternative.dist(n=rep(50,4),powersimu=10^4,rho=0.3,delta=c(0,0),scenario=matrix(c(0,0.65,0.65,0.65,0,0.65),nrow=2,ncol=3,byrow=T))
#proc.time()[1]-t

# In Windows System
#if(!is.loaded("consonant.adj")) dyn.load('./consonant.adj.dll')
# In Linux System
dyn.load("src/clrt.so")
.CLRT.PS4.cv<-function(alpha=0.025,null){
    # The number of endpoints comes from null, which is fixed at 2.
	n<-null$n
    simu<-null$simu
    k<-length(n)
    balanced<-(length(unique(n[1:(k-1)]))==1)
    NP<-null$NP
    ComponentLRT.cv<-list()
    for(cross in 1:(k-1)) ComponentLRT.cv[[cross]]<-matrix(nrow=2^cross,ncol=choose(k-1,cross))

    if(balanced){
    ComponentLRT.cv[[1]][1,]<-ComponentLRT.cv[[1]][2,]<-quantile(null$ComponentLRT[[1]],probs=1-alpha)
    for(cross in 2:(k-1)){
        n.adj<-dim(NP$col.ind[[cross-1]])[2]
        # List of variables needed by .C function
		# NP$col.ind[[cross-1]] is a choose(k-1,cross) by cross matrix
        # NP$row.ind[[cross-1]] is a 2^cross by cross matrix
		#	they share the same number of columns cross, which is the number of hypotheses to test in
		#	the consonance adjustment. Denoted by n.adj (equal to cross).
        # null$ComponentLRT[[cross-1]] is a 2^(cross-1) * choose(k-1,cross-1) * simu array
        # null$ComponentLRT[[cross]] is a 2^cross * choose(k-1,cross) * simu array
        for(a in 1:2^cross){
            cv<-sapply(1:choose(k-1,cross), function(j)
                            sapply(1:n.adj,function(x)ComponentLRT.cv[[cross-1]][NP$row.ind[[cross-1]][a,x],NP$col.ind[[cross-1]][j,x]]))
            # cv is a n.adj (cross) by choose(k-1,cross) matrix

			# The following .C code is the consonance adjustment, it will replace the likelihood ratio statistics of
			#	those intersection hypotheses do not satisfy consonance with 0.
            null$ComponentLRT[[cross]][a,,]<-.C("component_adj",
              as.double(null$ComponentLRT[[cross-1]]),
              as.integer(2^(cross-1)),
              as.integer(choose(k-1,cross-1)),
              ComponentLRT_post=as.double(null$ComponentLRT[[cross]][a,,]),
              as.integer(choose(k-1,cross)),
              as.integer(NP$row.ind[[cross-1]][a,]),
              as.integer(NP$col.ind[[cross-1]]),
              as.double(cv),
              as.integer(n.adj),
              as.integer(simu),
              PACKAGE="clrt"
              )$ComponentLRT_post
        }
		# For balanced case, the critical constants are the same among intersection hypotheses with the same number
		#	of treatments involved regardless of endpoints involved.
        for(unq in k:1){
            L<-which(sapply(1:2^cross,function(x)length(unique(NP$component.array[[cross]][x,,1]))==unq))
            if(length(L)==0)next
            ComponentLRT.cv[[cross]][L,]<-quantile(null$ComponentLRT[[cross]][L,,],probs=1-alpha)
        }
    }
    }

    else{
    for(j in 1:(k-1))ComponentLRT.cv[[1]][,j]<-quantile(null$ComponentLRT[[1]][,j,],probs=1-alpha)
    for(cross in 2:(k-1)){
        n.adj<-dim(NP$col.ind[[cross-1]])[2]
        for(a in 1:2^cross){
            cv<-sapply(1:choose(k-1,cross), function(j)
                sapply(1:n.adj,function(x)ComponentLRT.cv[[cross-1]][NP$row.ind[[cross-1]][a,x],NP$col.ind[[cross-1]][j,x]]))
            null$ComponentLRT[[cross]][a,,]<-.C("component_adj",
                  as.double(null$ComponentLRT[[cross-1]]),
                  as.integer(2^(cross-1)),
                  as.integer(choose(k-1,cross-1)),
                  ComponentLRT_post=as.double(null$ComponentLRT[[cross]][a,,]),
                  as.integer(choose(k-1,cross)),
                  as.integer(NP$row.ind[[cross-1]][a,]),
                  as.integer(NP$col.ind[[cross-1]]),
                  as.double(cv),
                  as.integer(n.adj),
                  as.integer(simu),
                  PACKAGE="clrt"
                  )$ComponentLRT_post
        }
        for(unq in k:1){
            L<-which(sapply(1:2^cross,function(x)length(unique(NP$component.array[[cross]][x,,1]))==unq))
            if(length(L)==0)next
            ComponentLRT.cv[[cross]][L,]<-sapply(1:choose(k-1,cross),function(j)quantile(null$ComponentLRT[[cross]][L,j,],probs=1-alpha))
        }
    }
    }

    return(ComponentLRT.cv)
}

#a<-proc.time()[1]
#cv<-.CLRT.PS4.cv(alpha=0.025,PS4.null)
#(proc.time()[1]-a)
#dyn.unload('./consonant.adj.dll')

.CLRT.PS4.test<-function(alpha=0.05,cv=NULL,n=rep(50,4),ybar,sigma,alter=NULL,powersimu=NULL,null=NULL,rho=0,delta=c(0,0),scenario=NULL){
    # The number of endpoints in this function is fixed at 2.
	# This function can take existing observations generated by .rAlternative.dist before, specify "alter".
	#	The delta and scenario will be obtained from the list "alter".
	# This function can also generate samples using .rAlternative.dist, give the desired sample size by "powersimu".
	#	And specify the correlation between endpoints with "rho" and the scenario want to test.
	# Otherwise, this function is used to test a specific observation, give their mean matrix and variance vector
	#	by "ybar" and "sigma". ybar is a m-by-k matrix treatment means, the last column is the control. sigma is
	#	a vector of length m, the stdev of each endpoint.
	k=length(n)
    m=2
    balanced<-(length(unique(n[1:(k-1)]))==1)

	if(is.null(cv))cv=.CLRT.PS4.cv(alpha=alpha,null=null)

    if(is.null(powersimu)){
        NP<-.naturalpartition(k=k,m=2,balanced=balanced)
        if(is.null(alter)){
            powersimu=1
            alter<-list('ComponentLRT'=list())
            for(cross in 1:(k-1)) alter$ComponentLRT[[cross]]<-array(dim=c(2^cross,choose(k-1,cross),1))
            ybar[,k]<-ybar[,k]+delta
            for(cross in 1:(k-1))
                for(j in 1:choose(k-1,cross))
                    alter$ComponentLRT[[cross]][,j,1]<-sapply(1:2^cross,function(x) .LR(Amat=NP$Comp.Amat[[cross]][[j]][[x]],k=k,m=2,Ybar=ybar,sigma=sigma,n=n))
        }
        else{
            powersimu<-alter$powersimu
            scenario<-alter$scenario
            delta<-alter$delta
        }
    }else{
        alter<-.rAlternative.dist(n=n,powersimu=powersimu,rho=rho,delta=delta,scenario=scenario)
        NP<-alter$NP
    }

    for(cross in 2:(k-1)){
        n.adj<-dim(NP$col.ind[[cross-1]])[2]
        for(a in 1:2^cross){
            cc<-sapply(1:choose(k-1,cross), function(j)
                sapply(1:n.adj,function(x)cv[[cross-1]][NP$row.ind[[cross-1]][a,x],NP$col.ind[[cross-1]][j,x]]))
            # The following .C code is the consonance adjustment, it will replace the likelihood ratio statistics of
			#	those intersection hypotheses do not satisfy consonance with 0.
            alter$ComponentLRT[[cross]][a,,]<-.C("component_adj",
                  as.double(alter$ComponentLRT[[cross-1]]),
                  as.integer(2^(cross-1)),
                  as.integer(choose(k-1,cross-1)),
                  ComponentLRT_post=as.double(alter$ComponentLRT[[cross]][a,,]),
                  as.integer(choose(k-1,cross)),
                  as.integer(NP$row.ind[[cross-1]][a,]),
                  as.integer(NP$col.ind[[cross-1]]),
                  as.double(cc),
                  as.integer(n.adj),
                  as.integer(powersimu),
                  PACKAGE="clrt"
                  )$ComponentLRT_post
        }
    }
	# After the consonance adjustment, compare the likelihood ratio statistics with critical constants.
    if(is.null(null)){
		rejection<-matrix(nrow=(m+1)^(k-1)-1,ncol=powersimu)
		for(cross in 1:(k-1)){
			for(i in 1:choose(k-1,cross)){
				for(j in 1:m^cross){
					for(h in 1:((m+1)^(k-1)-1)){
						if(all(NP$matrix[h,]==NP$component.array[[cross]][j,,i])){
							rejection[h,]<-sapply(1:powersimu,function(x)alter$ComponentLRT[[cross]][j,i,x]>cv[[cross]][j,i])
							break
						}
					}
				}
			}
		}
	}
	# If p-value is desired, then compare likelihood ratio statistics with the null distribution and calculate p-value.
	else{
		pvalue<-rejection<-matrix(nrow=(m+1)^(k-1)-1,ncol=powersimu)
		for(cross in 1:(k-1)){
			for(i in 1:choose(k-1,cross)){
				for(j in 1:m^cross){
					for(h in 1:((m+1)^(k-1)-1)){
						if(all(NP$matrix[h,]==NP$component.array[[cross]][j,,i])){
							pvalue[h,]<-sapply(1:powersimu,function(x)mean(null$ComponentLRT[[cross]][j,i,]>alter$ComponentLRT[[cross]][j,i,x]))
							rejection[h,]<-pvalue[h,]<alpha
							break
						}
					}
				}
			}
		}
	}

    # The rejection rule follows Section 4.1
	Inference<-matrix(0,nrow=m,ncol=k-1)
    FWER<-numeric(powersimu)
    for(edp in 1:m){
        for(dose in 1:(k-1)){
            if(is.null(scenario)){
                Inference[edp,dose]<-all(rejection[which(NP$matrix[,dose]<=edp),1]==1)
                FWER<-NA
            }
            else if(scenario[edp,dose]==0) for(i in 1:powersimu){
                if(FWER[i]==1) Inference[edp,dose]<-Inference[edp,dose]+all(rejection[which(NP$matrix[,dose]<=edp),i]==1)
                else Inference[edp,dose]<-Inference[edp,dose]+(FWER[i]<-all(rejection[which(NP$matrix[,dose]<=edp),i]==1))
            }
            else for(i in 1:powersimu){
                Inference[edp,dose]<-Inference[edp,dose]+all(rejection[which(NP$matrix[,dose]<=edp),i]==1)
            }
        }
    }

	if(!is.null(null))
		return(list('alpha'=alpha,'Power'=Inference/powersimu,'FWER'=sum(FWER)/powersimu,'Partition'=apply(rejection,1,mean),'cv'=cv,'Pvalue'=pvalue,'Hypotheses'=NP$matrix[,1:3],'ComponentLRT'=alter$ComponentLRT ))
	else
		return(list('alpha'=alpha,'Power'=Inference/powersimu,'FWER'=sum(FWER)/powersimu,'Partition'=apply(rejection,1,mean),'cv'=cv,'Pvalue'=rejection,'Hypotheses'=NP$matrix[,1:3],'ComponentLRT'=alter$ComponentLRT ))
}

#a<-proc.time()[1]
#.CLRT.PS4.test(cv=cv,n=rep(50,4),powersimu=10^3,rho=0.3,delta=c(0,0),scenario=matrix(0.65,nrow=2,ncol=3))
#(proc.time()[1]-a)
#.CLRT.PS4.test(cv=cv,n=rep(50,4),ybar=matrix(8:1,nrow=2,ncol=4),sigma=c(2,4),delta=c(2,1))
#.CLRT.PS4.test(cv=cv,n=rep(50,4),alter=PS4.alter)

#source('./main.r') # Appended main.r source code above
if(!is.loaded("consonant.adj"))
# In Windows System
# dyn.load('./consonant.adj.dll')
# In Linux System
dyn.load("src/clrt.so")

clrt<-function(alpha=NULL,cv=NULL,n=NULL,grpmean=NULL,grpstdev=NULL,distr.null=NULL,distr.null.size=NULL,distr.alter=NULL,distr.alter.size=NULL,rho=0,delta=c(0,0),scenario=NULL,savenull=FALSE,savealter=FALSE,showpvalues=FALSE,showLRT=FALSE){
	if(is.null(alpha)){
		if(savenull){
			if(is.null(n))stop("Please specify sample size in each treatment groups and the control group.")
			if(is.null(distr.null.size))stop("Please specify how many samples are required for the null distribution.")
			distr.null=.rNull.dist(n=n,simu=distr.null.size,rho=0)
		}
		if(savealter){
			if(is.null(n))stop("Please specify sample size in each treatment groups and the control group.")
			if(is.null(distr.alter.size))stop("Please specify how many samples are required for the alternative distribution.")
			if(dim(scenario)[1]!=2)stop("This program can only handle cases with two endpoints.")
			if(dim(scenario)[2]!=length(n)-1)stop("Please specify the effect size for each treatment arm in each endpoint.")
			distr.alter=.rAlternative.dist(n=n,powersimu=distr.alter.size,rho=rho,delta=delta,scenario=scenario)
		}
		if(savenull&savealter) return(list('distr.null'=distr.null,'distr.alter'=distr.alter))
		else if(savenull) return(list('distr.null'=distr.null))
		else if(savealter) return(list('distr.alter'=distr.alter))
		else stop("Please specify significance level alpha if you want to perform test or calculate critical constants.")
	}
	else if(!is.null(grpmean) | !is.null(distr.alter) | !is.null(distr.alter.size)){
		if(is.null(cv)&is.null(distr.null)){
			if(is.null(n))stop("Please specify sample size in each treatment groups and the control group.")
			if(is.null(distr.null.size))stop("Please specify how many samples are required for the null distribution.")
			distr.null=.rNull.dist(n=n,simu=distr.null.size,rho=0)
		}
		if(!is.null(distr.null))showpvalue=TRUE
		else if(showpvalues){
			if(is.null(n))stop("Please specify sample size in each treatment groups and the control group.")
			if(is.null(distr.null.size))stop("Please specify how many samples are required for the null distribution.")
			distr.null=.rNull.dist(n=n,simu=distr.null.size,rho=0)
			showpvalue=TRUE
		}
		test.result<-.CLRT.PS4.test(alpha=alpha,cv=cv,n=n,ybar=grpmean,sigma=grpstdev,alter=distr.alter,powersimu=distr.alter.size,null=distr.null,rho=rho,delta=delta,scenario=scenario)
		if(!savenull)distr.null=NULL
		if(!savealter)distr.alter=NULL
		if(!showLRT)test.result$ComponentLRT=NULL
		if(showpvalue) return(list('alpha'=alpha,'Power.Decision'=test.result$Power,'FWER'=test.result$FWER,'Partition.power'=test.result$Partition,'cv'=test.result$cv,'Partition.pvalue'=test.result$Pvalue,'Hypotheses'=test.result$Hypotheses,'ComponentLRT'=test.result$ComponentLRT,'distr.null'=distr.null,'distr.alter'=distr.alter))
		else return(list('alpha'=alpha,'Power.Decision'=test.result$Power,'FWER'=test.result$FWER,'Partition.power'=test.result$Partition,'cv'=test.result$cv,'Partition.rejection'=test.result$Pvalue,'Hypotheses'=test.result$Hypotheses,'ComponentLRT'=test.result$ComponentLRT,'distr.null'=distr.null,'distr.alter'=distr.alter))
	}
	else{
		if(is.null(distr.null)){
			if(is.null(n))stop("Please specify sample size in each treatment groups and the control group.")
			if(is.null(distr.null.size))stop("Please specify how many samples are required for the null distribution.")
			distr.null=.rNull.dist(n=n,simu=distr.null.size,rho=0)
			cv<-.CLRT.PS4.cv(alpha=alpha,null=distr.null)
		}
		else cv<-.CLRT.PS4.cv(alpha=alpha,null=distr.null)
		if(savenull)return(list('alpha'=alpha,'cv'=cv,'distr.null'=distr.null))
		else return(list('alpha'=alpha,'cv'=cv))
	}
}


#This script has been used to generate the tSNE-plots for figure 8g in the paper "The
#heterogeneity of human CD127+ innate lymphoid cells revealed by single-cell RNA
#sequencing" by Björklund, Forkel et al.

# All data needed for the analysis is included in FACS_raw_protein_data_ILC.zip

# Copyright (c) 2015, Jakob Theorell <jakob.theorell@ki.se> for this script. For citation
#purposes, the user is referred to The Core Team of R, as well as the authors for every
#included package.
#
# Permission to use, copy, modify, and/or distribute this software for any
# purpose with or without fee is hereby granted, provided that the above
# copyright notice and this permission notice appear in all copies.
#
# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

#Packages needed for preprocessing
library(plyr)

#Packages needed for Barnes-Hut SNE
library(Rtsne)

#Packages needed for graphic display/density estimates
library(gplots)
library(ggplot2)
library(RColorBrewer)
library(grid)
library(rgl)
library(MASS)

#Create a new folder if it is not already present and change the working directory there (this will be iterated multiple times below)
setwd("~/Desktop/")
subDir <- "SNE_mapper"
if (! file.exists(subDir)){
  dir.create(subDir)
}
setwd("~/Desktop/SNE_mapper/")

subDir <- "Data"
if (! file.exists(subDir)){
  dir.create(subDir)
}
setwd("~/Desktop/SNE_mapper/Data/")

#Move raw files into this directory
file.rename("~/Desktop/Raw_data_ILC", "~/Desktop/SNE_mapper/Data/Raw_data_ILC")

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

#Import the raw data. For three of the files, a warning is generated, but it does not have any impact on the data.
setwd("~/Desktop/SNE_mapper/Data/Raw_data_ILC/")
filenames <- list.files(path = ".", pattern = NULL, all.files = FALSE, full.names = FALSE, recursive = FALSE, ignore.case = FALSE)
 read_csv_filename <- function(filename){
    ret <- read.csv(filename)
    id <- gsub(pattern="ILC_..._......._|\\.csv", "\\1", filename)
    ret$id <- id
    label <- gsub(pattern="ILC_..._|_.......\\.csv", "\\1", filename)
    ret$label <- label

    ret
 }
raw_data <- ldply(filenames, read_csv_filename)

setwd("~/Desktop/SNE_mapper/Data/")
write.csv(raw_data, "all_data_before_raw.csv", row.names=FALSE)

colnames(raw_data)

colnames(raw_data) <- c("CD45RA", "HLA.DR", "CD62L", "NKp44", "ids", "label")

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

#Creates a data frame with the full-range indata-parameters.
indata_full <- subset(raw_data, select=c("CD45RA", "HLA.DR", "CD62L", "NKp44"))

#Display the column names
colnames(indata_full)

#Turn each column of the data frame into percentages of the range between the highest and the lowest values
indata_percent <- 100*((indata_full-apply(indata_full, 2, min, na.rm=TRUE)[col(indata_full)])/(apply(indata_full, 2, max, na.rm=TRUE)[col(indata_full)]-apply(indata_full, 2, min, na.rm=TRUE)[col(indata_full)]))

setwd("~/Desktop/SNE_mapper/Data")
write.csv(indata_percent, "All_indata.csv", row.names=FALSE)

#############################################################
#Generate the tSNE parameters

twodimSNE <- Rtsne(as.matrix(indata_percent), perplexity=30, theta=0.5)

write.csv(twodimSNE, "Result.csv", row.names=FALSE)

twodimSNEY <- twodimSNE$Y

colnames(twodimSNEY) <- c("V1", "V2")

#Turn each column of the data frame into percentages of the range between the highest and the lowest values
percent_result <- 100*((twodimSNEY-apply(twodimSNEY, 2, min, na.rm=TRUE)[col(twodimSNEY)])/(apply(twodimSNEY, 2, max, na.rm=TRUE)[col(twodimSNEY)]-apply(twodimSNEY, 2, min, na.rm=TRUE)[col(twodimSNEY)]))

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

#Sort the variables into categorical and quantitative variables, i e
quantitative <- raw_data[ , -which(colnames(raw_data) %in% c("ids", "label"))]
categorical <- raw_data[ , which(colnames(raw_data) %in% c("ids", "label"))]

#4 Normalize the most extreme low and high per mille of the events to their lower end, so they will not influence the graphical display. This does not have any effect of the SNE parameter generation.
for (i in 1:length(quantitative)){
    cat(i,"\n")

    x <- quantile(quantitative[[i]], c(.999))
    y <- quantile(quantitative[[i]], c(.001))

    print(x)
    print(y)

    quantitative[[i]][quantitative[[i]] > x] <- x
    quantitative[[i]][quantitative[[i]] < y] <- y
}

#Turn each column of the data frame into percentages of the range between the highest and the lowest values
percent_quantitative <- 100*((quantitative-apply(quantitative, 2, min, na.rm=TRUE)[col(quantitative)])/(apply(quantitative, 2, max, na.rm=TRUE)[col(quantitative)]-apply(quantitative, 2, min, na.rm=TRUE)[col(quantitative)]))

Percent_all_data <- cbind(percent_quantitative, percent_result, categorical)

#Export this
setwd("~/Desktop/SNE_mapper/Data")
write.csv(Percent_all_data, "Percent_all_data.csv", row.names=FALSE)

#Stupid to solve problem with id not being values, but a string of some other kind.
Percent_all_data <- read.csv("Percent_all_data.csv")
#############################################################

#Plotting of all the flow cytometry variables

setwd("~/Desktop/SNE_mapper/")
subDir <- "Graphics"
if (! file.exists(subDir)){
  dir.create(subDir)
}
setwd("~/Desktop/SNE_mapper/Graphics/")

#Save the palette. This is necessary for a correct color representation below.
pdf("palette.pdf")
palette(rev(rich.colors(100, plot=TRUE)))
dev.off()

#The label parameter has been given values that corresponds to nice shapes in ggplot2. Therefore:
cols <- Percent_all_data$ids

#Make contour plot of the subpopulations
fname3 = paste("Subpop_combined",'.pdf')
p <- ggplot(Percent_all_data,aes(x=V1,y=V2)) +
    	geom_point(col=cols, size=2.2, alpha=0.7) 	+  xlim(-10, 110) + ylim(-10, 110) +
    	theme (line = element_blank(),
        		text = element_blank(),
        		line = element_blank(),
        		title = element_blank(),
				panel.background = element_rect(fill = "white"))
gt <- ggplot_gtable(ggplot_build(p))
ge <- subset(gt$layout, name == "panel")
grid.draw(gt[ge$t:ge$b, ge$l:ge$r])
ggsave(filename = fname3, dpi=300)

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

#Figures for all the fluorescent parameters are sorted into a specific folder
setwd("~/Desktop/SNE_mapper/Graphics")
subDir <- "Indata_params"
if (! file.exists(subDir)){
  dir.create(subDir)
}
setwd("~/Desktop/SNE_mapper/Graphics/Indata_params")

Indata_plotting <- Percent_all_data[ , which(colnames(Percent_all_data) %in% c(colnames(indata_percent)))]

#Make contour plot of all the populations with color representing each csv column.
for (i in 1:length(Indata_plotting)){
    cat(i,"\n")
    graphics.off()

    #graphs
    fname3 = paste(colnames(Indata_plotting[i]),'.pdf')

    p <- ggplot(Percent_all_data,aes(x=V1,y=V2)) +
    	geom_point(col=(1 + 0.98*(102-Indata_plotting[[i]])), size=2.5, alpha=0.7) + xlim(-10, 110) + ylim(-10, 110) +
    	theme (line = element_blank(),
        		text = element_blank(),
        		line = element_blank(),
        		title = element_blank(),
				panel.background = element_rect(fill = "white"))
	gt <- ggplot_gtable(ggplot_build(p))
	ge <- subset(gt$layout, name == "panel")

	grid.draw(gt[ge$t:ge$b, ge$l:ge$r])

    #Save file
    ggsave(filename = fname3, dpi=300)
}

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

#Figures for the label plot is sorted separately
setwd("~/Desktop/SNE_mapper/Graphics")
subDir <- "Donor_distribution"
if (! file.exists(subDir)){
  dir.create(subDir)
}
setwd("~/Desktop/SNE_mapper/Graphics/Donor_distribution")

cols <- Percent_all_data$label

#Make contour plot of the label parameter
fname3 = paste("Donors_adults",'.pdf')
p <- ggplot(Percent_all_data,aes(x=V1,y=V2)) +
    	geom_point(col=cols, size=2.5, alpha=0.5) 	+  xlim(-10, 110) + ylim(-10, 110) +
    	theme (line = element_blank(),
        		text = element_blank(),
        		line = element_blank(),
        		title = element_blank(),
				panel.background = element_rect(fill = "white"))
gt <- ggplot_gtable(ggplot_build(p))
ge <- subset(gt$layout, name == "panel")
grid.draw(gt[ge$t:ge$b, ge$l:ge$r])
ggsave(filename = fname3, dpi=300)


#' Covert grid reference to latitude and longitude
#'
#' @export
#' @param gridref a vector of strings giving grid references to be changed
#' @param precision gives the precision of the grid references. Must be of
#'        the same length as gridref. precision is given in meters as a numeric
#'        i.e. 10km square = 10000, 1km square = 1000. If NULL then the function
#'        tries to work out the precision itself.
#' @param centre If \code{TRUE} the coordinates for the centre of the cell are given
#'        else if \code{FALSE} the coordinates for the bottom left corner are given.
#' @return A dataframe of results are returned
#' @keywords mapping latitude longitude grid-reference
#' @examples
#'
#' gr2gps_latlon('SU616896')

gr2gps_latlon = function(gridref, precision = NULL, centre = TRUE){
    # NOTE FOR UTM30 gridrefs then no need to use helmert transformation as lat long are already in correct projection

    # Setup up variable to hold final output
    out_latlon = data.frame(LATITUDE = rep(NA, length(gridref)), LONGITUDE = rep(NA, length(gridref)))

    # Determine eastings & northings
    org_en = gr_let2num(gridref, centre = centre, gr_prec = precision, return_projection = TRUE)

    # Determine lat lon (original projection)
    out_latlon = OSGridstoLatLong(org_en$EASTING, org_en$NORTHING, org_en$PROJECTION)

    # Determine indices of gridrefs that are not UTM30 (which will need transformed)
    i_trans = which(!org_en$PROJECTION %in% c("UTM30","WGS84", NA))

	# Determine whether any supplied grid references need reprojection (i.e. are any grid references from UK, Ireland)
	if(length(i_trans) > 0){
		# Determine Cartesian (Original projection)
		org_cart = LatLong_Cartesian(out_latlon$LATITUDE[i_trans], out_latlon$LONGITUDE[i_trans], org_en$PROJECTION[i_trans])

		# Apply Helmert transformation to convert original projections to WGS84 (Cartesian in WGS84)
		helm_tran = helmert_trans(x =org_cart$x, y = org_cart$y, z = org_cart$z, trans = paste(org_en$PROJECTION[i_trans],"toWGS84", sep=""))

		# Convert Cartesian coordinates to Latitude/Longitude (Lat Lon in WGS84)
		out_latlon[i_trans,] = Cartesian_LatLong(helm_tran$x, helm_tran$y, helm_tran$z, "UTM30")
    }
    # Return output
    return(out_latlon)
}

#### ADDINTIONAL FUNCTIONS ####

gr_det_country <-
    function(gridref){
        # Create variable to store output
        cty_out = rep(NA, length(gridref))

        "(^[[:upper:]]{1,2}[[:digit:]]{2}([[:upper:]]?|[[:upper:]]{2})$)|(^[[:upper:]]{1,2}[[:digit:]]{2,}$)"

        # Find British Gridrefs
        cty_out[grepl('(^[[:upper:]]{2}[[:digit:]]{2}([[:upper:]]?|[[:upper:]]{2})$)|(^[[:upper:]]{2}[[:digit:]]{2,}$)',gridref) & !grepl('^(WA)|(WV)',gridref)] = "OSGB"

        # Find Irish Gridrefs
        cty_out[grepl('(^[[:upper:]]{1}[[:digit:]]{2}([[:upper:]]?|[[:upper:]]{2})$)|(^[[:upper:]]{1}[[:digit:]]{2,}$)',gridref)] = "OSNI"

        # Find Channel Islands Gridrefs
        cty_out[grepl('(^(WA)|(WV)[[:digit:]]{2}([[:upper:]]?|[[:upper:]]{2})$)|(^(WA)|(WV)[[:digit:]]{2,}$)',gridref)] = "UTM30"

        # Return output object
        return(cty_out)
    }

gr_let2num <-
    function(gridref, centre = FALSE, gr_prec = NULL, return_projection = FALSE){
        # Function required to calculate easting in Letter Grid
        spmod = function(x, mod){
            ret_obj = x %% mod
            ret_obj[ret_obj == 0] = mod
            return(ret_obj)
        }

        # Validate grid reference format (removing any spaces or hyphens)
        gr_comps = gr_components(gridref)
        gridref = gsub("[ -]","",toupper(gridref))

        # Setup variable to hold output
        len_grvec = nrow(gr_comps)
        if(return_projection){
            ret_obj = data.frame( EASTING = rep(NA,len_grvec), NORTHING = rep(NA, len_grvec), PROJECTION = rep(NA, len_grvec), row.names = NULL ) # row.names set to null to stop duplicate row names error
        } else {
            ret_obj = data.frame( EASTING = rep(NA,len_grvec), NORTHING = rep(NA, len_grvec), row.names = NULL ) # row.names set to null to stop duplicate row names error
        }

        # First find all British Gridrefs
        cty_inds = which(grepl('(^[[:upper:]]{2}[[:digit:]]{2}([[:upper:]]?|[[:upper:]]{2})$)|(^[[:upper:]]{2}[[:digit:]]{2,}$)',gr_comps$VALID_GR) & !grepl('^(WA)|(WV)',gr_comps$VALID_GR))

        # If British Gridrefs found then calc easting and northings
        if(length(cty_inds) > 0){
            # Get position of gridref letters in grid
            l1 = match(substr(gr_comps$CHARS[cty_inds],1,1), LETTERS[-9])
            l2 = match(substr(gr_comps$CHARS[cty_inds],2,2), LETTERS[-9])
            # Determine initial easting northing digits based on 500km square
            e = (spmod(l1,5) - 1)*5
            n = floor(abs(l1 - 25)/5)*5
            # Modify initial easting/northing digits based on 100km square
            e = e + (spmod(l2,5) - 1)
            n = n + floor(abs(l2 - 25)/5)
            # Recalulate for false origin (SV) of British Grid
            e = e - 10
            n = n - 5
            # Extend so easting and northing digits so that nchars of east_num/north_num = 5 right padded with zeros
            east_num = gsub(" ","0", format(gr_comps$DIGITS_EAST[cty_inds], width = 5))
            north_num = gsub(" ","0", format(gr_comps$DIGITS_NORTH[cty_inds], width = 5))
            # append numeric part of references to grid index
            e = paste(e,east_num, sep="")
            n = paste(n,north_num, sep="")
            # Overwrite placeholder values in ret_obj
            ret_obj[cty_inds,c("EASTING", "NORTHING")] = c(as.numeric(e), as.numeric(n))
            if(return_projection){
                ret_obj[cty_inds,"PROJECTION"] = "OSGB"
            }
        }

        # Find all Irish Gridrefs
        cty_inds = which(grepl('(^[[:upper:]]{1}[[:digit:]]{2}([[:upper:]]?|[[:upper:]]{2})$)|(^[[:upper:]]{1}[[:digit:]]{2,}$)',gr_comps$VALID_GR))
        # If Irish Gridrefs found the calc easting and northings
        if(length(cty_inds) > 0){
            # Get position of gridref letters in grid
            l2 = match(substr(gr_comps$CHARS[cty_inds],1,1), LETTERS[-9])
            # Determine initial easting/northing digits based on 100km square
            e = spmod(l2,5) - 1
            n = floor(abs(l2 - 25)/5)
            # Extend so easting and northing digits so that nchars of east_num/north_num = 5 right padded with zeros
            east_num = gsub(" ","0", format(gr_comps$DIGITS_EAST[cty_inds], width = 5))
            north_num = gsub(" ","0", format(gr_comps$DIGITS_NORTH[cty_inds], width = 5))
            # append numeric part of references to grid index
            e = paste(e,east_num, sep="")
            n = paste(n,north_num, sep="")
            # Overwrite placeholder values in ret_obj
            ret_obj[cty_inds,c("EASTING", "NORTHING")] = c(as.numeric(e), as.numeric(n))
            if(return_projection){
                ret_obj[cty_inds,"PROJECTION"] = "OSNI"
            }
        }

        # Find all Channel Islands Gridrefs
        cty_inds = which(grepl('(^(WA)|(WV)[[:digit:]]{2}([[:upper:]]?|[[:upper:]]{2})$)|(^(WA)|(WV)[[:digit:]]{2,}$)',gr_comps$VALID_GR))
        # If CI gridrefs found then calc easting and northings
        if(length(cty_inds) > 0){
            # Determine initial easting/northing based on letters
            e = rep(5, length(cty_inds))
            n = ifelse(grepl('^(WA)[[:digit:]]{2,}$',gr_comps$VALID_GR[cty_inds]),55,54)
            # Extend so easting and northing digits so that nchars of east_num/north_num = 5 right padded with zeros
            east_num = gsub(" ","0", format(gr_comps$DIGITS_EAST[cty_inds], width = 5))
            north_num = gsub(" ","0", format(gr_comps$DIGITS_NORTH[cty_inds], width = 5))
            # append numeric part of references to grid index
            e = paste(e,east_num, sep="")
            n = paste(n,north_num, sep="")
            # Overwrite placeholder values in ret_obj
            ret_obj[cty_inds,c("EASTING", "NORTHING")] = c(as.numeric(e), as.numeric(n))
            if(return_projection){
                ret_obj[cty_inds,"PROJECTION"] = "UTM30"
            }
        }

        # If any grid refs contained a tetrad or quadrant code then need to modify the easting and northing
        # Find all grid refs with a tetrad code
        cty_inds = which(!is.na(gr_comps$TETRAD))
        # For these grid refs modify the eastings and northings accordingly
        if(length(cty_inds) > 0){
            # Get list of tetrad codes (all letters but O)
            tet_codes = LETTERS[-15]
            # Determine the position in the tetrad codes vector for each code
            code_match = match(gr_comps$TETRAD[cty_inds], tet_codes)
            # Modify easting
            ret_obj[cty_inds, "EASTING"] = ret_obj[cty_inds,"EASTING"] + ((code_match-1) %/% 5)*2000
            # Modify northing
            ret_obj[cty_inds, "NORTHING"] = ret_obj[cty_inds,"NORTHING"] + ((code_match-1) %% 5)*2000
        }

        # Find all grid refs with a quadrant code
        cty_inds = which(!is.na(gr_comps$QUADRANT))
        # For these grid refs modify the eastings and northings accordingly
        if(length(cty_inds) > 0){
            # Get list of tetrad codes (all letters but O)
            quad_codes = c("SW","NW","SE","NE")
            # Determine the position in the tetrad codes vector for each code
            code_match = match(gr_comps$QUADRANT[cty_inds], quad_codes)
            # Modify easting
            ret_obj[cty_inds, "EASTING"] = ret_obj[cty_inds,"EASTING"] + ((code_match-1) %/% 2)*5000
            # Modify northing
            ret_obj[cty_inds, "NORTHING"] = ret_obj[cty_inds,"NORTHING"] + ((code_match-1) %% 2)*5000
        }

        # If centre is true the determine precision and give easting and northing for centre of gridref
        if(centre){
            # Determine precision (if gr_prec not supplied)
            if(is.null(gr_prec)){
                gr_prec = gr_comps$PRECISION
            }
            # Add half of precision to easting and northing
            ret_obj[,c("EASTING", "NORTHING")] = ret_obj[,c("EASTING", "NORTHING")] + (gr_prec/2)
        }
        # Return easting and Northings
        return(ret_obj)
    }

OSGridstoLatLong <-
    function(Easting, Northing, Datum = "OSGB", datum_params = NULL, full_output = FALSE) {
        # If datum_params is null then defaults data.frame included with package will be used
        if(is.null(datum_params)){

            # Set datum_params to datum_vars
            datum_params = datum_vars
        }

        # Determine length of Easting & check same as Northing
        east_len = length(Easting)
        if(length(Northing) != east_len){
            stop("ERROR: 'Easting' & 'Northing' are of different lengths")
        }

        # Get list of Datums to be converted from Datum
        # If length of Datum input not 1 or same length as Easting/Northing then stop
        if(!length(Datum) %in% c(1,east_len)){
            stop("ERROR: Length of 'Datum' does not match length of Easting/Northing values")
        }
        datum_list = na.omit(unique(Datum))
        # Check all Datum are in datum_params data frame
        miss_datum = which(!datum_list %in% datum_params$Datum)
        if(length(miss_datum) > 0){
            stop(paste("ERROR: Datum present in data for which parameters have not been given (",paste(sQuote(datum_list[miss_datum]), collapse=","), ")", sep=""))
        }

        # Setup object to hold output data
        if(full_output){
            ret_obj = data.frame(EASTING = Easting, NORTHING = Northing, DATUM = Datum, LATITUDE = rep(NA, east_len), LONGITUDE =rep(NA, east_len), stringsAsFactors = FALSE)
        } else {
            ret_obj = data.frame(LATITUDE = rep(NA, east_len), LONGITUDE =rep(NA, east_len), stringsAsFactors = FALSE)
        }

        # Loop through datum and extract params and then calculate lat long
        for(i_datum in 1:length(datum_list)){

            # Extract indices of easting/northing values corresponding to current datum
            if(length(Datum) == 1){
                dat_inds = 1:east_len
            } else {
                dat_inds = which(Datum == datum_list[i_datum])
            }

            # Extract datum params from datum_params (at same time covert lat0 and lon0 from degrees to radians
            par_ind = which(datum_params$Datum == datum_list[i_datum])
            # Check only one row of datum parameters data frame matches current datum
            if(length(par_ind) > 1){
                stop(paste("ERROR: More than one match for current Datum (",sQuote(datum_list[i_datum]),") found in datum_params data frame",sep=""))
            }
            a = datum_params$a[par_ind]
            b = datum_params$b[par_ind]
            F0 = datum_params$F0[par_ind]
            lat0 = datum_params$lat0[par_ind] * (pi/180) # Converting to radians
            lon0 = datum_params$lon0[par_ind] * (pi/180) # Converting to radians
            N0 = datum_params$N0[par_ind]
            E0 = datum_params$E0[par_ind]

            # Calculate other derived variables for projection/datum
            e2 = 1 - (b^2)/(a^2)		# eccentricity squared
            n = (a-b)/(a+b)
            n2 = n^2   					# Calculate n squared (used several times so store as variable)
            n3 = n^3					# Calculate n cubed (used several times so store as variable)

            # Iterate to estimate value of lat and M
            # Intial values
            # Lat
            lat = ( (Northing[dat_inds] - N0) / (a * F0) ) + lat0
            # Meridional Arc
            Ma = ( 1 + n + ((5/4)*n2) + ((5/4)*n3) ) * (lat-lat0)
            Mb = ( (3*n) + (3*n2) + ((21/8)*n3) ) * sin(lat-lat0) * cos(lat+lat0)
            Mc = ( ((15/8)*n2) + ((15/8)*n3) ) * sin(2*(lat-lat0)) * cos(2*(lat+lat0))
            Md = ( (35/24)*n3) * sin(3*(lat-lat0)) * cos(3*(lat+lat0))
            M = (b * F0) * (Ma - Mb + Mc - Md)			# Calculate Developed Meridional arc (M)
            # Setup index for lats that need further iteration
            iter_inds = which(abs( Northing[dat_inds] - N0 - M) >= 0.01)
            while(length(iter_inds) > 0){
                # Lat
                lat[iter_inds] = ( (Northing[dat_inds][iter_inds] - N0 - M[iter_inds]) / (a * F0) ) + lat[iter_inds]
                # Meridional Arc
                Ma[iter_inds] = ( 1 + n + ((5/4)*n2) + ((5/4)*n3) ) * (lat[iter_inds]-lat0)
                Mb[iter_inds] = ( (3*n) + (3*n2) + ((21/8)*n3) ) * sin(lat[iter_inds]-lat0) * cos(lat[iter_inds]+lat0)
                Mc[iter_inds] = ( ((15/8)*n2) + ((15/8)*n3) ) * sin(2*(lat[iter_inds]-lat0)) * cos(2*(lat[iter_inds]+lat0))
                Md[iter_inds] = ( (35/24)*n3) * sin(3*(lat[iter_inds]-lat0)) * cos(3*(lat[iter_inds]+lat0))
                M[iter_inds] = (b * F0) * (Ma[iter_inds] - Mb[iter_inds] + Mc[iter_inds] - Md[iter_inds])			# Calculate Developed Meridional arc (M)
                # Recalculate iteration index
                iter_inds = which(abs( Northing[dat_inds] - N0 - M) >= 0.01)
            }

            sinLat = sin(lat)
            tanLat = tan(lat)
            tan2Lat = tanLat^2
            tan4Lat = tanLat^4
            tan6Lat = tanLat^6
            secLat = 1 / cos(lat)

            elon = Easting[dat_inds] - E0

            nu = (a * F0)*(1-e2*sinLat^2)^-0.5              # transverse radius of curvature
            rho = (a * F0) * (1-e2)*(1-e2*sinLat^2)^-1.5   # meridional radius of curvature
            eta2 = (nu/rho)-1								# East-west component of the deviation of the vertical squared

            VII = tanLat / (2*rho*nu)
            VIII = ( tanLat / (24*rho*nu^3) ) * ( 5 + (3*tan2Lat) + eta2 - (9 * tan2Lat * eta2) )
            IX = (tanLat/(720*rho*nu^5)) * (61 + (90*tan2Lat) + (45*tan4Lat))
            X = secLat / nu
            XI = (secLat / (6 * nu^3)) * ( (nu/rho) + 2*tan2Lat)
            XII = (secLat / (120 * nu^5)) * (5 + (28*tan2Lat) + (24*tan4Lat))
            XIIA = (secLat / (5040 * nu^7)) * (61 + (662*tan2Lat) + (1320*tan4Lat) + (720*tan6Lat))

            Lat_rad = lat - (VII*elon^2) + (VIII*elon^4) - (IX*elon^6)
            Long_rad = lon0 + (X*elon) - (XI*elon^3) + (XII*elon^5) - (XIIA*elon^7)

            Latitude = Lat_rad * (180/pi)
            Longitude = Long_rad * (180/pi)

            ret_obj[dat_inds,c("LATITUDE","LONGITUDE")] = data.frame(Latitude, Longitude)
        }
        return (ret_obj)
    }

LatLong_Cartesian <-
    function(Latitude, Longitude, Datum = "OSGB", datum_params = NULL, H = NULL, full_output = FALSE){
        # If datum_params is null then defaults data.frame included with package will be used
        if(is.null(datum_params)){
            # Set datum_params to datum_vars
            datum_params = datum_vars
        }

        # Determine length of Latitude & check same as Longitude
        lat_len = length(Latitude)
        if(length(Longitude) != lat_len){
            stop("ERROR: 'Latitude' & 'Longitude' are of different lengths")
        }

        # Get list of Datums to be converted from Datum
        # If length of Datum input not 1 or same length as Latitude/Longitude then stop
        if(!length(Datum) %in% c(1,lat_len)){
            stop("ERROR: Length of 'Datum' does not match length of Latitude/Longitude values")
        }
        datum_list = na.omit(unique(Datum))
        # Check all Datum are in datum_params data frame
        miss_datum = which(!datum_list %in% datum_params$Datum)
        if(length(miss_datum) > 0){
            stop(paste("ERROR: Datum present in data for which parameters have not been given (",paste(sQuote(datum_list[miss_datum]), collapse=","), ")", sep=""))
        }

        # Setup object to hold output data (Cartesian Coordinates)
        if(full_output){
            ret_obj = data.frame(LATITUDE = Latitude, LONGITUDE = Longitude, DATUM = Datum, x = rep(NA, lat_len), y = rep(NA, lat_len), z = rep(NA, lat_len),  stringsAsFactors = FALSE)
        } else {
            ret_obj = data.frame(x = rep(NA, lat_len), y = rep(NA, lat_len), z = rep(NA, lat_len), stringsAsFactors = FALSE)
        }

        # Loop through datum and extract params and then calculate Cartesian Coordinates
        for(i_datum in 1:length(datum_list)){

            # Extract indices of lat/long values corresponding to current datum
            if(length(Datum) == 1){
                dat_inds = 1:lat_len
            } else {
                dat_inds = which(Datum == datum_list[i_datum])
            }

            # Extract datum params from datum_params (at same time covert lat0 and lon0 from degrees to radians
            par_ind = which(datum_params$Datum == datum_list[i_datum])
            # Check only one row of datum parameters data frame matches current datum
            if(length(par_ind) > 1){
                stop(paste("ERROR: More than one match for current Datum (",sQuote(datum_list[i_datum]),") found in datum_params data frame",sep=""))
            }
            a = datum_params$a[par_ind]
            b = datum_params$b[par_ind]

            # Height (H) assummed to be 0 unless specified
            if(is.null(H)){
                H = 0
            } else {
                H = H
            }

            # Convert latitude/longitude values into radians
            lat = Latitude[dat_inds] * (pi/180)
            lon = Longitude[dat_inds] * (pi/180)

            # Calculate eccentricity squared (e2)
            e2 = (a^2 - b^2)/a^2

            # Calculate Cartezian coordinates
            v = a / sqrt(1 - e2*sin(lat)^2)
            x = (v + H)*cos(lat)*cos(lon)
            y = (v + H)*cos(lat)*sin(lon)
            z = (((1-e2)*v) + H)*sin(lat)

            # Write values to ret_obj
            ret_obj[dat_inds,c("x","y","z")] = data.frame(x,y,z)

        }
        return(ret_obj)
    }

helmert_trans <-
    function(x, y, z, trans = "OSNItoOSGB", trans_params = NULL, full_output = FALSE){
        # If trans_params is null then check where helmert_trans_vars data.frame has been loaded from package
        if(is.null(trans_params)){

            # set trans_params = helmert_trans_vars
            trans_params = helmert_trans_vars
        }

        # Determine length of input vars x,y,z and check all 3 variables are same length
        len_x = length(x)
        if(length(y) != len_x | length(z) != len_x){
            stop("ERROR: input variables 'x', 'y' and 'z' are of different lengths")
        }

        # Get list of trans to be performed from trans
        # If length of trans input not 1 or same length as input vars then stop
        if(!length(trans) %in% c(1,len_x)){
            stop("ERROR: Length of 'trans' does not match length of input 'x','y' & 'z' values")
        }
        trans_list = unique(trans)
        # Check all Datum present in data are in datum_params data frame
        miss_trans = which(!trans_list %in% trans_params$TRANS)
        if(length(miss_trans) > 0){
            stop(paste("ERROR: Transformation requested for which parameters have not been given (",paste(sQuote(trans_list[miss_trans]), collapse=","), ")", sep=""))
        }

        # Setup object to hold output data (x,y,z)
        if(full_output){
            ret_obj = data.frame(org_x = x, org_y = y, org_z = z, TRANS = trans, x = rep(NA, len_x), y = rep(NA, len_x), z = rep(NA, len_x), stringsAsFactors = FALSE)
        } else {
            ret_obj = data.frame(x = rep(NA, len_x), y = rep(NA, len_x), z = rep(NA, len_x), stringsAsFactors = FALSE)
        }

        # Loop through transformations and extract params and then perform helmert transformation
        for(i_trans in 1:length(trans_list)){
            # Extract indices of x,y,z values corresponding to current transformation
            if(length(trans) == 1){
                dat_inds = 1:len_x
            } else {
                dat_inds = which(trans == trans_list[i_trans])
            }
            # Select relevant helmert transformation parameters
            tp = trans_params[trans_params$TRANS == trans_list[i_trans],]
            # Convert trans paras for rotation from degress to radians
            tp[,c("rx","ry","rz")] = (tp[,c("rx","ry","rz")]/3600) * (pi/180)
            # Normalise s to ppm
            tp[,"s"] = tp$s*1e-6
            # Apply transformation
            x_out = x[dat_inds] + (x[dat_inds]*tp$s) - (y[dat_inds]*tp$rz) + (z[dat_inds]*tp$ry) + tp$tx
            y_out = (x[dat_inds]*tp$rz) + y[dat_inds] + (y[dat_inds]*tp$s) - (z[dat_inds]*tp$rx) + tp$ty
            z_out = (-1*x[dat_inds]*tp$ry) + (y[dat_inds]*tp$rx) + z[dat_inds] + (z[dat_inds]*tp$s) + tp$tz

            # Insert transformed cartesian coordincates into output variable
            ret_obj[dat_inds,c("x","y","z")] = data.frame(x = x_out, y = y_out, z = z_out)
        }
        return(ret_obj)
    }

Cartesian_LatLong <-
    function(x,y,z, Datum = "OSGB", datum_params = NULL, full_output = FALSE ){
        # If datum_params is null then defaults data.frame included with package will be used
        if(is.null(datum_params)){
            # Determine if datum variables data.frame is already loaded from package

            # Set datum_params to datum_vars
            datum_params = datum_vars
        }

        # Determine length of input vars x,y,z and check all 3 variables are same length
        len_x = length(x)
        if(length(y) != len_x | length(z) != len_x){
            stop("ERROR: input variables 'x', 'y' and 'z' are of different lengths")
        }

        # Get list of Datums to be converted from Datum
        # If length of Datum input not 1 or same length as input vars then stop
        if(!length(Datum) %in% c(1,len_x)){
            stop("ERROR: Length of 'Datum' does not match length of input 'x','y' & 'z' values")
        }
        datum_list = na.omit(unique(Datum))
        # Check all Datum present in data are in datum_params data frame
        miss_datum = which(!datum_list %in% datum_params$Datum)
        if(length(miss_datum) > 0){
            stop(paste("ERROR: Datum present in data for which parameters have not been given (",paste(sQuote(datum_list[miss_datum]), collapse=","), ")", sep=""))
        }

        # Setup object to hold output data (Latitude/Longitude)
        if(full_output){
            ret_obj = data.frame(x = x, y = y, z = z, DATUM = Datum, LATITUDE = rep(NA, len_x), LONGITUDE = rep(NA, len_x), HEIGHT = rep(NA, len_x), stringsAsFactors = FALSE)
        } else {
            ret_obj = data.frame(LATITUDE = rep(NA, len_x), LONGITUDE = rep(NA, len_x), stringsAsFactors = FALSE)
        }

        # Setup precision variable (used to determine when to stop iteration)
        prec = 1

        # Loop through datum and extract params and then calculate Latitude and Longitude
        for(i_datum in 1:length(datum_list)){

            # Extract indices of lat/long values corresponding to current datum
            if(length(Datum) == 1){
                dat_inds = 1:len_x
            } else {
                dat_inds = which(Datum == datum_list[i_datum])
            }

            # Extract datum params from datum_params (at same time covert lat0 and lon0 from degrees to radians
            par_ind = which(datum_params$Datum == datum_list[i_datum])
            # Check only one row of datum parameters data frame matches current datum
            if(length(par_ind) > 1){
                stop(paste("ERROR: More than one match for current Datum (",sQuote(datum_list[i_datum]),") found in datum_params data frame",sep=""))
            }
            a = datum_params$a[par_ind]
            b = datum_params$b[par_ind]

            # Calculate eccentricity squared (e2)
            e2 = (a^2 - b^2)/a^2

            # Determine longitude
            lon = atan(y[dat_inds]/x[dat_inds])
            # Iteratively determine latitude
            p = sqrt(x[dat_inds]^2 + y[dat_inds]^2)
            lat = atan( z[dat_inds] / (p * (1 - e2)) )
            v = a / sqrt(1 - e2*sin(lat)^2)
            lat2 = atan( (z[dat_inds] + e2*v*sin(lat))/p )
            d_lat = lat - lat2
            iter_inds = which(d_lat > prec)
            while(length(iter_inds) > 0){
                # Change lat to lat2 and recalculate lat2
                lat[iter_inds] = lat2[iter_inds]
                v[iter_inds] = a[dat_inds][iter_inds] / sqrt(1 - e2*sin(lat[iter_inds])^2)
                lat2[iter_inds] = atan( (z[dat_inds][iter_inds] + e2*v[iter_inds]*sin(lat[iter_inds]))/p[iter_inds] )
                d_lat[iter_inds] = lat[iter_inds] - lat2[iter_inds]
                # Recalculate which rows need further iteration
                iter_inds = which(d_lat > prec)
            }
            # Calculate Height (although in majority of cases not really needed/wanted)
            H = (p / cos(lat)) - v
            # Convert Lat / long back to degrees
            lat = lat * (180/pi)
            lon = lon * (180/pi)

            # Setup return object
            if(full_output){
                ret_obj[dat_inds,c("LATITUDE","LONGITUDE", "HEIGHT")] = data.frame(lat, lon, H)
            } else {
                ret_obj[dat_inds,c("LATITUDE","LONGITUDE")] = data.frame(lat, lon)
            }

        }
        # Return output object
        return(ret_obj)
    }

fmt_gridref = function(gridref, gr_fmt = NULL){
    # Setup object to hold output grid refs
    gr_out = rep(NA, length(gridref))
    # convert gridref string to upper case
    gridref = toupper(gridref)
    # Replace any spaces, punctuation or control characters
    gridref = gsub("[[:space:][:cntrl:][:punct:]]", "", gridref)
    # Check that gridref conforms to grid reference pattern after removals
    # Get indices of gridrefs which are in a valid format
    gr_inds = which(grepl("^[[:upper:]]{1,2}[[:digit:]]{2,}([[:upper:]]?|[[:upper:]]{2})$", gridref))
    # Copy valid gridrefs to output object
    gr_out[gr_inds] = gridref[gr_inds]
    # Extract components where gr_fmt is not NULL (1 = Whole gridref minus tet/quad codes, 2 = Inital letter(s), 3 = Digits only, 4 = Tetrad/Quad only, 5 = Tetrad only, 6 = Quadrant only)
    if(!is.null(gr_fmt)){
        gr_out = gsub("^(([[:upper:]]{1,2})([[:digit:]]{2,}))(([[:upper:]]?)|([[:upper:]]{2}))$", paste("\\",gr_fmt, sep=""), gr_out)
    }
    # Return formatted gridref
    return(gr_out)
}

det_gr_precision <- function(
    gridref
){
    # Convert letters to uppercase
    gridref = toupper(gridref)

    # Set up variable to store output
    prec_out = rep(NA,length(gridref))

    # Find valid gridrefs
    v_inds = which(grepl("(^[[:upper:]]{1,2}[[:digit:]]{2}([[:upper:]]?|[[:upper:]]{2})$)|(^[[:upper:]]{1,2}[[:digit:]]{2,}$)", gridref) & nchar(gsub("^(([[:upper:]]{1,2})([[:digit:]]{2,}))(([[:upper:]]?)|([[:upper:]]{2}))$", "\\3", gridref)) %% 2 == 0)

    # Split into components
    gr_char = gsub("^(([[:upper:]]{1,2})([[:digit:]]{2,}))(([[:upper:]]?)|([[:upper:]]{2}))$", "\\2", gridref[v_inds])
    gr_digits = gsub("^(([[:upper:]]{1,2})([[:digit:]]{2,}))(([[:upper:]]?)|([[:upper:]]{2}))$", "\\3", gridref[v_inds])
    gr_tet = gsub("^(([[:upper:]]{1,2})([[:digit:]]{2,}))(([[:upper:]]?)|([[:upper:]]{2}))$", "\\5", gridref[v_inds])
    gr_quad = gsub("^(([[:upper:]]{1,2})([[:digit:]]{2,}))(([[:upper:]]?)|([[:upper:]]{2}))$", "\\6", gridref[v_inds])

    # Determine number of digits pairs
    n_pairs = nchar(gr_digits)/2

    # Determine precison based on gr
    gr_prec = 10^5 / 10^n_pairs

    # If gr_tet contains valid letter then ignore precision based on gridref length and assign 2000
    gr_prec[gr_tet %in% LETTERS[-15]] = 2000
    # If not valid tetrad code in gr_tet then set to NA (i.e. O is not a valid tetrad code)
    gr_prec[!gr_tet %in% LETTERS[-15] & gr_tet != ""] = NA

    # If gr_quad contains valid letter then ignore precision based on gridref length and assign 5000
    gr_prec[gr_quad %in% c("NW","NE","SW","SE")] = 5000
    # If not valid quadrant code in gr_tet then set to NA
    gr_prec[!gr_quad %in% c("NW","NE","SW","SE") & gr_quad != ""] = NA

    # Write gr_prec values to output variable
    prec_out[v_inds] = gr_prec

    # Return output variable
    return(prec_out)
}
gr_components <- function(gridref, output_col = NULL){

    # Convert letters to uppercase
    gridref = toupper(gridref)

    # Set up variable to store output
    gr_comps = data.frame(GRIDREF = gridref, VALID_GR = NA, PRECISION = NA, CHARS = NA, DIGITS = NA, DIGITS_EAST = NA, DIGITS_NORTH = NA, TETRAD = NA, QUADRANT = NA)

    # Check values for output_col if supplied
    if(!is.null(output_col)){
        if(!all(toupper(output_col) %in% names(gr_comps))){
            stop("Supplied output column name not recognised, valid values are:\n\t", paste(shQuote(names(gr_comps)), collapse = ", "))
        }
    }

    # Find valid gridrefs
    v_inds = which(grepl("(^[[:upper:]]{1,2}[[:digit:]]{2}([[:upper:]]?|[[:upper:]]{2})$)|(^[[:upper:]]{1,2}[[:digit:]]{2,}$)", gsub("[ -]","",gridref)) & nchar(gsub("^(([[:upper:]]{1,2})([[:digit:]]{2,}))(([[:upper:]]?)|([[:upper:]]{2}))$", "\\3", gsub("[ -]","",gridref))) %% 2 == 0)

    if(length(v_inds) > 0){

        # Update valid gridrefs to data.frame
        gr_comps[v_inds,"VALID_GR"] = gsub("[ -]","", gridref[v_inds])

        # Split into components
        # Characters
        gr_comps[v_inds,"CHARS"] = gsub("^(([[:upper:]]{1,2})([[:digit:]]{2,}))(([[:upper:]]?)|([[:upper:]]{2}))$", "\\2", gr_comps$VALID_GR[v_inds])
        # Digits
        gr_comps[v_inds,"DIGITS"] = gsub("^(([[:upper:]]{1,2})([[:digit:]]{2,}))(([[:upper:]]?)|([[:upper:]]{2}))$", "\\3", gr_comps$VALID_GR[v_inds])
        # split digits into east and north
        len_digit = nchar(gr_comps$DIGITS[v_inds])
        gr_comps[v_inds, "DIGITS_EAST"] = substr(gr_comps$DIGITS[v_inds], 1, len_digit/2)
        gr_comps[v_inds, "DIGITS_NORTH"] = substr(gr_comps$DIGITS[v_inds], (len_digit/2)+1, len_digit)
        # Determine precision based on digits
        gr_comps[v_inds,"PRECISION"] = 10^5 / 10^(len_digit[v_inds]/2)
        # Tetrad
        gr_comps[v_inds,"TETRAD"] = gsub("^(([[:upper:]]{1,2})([[:digit:]]{2,}))(([[:upper:]]?)|([[:upper:]]{2}))$", "\\5", gr_comps$VALID_GR[v_inds])
        # Find blank string values in gr_tet and replace with NA
        na_inds = which(!gr_comps$TETRAD %in% LETTERS[-15])
        if(length(na_inds) > 0){
            gr_comps[na_inds,"TETRAD"] = NA
        }
        # Quadrant
        gr_comps[v_inds,"QUADRANT"] = gsub("^(([[:upper:]]{1,2})([[:digit:]]{2,}))(([[:upper:]]?)|([[:upper:]]{2}))$", "\\6", gr_comps$VALID_GR[v_inds])
        # Find blank string values in gr_tet and replace with NA
        na_inds = which(!gr_comps$QUADRANT %in% c("NW","NE","SW","SE"))
        if(length(na_inds) > 0){
            gr_comps[na_inds,"QUADRANT"] = NA
        }

        # Modify precision if tetrad or quadrant is not null
        # Tetrad
        gr_comps[grepl("^[[:upper:]]{1,2}[[:digit:]]{2}[[:upper:]]{1,2}$", gr_comps$VALID_GR) & !is.na(gr_comps$TETRAD),"PRECISION"] = 2000
        # quadrant
        gr_comps[grepl("^[[:upper:]]{1,2}[[:digit:]]{2}[[:upper:]]{1,2}$", gr_comps$VALID_GR) & !is.na(gr_comps$QUADRANT),"PRECISION"] = 5000

        # Modify valid_gr to remove any gridrefs that had non-valid tetrad/quadrant codes
        na_inds = which(grepl("^[[:upper:]]{1,2}[[:digit:]]{2}[[:upper:]]{1,2}$", gr_comps$VALID_GR) & is.na(gr_comps$TETRAD) & is.na(gr_comps$QUADRANT))
        if(length(na_inds) > 0){
            gr_comps[na_inds,-1] = NA
        }
    }

    # If output_col is null then output all columns otherwise only output requested columns
    if(is.null(output_col)){
        out_obj = gr_comps
    } else {
        out_obj = gr_comps[,toupper(output_col)]
    }

    # Return output object
    return(out_obj)
}

det_tet_quad <- function(
    gridref,
    precision = NULL,
    prec_out = NULL
){
    # Setup output object
    out_obj = data.frame(TETRAD_GR = rep(NA, length(gridref)), QUADRANT_GR = NA)

    # Split gridref into components (will also check gridref sytax is correct)
    gr_comps = gr_components(gridref)

    gr_inds = which(nchar(gr_comps$DIGITS) >= 2 & !is.na(gr_comps$VALID_GR))
    sq10 = rep(NA, length(gridref))
    sq10[gr_inds] = paste(gr_comps$CHARS[gr_inds], substr(gr_comps$DIGITS_EAST[gr_inds],1,1), substr(gr_comps$DIGITS_NORTH[gr_inds],1,1), sep="")

    # All gridrefs that have valid tetrad/quadrant codes can be filled directly to out_obj
    # Tetrads
    gr_inds = which(!is.na(gr_comps$TETRAD))
    if(length(gr_inds) > 0){
        out_obj[gr_inds,"TETRAD_GR"] = paste(sq10[gr_inds], gr_comps$TETRAD[gr_inds], sep="")
    }
    #Quadrants
    gr_inds = which(!is.na(gr_comps$QUADRANT))
    if(length(gr_inds) > 0){
        out_obj[gr_inds,"QUADRANT_GR"] = paste(sq10[gr_inds], gr_comps$QUADRANT[gr_inds], sep="")
    }

    # If original gridref had tetrad code then where can be mapped directly to quadrant then do so
    # Find gridrefs with calculated precision of 2000 i.e. those that had a tetrad code in the grid ref
    gr_inds = which(gr_comps$PRECISION == 2000)
    if(length(gr_inds) > 0){
        # SW
        gr_inds = which(gr_comps$PRECISION == 2000 & gr_comps$TETRAD %in% c("A","B","F","G"))
        if(length(gr_inds) > 0){
            out_obj[gr_inds,"QUADRANT_GR"] = paste(sq10[gr_inds], "SW", sep="")
        }
        # NW
        gr_inds = which(gr_comps$PRECISION == 2000 & gr_comps$TETRAD %in% c("D","E","J","I"))
        if(length(gr_inds) > 0){
            out_obj[gr_inds,"QUADRANT_GR"] = paste(sq10[gr_inds], "NW", sep="")
        }
        # SE
        gr_inds = which(gr_comps$PRECISION == 2000 & gr_comps$TETRAD %in% c("Q","R","V","W"))
        if(length(gr_inds) > 0){
            out_obj[gr_inds,"QUADRANT_GR"] = paste(sq10[gr_inds], "SE", sep="")
        }
        # NE
        gr_inds = which(gr_comps$PRECISION == 2000 & gr_comps$TETRAD %in% c("T","U","Y","Z"))
        if(length(gr_inds) > 0){
            out_obj[gr_inds,"QUADRANT_GR"] = paste(sq10[gr_inds], "NE", sep="")
        }
    }

    # Find all valid gridrefs where precision is high enough
    gr_inds = which(gr_comps$PRECISION <= 1000)

    if(length(gr_inds) > 0){

        # Extract relevant digits for tetrad/quadrant estimation
        code_e = as.numeric(substr(gr_comps$DIGITS_EAST[gr_inds],2,2))
        code_n = as.numeric(substr(gr_comps$DIGITS_NORTH[gr_inds],2,2))

        # Determine tetrad code from easting and northing digits (can perhaps
        # Get list of tetrad codes (no O)
        tet_codes = LETTERS[-15]
        # Get tetrad code for each gridref of suitable precision
        tets = tet_codes[(code_e%/%2)*5 + (code_n%/%2)+1]
        out_obj[gr_inds,"TETRAD_GR"] = paste(sq10[gr_inds],tets, sep="")

        # Determine quadrant codes from easting and northing digits
        # Build vector of quadrant codes (in correct order)
        quad_codes = c("SW","NW","SE","NE")
        # Get tetrad code for each gridref of suitable precision
        quads = quad_codes[(code_e%/%5)*2 + (code_n%/%5)+1]
        out_obj[gr_inds,"QUADRANT_GR"] = paste(sq10[gr_inds],quads, sep="")

    }

    # If precision is supplied determine if it matches value estimated from gridref
    if(!is.null(precision)){
        # Check that precision is either a vector of length gridref or a single value
        if( !(length(precision) == 1 | length(precision) == length(gridref)) ){
            stop("precision does not match gridref length, supply either single value or vector of same length as gridref")
        }
        # Find non-matching precisions
        # Find non-matching non padded gridrefs (i.e. ones that shouldn't be wrong)
        gr_inds = which(gr_comps$PRECISION != precision & gr_comps$PRECISION != 1000 & (precision != 2000 | precision != 5000) )
        # Find all non-matched precision values
        if(length(gr_inds) > 0){
            stop("Precision supplied does not match determined precision for", length(gr_inds), " grid refs")
        }
        # If estimated precision = 1000 and supplied prec = 2000 or 5000 then assume tetrad/quadrant padded values (e.g. BRC type data)
        # Padded tetrads
        # Note if tetrad grid ref and tetrad code in (C,H,K,L,M,N,P,S,X) then quadrant cannot be uniquely determined
        # Find grid refs matching this criteria
        gr_inds = which(gr_comps$PRECISION != precision & gr_comps$PRECISION == 1000 & precision == 2000 & grepl("^[[:alpha:]]{1,2}[[:digit:]]{2}[CHKLMNPSX]$",out_obj$TETRAD_GR))
        # Set quadrant to NA
        if(length(gr_inds) > 0){
            out_obj[gr_inds,"QUADRANT_GR"] = NA
        }
        # Padded Quadrant
        # For all padded quadrant codes tetrad cannot be uniquely determined
        gr_inds = which(gr_comps$PRECISION != precision & gr_comps$PRECISION == 1000 & precision == 5000)
        # Set quadrant to NA
        if(length(gr_inds) > 0){
            out_obj[gr_inds,"TETRAD_GR"] = NA
        }

    }

    # Return output object based on prec_out value
    if(is.null(prec_out)){
        return(out_obj)
    } else if(prec_out == 2000){
        return(out_obj$TETRAD_GR)
    } else if(prec_out == 5000){
        return(out_obj$QUADRANT_GR)
    }
}


suppressPackageStartupMessages(library(optparse, warn.conflicts=F, quietly=T))

option_list <- list(
  make_option(c("-b", "--bigwig"),
              type="character",
              default=NA,
              help="Input BigWig file"),
  make_option(c("-r", "--reads"),
              type="integer",
              default=1,
              help="Read count normalization (in millions, default 1)"),
  make_option(c("-s", "--size"),
              type="integer",
              default=150,
              help="Fragment size normalization (default 150 bp)")
)

# OPTION PROCESSING

opt <- parse_args(OptionParser(option_list=option_list))

if(is.na(opt$bigwig)) {
  message("No BigWig file specified.")
  q(status=1)
}

suppressPackageStartupMessages(library(rtracklayer, warn.conflicts=F))

message("Loading: ", opt$bigwig)
cov <- import(opt$bigwig, as="RleList")
cov <- cov / sum(as.numeric(sapply(cov, function(x) sum(as.numeric(x))))) * opt$reads * 1e6 * opt$size

new_bigwig <- gsub("\\.bw$", "_rpm.bw", basename(opt$bigwig))

message("Writing: ", new_bigwig)
export(cov, new_bigwig)


#!/nfs2/pipe/RNA/soft/R-3.1.2/bin/Rscript
# Created by Linxingzhong at 2015-7-24
# get items in the intersection of venn plot

library('VennDiagram')

args = commandArgs(TRUE)
options(stringsAsFactors=F)
#-----------------------------------------------------
#               USAGE
# Rscript VennItemGroup.r <outdir> 1/2 <file1> <file2> <file3> ...
#       1 : for venn drawing
#       2 : for genes groups
#----------------------------------------------------

# read input file as a list
File2List = function(args) {
    tmpList = list()
        for (arg in args) {
            name = strsplit(basename(arg), '.', fixed=T)[[1]][1]
            geneList = read.table(arg, header=T, sep='\t', fill=TRUE, quote="", stringsAsFactors=F)[,1]
            tmpList[[name]] = geneList
        }
    return(tmpList)
    }

# redefined function of set analyis, add the sample names to the result
Intersection = function(...) {
    out = Reduce(intersect, list(...))
    return(out)

}

Union = function(...) {
    out = Reduce(union, list(...))
    return(out)
}

# get intersection and write them to file
InterItems = function(datalist) {
    if (class(datalist) != "list")
        stop("Please make sure the input data is in list! ")

    m = length(datalist)    # sample number
    Names = names(datalist) # sample names
    outlist = list()

    if (m == 1) {
        outlist = datalist
    }
    else if (m == 2) {
        cross = Intersection(datalist[[1]], datalist[[2]])
        outlist[[paste(Names, collapse="-")]] = cross
        a12 = setdiff(datalist[[1]], cross)
        outlist[[paste(Names, collapse="-")]] = a12
        a21 = setdiff(datalist[[2]], cross)
        outlist[[paste(rev(Names), collapse="-")]] = a21

    }
    else if (m == 3) {
        n12 = intersect(datalist[[1]], datalist[[2]])
        n13 = intersect(datalist[[1]], datalist[[3]])
        n23 = intersect(datalist[[2]], datalist[[3]])
        n123 = Intersection(n13, n12, n23)

        a1 = setdiff(datalist[[1]], union(n12,n13))
        a2 = setdiff(n12, n123)
        a3 = setdiff(datalist[[2]], union(n12, n23))
        a4 = setdiff(n13, n123)
        a5 = n123
        a6 = setdiff(n23, n123)
        a7 = setdiff(datalist[[3]], union(n13, n23))

        outlist[['a1']] = a1
        outlist[['a2']] = a2
        outlist[['a3']] = a3
        outlist[['a4']] = a4
        outlist[['a5']] = a5
        outlist[['a6']] = a6
        outlist[['a7']] = a7

    }
    else if (m == 4) {
        n12 = intersect(datalist[[1]], datalist[[2]])
        n13 = intersect(datalist[[1]], datalist[[3]])
        n14 = intersect(datalist[[1]], datalist[[4]])
        n23 = intersect(datalist[[2]], datalist[[3]])
        n24 = intersect(datalist[[2]], datalist[[4]])
        n34 = intersect(datalist[[3]], datalist[[4]])

        n123 = intersect(n12, datalist[[3]])
        n124 = intersect(n12, datalist[[4]])
        n134 = intersect(n13, datalist[[4]])
        n234 = intersect(n23, datalist[[4]])

        n1234 = intersect(n123, datalist[[4]])

        a6  = n1234
        a12 = setdiff(n123, a6)
        a11 = setdiff(n124, a6)
        a5  = setdiff(n134, a6)
        a7  = setdiff(n234, a6)
        a15 = setdiff(n12, Union(a6, a11, a12))
        a4  = setdiff(n13, Union(a6, a5, a12))
        a10 = setdiff(n14, Union(a6, a5, a11))
        a13 = setdiff(n23, Union(a6, a7, a12))
        a8  = setdiff(n24, Union(a6, a7, a11))
        a2  = setdiff(n34, Union(a6, a5, a7))
        a9  = setdiff(datalist[[1]], Union(a4, a5, a6, a10, a11, a12, a15))
        a14 = setdiff(datalist[[2]], Union(a6, a7, a8, a11, a12, a13, a15))
        a1  = setdiff(datalist[[3]], Union(a2, a4, a5, a6, a7, a12, a13))
        a3  = setdiff(datalist[[4]], Union(a2, a5, a6, a7, a8, a10, a11))

        outlist[['a1']] = a1
        outlist[['a2']] = a2
        outlist[['a3']] = a3
        outlist[['a4']] = a4
        outlist[['a5']] = a5
        outlist[['a6']] = a6
        outlist[['a7']] = a7
        outlist[['a8']] = a8
        outlist[['a9']] = a9
        outlist[['a10']] = a10
        outlist[['a11']] = a11
        outlist[['a12']] = a12
        outlist[['a13']] = a13
        outlist[['a14']] = a14
        outlist[['a15']] = a15

        }
    else if (m == 5) {
        n12 = intersect(datalist[[1]], datalist[[2]])
        n13 = intersect(datalist[[1]], datalist[[3]])
        n14 = intersect(datalist[[1]], datalist[[4]])
        n15 = intersect(datalist[[1]], datalist[[5]])
        n23 = intersect(datalist[[2]], datalist[[3]])
        n24 = intersect(datalist[[2]], datalist[[4]])
        n25 = intersect(datalist[[2]], datalist[[5]])
        n34 = intersect(datalist[[3]], datalist[[4]])
        n35 = intersect(datalist[[3]], datalist[[5]])
        n45 = intersect(datalist[[4]], datalist[[5]])

        n123 = intersect(n12, datalist[[3]])
        n124 = intersect(n12, datalist[[4]])
        n125 = intersect(n12, datalist[[5]])
        n134 = intersect(n13, datalist[[4]])
        n135 = intersect(n13, datalist[[5]])
        n145 = intersect(n14, datalist[[5]])
        n234 = intersect(n23, datalist[[4]])
        n235 = intersect(n23, datalist[[5]])
        n245 = intersect(n24, datalist[[5]])
        n345 = intersect(n34, datalist[[5]])

        n1234 = intersect(n123, datalist[[4]])
        n1235 = intersect(n123, datalist[[5]])
        n1245 = intersect(n124, datalist[[5]])
        n1345 = intersect(n134, datalist[[5]])
        n2345 = intersect(n234, datalist[[5]])

        n12345 = intersect(n1234, datalist[[5]])

        a31 = n12345
        a30 = setdiff(n1234, a31)
        a29 = setdiff(n1235, a31)
        a28 = setdiff(n1245, a31)
        a27 = setdiff(n1345, a31)
        a26 = setdiff(n2345, a31)
        a25 = setdiff(n245, Union(a26, a28, a31))
        a24 = setdiff(n234, Union(a26, a30, a31))
        a23 = setdiff(n134, Union(a27, a30, a31))
        a22 = setdiff(n123, Union(a29, a30, a31))
        a21 = setdiff(n235, Union(a26, a29, a31))
        a20 = setdiff(n125, Union(a28, a29, a31))
        a19 = setdiff(n124, Union(a28, a30, a31))
        a18 = setdiff(n145, Union(a27, a28, a31))
        a17 = setdiff(n135, Union(a27, a29, a31))
        a16 = setdiff(n345, Union(a26, a27, a31))
        a15 = setdiff(n45, Union(a18, a25, a16, a28, a27, a26, a31))
        a14 = setdiff(n24, Union(a19, a24, a25, a30, a28, a26, a31))
        a13 = setdiff(n34, Union(a16, a23, a24, a26, a27, a30, a31))
        a12 = setdiff(n13, Union(a17, a22, a23, a27, a29, a30, a31))
        a11 = setdiff(n23, Union(a21, a22, a24, a26, a29, a30, a31))
        a10 = setdiff(n25, Union(a20, a21, a25, a26, a28, a29, a31))
        a9  = setdiff(n12, Union(a19, a20, a22, a28, a29, a30, a31))
        a8  = setdiff(n14, Union(a18, a19, a23, a27, a28, a30, a31))
        a7  = setdiff(n15, Union(a17, a18, a20, a27, a28, a29, a31))
        a6  = setdiff(n35, Union(a16, a17, a21, a26, a27, a29, a31))
        a5 = setdiff(datalist[[5]], Union(a6, a7, a15, a16, a17, a18, a25, a26, a27, a28, a31, a20, a29, a21, a10))
        a4 = setdiff(datalist[[4]], Union(a13, a14, a15, a16, a23, a24, a25, a26, a27, a28, a31, a18, a19, a8, a30))
        a3 = setdiff(datalist[[3]], Union(a21, a11, a12, a13, a29, a22, a23, a24, a30, a31, a26, a27, a16, a6, a17))
        a2 = setdiff(datalist[[2]], Union(a9, a10, a19, a20, a21, a11, a28, a29, a31, a22, a30, a26, a25, a24, a14))
        a1 = setdiff(datalist[[1]], Union(a7, a8, a18, a17, a19, a9, a27, a28, a31, a20, a30, a29, a22, a23, a12))

        outlist[['a1']] = a1
        outlist[['a2']] = a2
        outlist[['a3']] = a3
        outlist[['a4']] = a4
        outlist[['a5']] = a5
        outlist[['a6']] = a6
        outlist[['a7']] = a7
        outlist[['a8']] = a8
        outlist[['a9']] = a9
        outlist[['a10']] = a10
        outlist[['a11']] = a11
        outlist[['a12']] = a12
        outlist[['a13']] = a13
        outlist[['a14']] = a14
        outlist[['a15']] = a15
        outlist[['a16']] = a16
        outlist[['a17']] = a17
        outlist[['a18']] = a18
        outlist[['a19']] = a19
        outlist[['a20']] = a20
        outlist[['a21']] = a21
        outlist[['a22']] = a22
        outlist[['a23']] = a23
        outlist[['a24']] = a24
        outlist[['a25']] = a25
        outlist[['a26']] = a26
        outlist[['a27']] = a27
        outlist[['a28']] = a28
        outlist[['a29']] = a29
        outlist[['a30']] = a30
        outlist[['a31']] = a31

    }

    return(outlist)

}

# find out specific and common genes among many DGE output files
Uniq_Comm = function(datalist) {
    outlist = list()
    com_genes = Reduce(intersect, datalist)
    outlist[['Common_genes']] = com_genes
    for (i in 1:length(datalist)) {
        tmpunion = Reduce(union, datalist[-i])
        tmpinter = intersect(tmpunion, datalist[[i]])
        spegenes = setdiff(datalist[[i]], tmpinter)
        tmpname = paste(names(datalist)[i],'_Specific', sep='')
        outlist[[tmpname]] = spegenes
        }
    return(outlist)
}

# write inter items to file
WriteInter = function(outlist, outdir) {
    for (i in 1:length(outlist)) {
        outfile = paste(outdir, '/', names(outlist[i]), '_', length(outlist[[i]]), '.txt', sep = '')
        tmpdataframe = as.data.frame(outlist[[i]])
        names(tmpdataframe) = 'Gene'
        write.table(tmpdataframe, file= outfile, row.names=FALSE, sep='\t', quote=F)
#        print(outfile)
    }
}

# draw plot
DrawVenn = function(datalist, outdir) {
    venn.plot=venn.diagram(datalist,filename=NULL,col = "#222222",lty = 1,
    lwd = 1,fill = rainbow(length(datalist)),alpha = 0.40,cex = 1,
    fontfamily = "serif",fontface = "bold",cat.col = "black",
    cat.cex =1.3,cat.fontfamily = "serif",cat.default.pos = "outer",
    margin=0.12,cat.dist=rep(0.06,length(datalist)), col='transparent')

    picname = paste(outdir, '/', paste(names(datalist), collapse='--'),
    '_venn.png', sep='')

    png(picname, 540, 540)
    grid.draw(venn.plot)
    dev.off()
}

# check outdir otherwise create
dir.create(args[1], showWarnings = FALSE)

filenames = args[-c(1,2)]
tmpList = File2List(filenames)

if (args[2] == '1') {
    DrawVenn(tmpList, args[1])
    outlist = InterItems(tmpList)
    WriteInter(outlist, args[1])
} else if (args[2] == '2') {
    outlist = Uniq_Comm(tmpList)
    WriteInter(outlist, args[1])
}


library(dHRUM)
nHrus <- 1
Areas <- 4700000
IdsHrus <- paste0("ID",seq(1:length(Areas)))
dhruBP <- initdHruModel(nHrus,Areas,IdsHrus)

filname2 = "../dHRUM/Calibrations/Amalie/indata/BP_1960_01_01.txt"

setPTInputsToAlldHrusFromFile(dhruBP, filname2)
# Hamon PET
calcPetToAllHrus(dhruBP,50.1,"Oudin")
# Oudin PET
# calPetToAllHrus(dHRU_ptr = dhruBP,50.1,"Oudin")

attach(what = "../dHRUM/Calibrations/Amalie/Amalie_lumped_dHRUM.rda")
Par_dHRUm_Amalie_lumped$pars[1,]
ParBP = Par_dHRUm_Amalie_lumped$pars[1,1:15]
# ParBP=BP_df[1,1:15]
setParamsToAlldHrus(dhruBP,as.numeric(ParBP[1,]),names(ParBP))
calcHBInAlldHrus(dhruBP)
gatherHBdata(dhruBP)

dta <- getOutput(dhruBP)
dF <-data.frame(dta$outDta)
names(dF) <- dta$VarsNams

# celkovy odtok
plot(dF$TOTR, type='l')
# zakladni odtok
plot(dF$BASF, type='l')
# primy odtok
plot(dF$DIRR, type='l')
# zasoba vody v pude
plot(dF$SOIS, type='l')
# zasoba vody v podzemni vode
plot(dF$GROS, type='l')
# vypar povrchova retence
plot(dF$AET, type='l')

VecDATE = c()
for(i in 1:nrow(dF)){
  VecDATE[i] = paste0(as.character(dF[i,1]),"-",as.character(dF[i,2]),"-",as.character(dF[i,3]))
}
VecDATE=as.Date(VecDATE)

Prec=dF$PREC
Temp=dF$TEMP

nHrus <- 1
Areas <- 4700000
IdsHrus <- paste0("ID",seq(1:length(Areas)))
dhruBP1 <- initdHruModel(nHrus,Areas,IdsHrus)
setPTDateInputsToAlldHrus(dhruBP1,Prec = Prec,Temp = Temp,DateVec = VecDATE)
calcPetToAllHrus(dhruBP1,Latitude = 50.1,PetTypeStr = "Hamon")
setParamsToAlldHrus(dhruBP1,as.numeric(ParBP[1,]),names(ParBP))
calcHBInAlldHrus(dhruBP1)
gatherHBdata(dhruBP1)
dta1 <- getOutput(dhruBP1)
dF1 <-data.frame(dta1$outDta)
names(dF1) <- dta1$VarsNams

plot(dF$PREF,dF1$PREF)
sum(dF$PREF-dF1$PREF)

library(data.table)
DFDT=as.data.table(dF)

DFDT[,DTM:=as.Date(paste(YEAR,MONTH,DAY,sep="-")),]
dfShort=DFDT[DTM>"1961-01-01" & DTM<"2011-01-01",]
dtM=dfShort[,.(PRM=sum(PREC),AETM=sum(AET)),by=.(MONTH,YEAR)]

dtM[,.(median(PRM)),by=.(MONTH)]

dta=readRDS("../dHRUM/Calibrations/Amalie/indata/StepProSimulace.rds")
dtaBP=dta[DTM>"1979-12-31" &  DTM<"2011-01-01" & ID=='BP',]

nHrus <- 1
Areas <- 4700000
IdsHrus <- paste0("ID",seq(1:length(Areas)))
dhruBP1 <- initdHruModel(nHrus,Areas,IdsHrus)
setPTDateInputsToAlldHrus(dhruBP1,Prec = dtaBP$P,Temp = dtaBP$T,DateVec = dtaBP$DTM)
calcPetToAllHrus(dhruBP1,Latitude = 50.1,PetTypeStr = "Oudin")

ParBest = ParBP
# ParBest[1,] = as.numeric(ParBP[1,1:15])
# ParBest
#
# BP_df

setParamsToAlldHrus(dhruBP1,as.numeric(ParBest[1,]),names(ParBest))
calcHBInAlldHrus(dhruBP1)
gatherHBdata(dhruBP1)
dta1 <- getOutput(dhruBP1)
dF <-data.frame(dta1$outDta)
names(dF) <- dta1$VarsNams
DFDT=as.data.table(dF)

DFDT[,DTM:=as.Date(paste(YEAR,MONTH,DAY,sep="-")),]
DFDT[,DTM:=as.Date(paste(YEAR,MONTH,DAY,sep="-")),]
dfShort=DFDT[DTM>"1980-01-01" & DTM<"2011-01-01",]
# na.omit(dfShort)
dfShort=DFDT[DTM>"1980-01-01" & DTM<"2011-01-01",Aet:=AET+EVBS+EVAS+EVAC]#]
dfShort=na.omit(dfShort)
dtM=dfShort[,.(PRM=sum(PREC),AETM=sum(Aet),PETM=sum(PET),SO=mean(SOIS),D=sum(DIRR),BF=sum(BASF),R=sum(TOTR)),by=.(MONTH,YEAR)]
# dtM=na.omit(dtM)
MdatBP=dtM[,.(P=median(PRM),PET=median(PETM),AET=median(AETM),SOIL=median(SO),DR=median(D),BF=median(BF),R=median(R)),by=.(MONTH)]
MdatBP
# saveRDS(file = "../../bp_m.rds",MdatBP)


################################################
## STEP 5. Doublet score filter
#################################################
# This is a simplest filter that looks at a threshold value for the doublet scores.
# To separate cells with low droplet score from the ones that have a high droplet score content what makes us think that the are mistakenly considered as a single cell but they are actully two or more.
# This can be a useful first guess. The settings for such a filter can also contain a simple "probabilityThreshold" setting.

# The most uses values in doublet scores reporting in the scrublet paper [1] are around 0.25. There are not too much literature about how to compute
# a threshold. For now, we will offer two methods:
# --> Absolute threshold: In order to be not too extrictive the threshold is set to 0.25
generate_default_values_doubletScores <- function(scdata, config) {

    # HARDCODE
    threshold <- 0.25

    return(threshold)
}

#' @description Filters seurat object based on doubletScores scores
#' @param config list containing the following information
#'          - enable: true/false. Refering to apply or not the filter.
#'          - auto: true/false. 'True' indicates that the filter setting need to be changed depending on some sensible value (it requires
#'          to call generate_default_values_doubletScores)
#'          - filterSettings: slot with thresholds
#'                  - probabilityThreshold: Float. cut-off for the maximun probability scores that could have a cell. The doubletScores scores have been computed
#'                  through "scrublet" [1]
#'                  - binStep: Float. Bin size for the histogram
#' @export return a list with the filtered seurat object by doublet score, the config and the plot values

doubletScores <- function(scdata, config){

    # Check if the experiment has doubletScores
    if (!"doublet_scores"%in%colnames(scdata@meta.data)){
        message("Warning! No doubletScores scores has been computed for this experiment!")
        return(scdata)
    }

    probabilityThreshold <- config$filterSettings$probabilityThreshold

    # Check if it is required to compute sensible values. From the function 'generate_default_values_doubletScores', it is expected
    # to get a value --> probabilityThreshold.
    if (as.logical(toupper(config$auto)))
        probabilityThreshold <- generate_default_values_doubletScores(scdata, config)

    # Check wheter the filter is set to true or false
    if (as.logical(toupper(config$enabled)))
        # Information regarding doublet score is pre-computed during the 'data-ingest'.
        scdata.filtered <- subset(scdata, subset = doublet_scores <= probabilityThreshold)
    else
        scdata.filtered <- scdata

    # update config
    config$filterSettings$probabilityThreshold <- probabilityThreshold

    # the result object will have to conform to this format: {data, config, plotData : {plot1, plot2}}
    result <- list(
        data = scdata.filtered,
        config = config,
        plotData = list(
            # plot 1: histgram of doublet scores
            # AAACCCAAGCGCCCAT-1 AAACCCAAGGTTCCGC-1 AAACCCACAGAGTTGG-1
            #              0.161              0.198              0.284  ...
            doubletFilterHistogram = scdata$doublet_scores
        )
    )

    return(result)

}

# [1] Wolock SL, Lopez R, Klein AM. Scrublet: Computational Identification of Cell Doublets in Single-Cell Transcriptomic Data.
# Cell Syst. 2019 Apr 24;8(4):281-291.e9. doi: 10.1016/j.cels.2018.11.005. Epub 2019 Apr 3. PMID: 30954476; PMCID: PMC6625319.