RBBGCMuso/RBBGCMuso/R/#musoRand.R#

#' musoRand
#'
#' This funtion samples uniformly from the choosen parameters of the BiomeBGC-Muso model, which parameters are constrained by the model logic.
#' @author Roland Hollos
#' @param parameters This is a dataframe (heterogen data-matrix), which first column is the name of the parameters, the second is a numeric vector of the rownumbers of the given variable in the input-file, the last two column consist the endpont of the parameter-ranges, where the parameters will be randomized.
#' @param constrains This is a matrics wich specify the constrain rules for the sampling. Further informations coming son.
#' @param iteration The number of sample-s. It is adviced to use at least 3000 iteration, because it is generally fast and it can be subsampled later at any time. 
#' @export

musoRand <- function(parameters, constrains = NULL, iterations=3000){

    if(!is.null(constrains)){
        constMatrix <- constrains
    }
    
    parameters <- parameters[,-1]
    constMatrix <- constMatrix[,-1]
    
    depTableMaker <- function(constMatrix,parameters){
	parameters <- parameters[order(parameters[,1]),]
	constMatrix[constMatrix[,"INDEX"] %in% parameters[,1],c(5,6)]<-parameters[,c(2,3)]
	logiConstrain <- (constMatrix[,"GROUP"] %in% constMatrix[constMatrix[,"INDEX"] %in% parameters[,1],"GROUP"] &
			  (constMatrix[,"GROUP"]!=0)) | ((constMatrix[,"INDEX"] %in% parameters[,1]) & (constMatrix[,"GROUP"] == 0))
	constMatrix<-constMatrix[logiConstrain,]
	constMatrix <- constMatrix[order(apply(constMatrix[,7:8],1,function(x){x[1]/10+abs(x[2])})),]
	constMatrix
    }

    genMat0 <- function(dep){
	numberOfVariable <- nrow(dep)
	G <- rbind(diag(numberOfVariable), -1*diag(numberOfVariable))
	h <- c(dependences[,5], -1*dependences[,6])
	return(list(G=G,h=h))
    }

    genMat1 <- function(dep, N){

	## Range <- sapply(list(min,max),function(x){
  
	##   x(as.numeric(rownames(dep)))
	## }) It is more elegant, more general, but slower
	Range <- (function(x){
	    c(min(x), max(x))
	})(as.numeric(dep[,"rowIndex"]))

	numberOfVariables <- nrow(dep)
	G<- -1*diag(numberOfVariables)

	for(i in 1:numberOfVariables){
	    if(dep[i,4]!=0){
		G[i,dep[i,4]] <- 1
	    }

	}

	G<-G[dep[,4]!=0,]

	if(Range[1]==1){
	    G<-cbind(G,matrix(ncol=(N-Range[2]),nrow=nrow(G),data=0))
	} else{
	    if(Range[2]==N){
		G<-cbind(matrix(ncol=(Range[1]-1),nrow=nrow(G),data=0),G)
	    } else {
		G <- cbind(matrix(ncol=(Range[1]-1),nrow=nrow(G),data=0),G,matrix(ncol=(N-Range[2]),nrow=nrow(G),data=0))
	    }
	}
	return(list(G=G,h=rep(0,nrow(G))))
    }

    genMat2 <- function(dep, N){
	G <- rep(1,nrow(dep))

	Range <- (function(x){
	    c(min(x), max(x))
	})(as.numeric(dep[,"rowIndex"]))

	if(Range[1]==1){
	    G<-c(G, numeric(N-Range[2]))
	} else{
	    if(Range[2]==N){
		G<-c(numeric(Range[1]-1), G)
	    } else {
		G <- c(numeric(Range[1]-1), G, numeric(N-Range[2]))
	    }
	}

	G <- t(matrix(sign(dep[2,4])*G))
	h <- abs(dep[1,4])

	return(list(G=G,h=h))
    }

    genMat3 <- function(dep, N){
	Range <- (function(x){
	    c(min(x), max(x))
	})(as.numeric(dep[,"rowIndex"]))

	E <- rep(1,nrow(dep))

	if(Range[1]==1){
	    E<-c(E, numeric(N-Range[2]))
	} else{
	    if(Range[2]==N){
		E<-c(numeric(Range[1]-1), E)
	    } else {
		E <- c(numeric(Range[1]-1), E, numeric(N-Range[2]))
	    }
	}


	E <- t(matrix(E))
	f <- dep[1,4]
	return(list(E=E,f=f))
    }


    applyRandTypeG <- function(dep,N){
	type <- unique(dep[,"TYPE"])
	minR <- min(dep[,"rowIndex"])
	maxR <- max(dep[,"rowIndex"])
	switch(type,
	       invisible(Gh <- genMat1(dep, N)),
	       invisible(Gh <- genMat2(dep, N)))
	return(Gh)
    }

    applyRandTypeE <- function(dep,N){
	type <- unique(dep[,"TYPE"])
	minR <- min(dep[,"rowIndex"])
	maxR <- max(dep[,"rowIndex"])
	switch(-type,
	       stop("Not implemented yet"),
	       stop("Not implemented yet"),
	       invisible(Ef <- genMat3(dep, N)))
	return(Ef)
    }

    dependences <- depTableMaker(constMatrix, parameters)
    dependences <- cbind(dependences,1:nrow(dependences))
    colnames(dependences)[ncol(dependences)] <- "rowIndex"
    numberOfVariable <- nrow(dependences)
    nonZeroDeps<-dependences[dependences[,"TYPE"]!=0,]
    if(nrow(nonZeroDeps)!=0){
        splitedDeps<- split(nonZeroDeps,nonZeroDeps[,"GROUP"])
        Gh <- list()
        Ef <- list()

        for(i in 1:length(splitedDeps)){
            print(splitedDeps[[i]][1,"TYPE"])
            if(splitedDeps[[i]][1,"TYPE"]>0){
                Gh[[i]]<-applyRandTypeG(splitedDeps[[i]],nrow(dependences))
            } else {
                Ef[[i]] <- applyRandTypeE(splitedDeps[[i]],nrow(dependences))
            }
        }
        
        Gh0<- genMat0(dependences)
        G <- do.call(rbind,lapply(Gh,function(x){x$G}))
        G<- rbind(Gh0$G,G)
        h <- do.call(c,lapply(Gh,function(x){x$h}))
        h <- c(Gh0$h,h)
        E <- do.call(rbind,lapply(Ef,function(x){x$E}))
        f <- do.call(c,lapply(Ef,function(x){x$f}))
        randVal <- suppressWarnings(limSolve::xsample(G=G,H=h,E=E,F=f,iter = iterations))$X
    } else{
        Gh0<-genMat0(dependences)
        randVal <- suppressWarnings(limSolve::xsample(G=Gh0$G,H=Gh0$h, iter = iterations))$X
    }
    
    results <- list(INDEX =dependences$INDEX, randVal=randVal)
    return(results)
}