hollorol/RBBGCMuso
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

solving the old dependency group problem

Browse Source
This commit is contained in:
Roland Hollós 2023-06-14 17:53:28 +02:00
parent f96a56c918
commit 0d3666a8f5
2 changed files with 138 additions and 92 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
RBBGCMuso/R/assistantFunctions.R
View File

@ -150,6 +150,7 @@ readValuesFromFile <- function(filename, linums){
return(values) return(values)
} }
#' readMeasuredMuso #' readMeasuredMuso
#' #'
#' MuSo data reader #' MuSo data reader

229
RBBGCMuso/R/musoRand.R
View File

@ -8,147 +8,182 @@
#' @importFrom limSolve xsample #' @importFrom limSolve xsample
#' @export #' @export
musoRand <- function(parameters, iterations=3000, fileType="epc", constrains = NULL, burnin = NULL){ musoRand <- function(parameters, iterations=3000, fileType="epc", sourceFile=NULL, constrains = NULL, burnin = NULL){
if(is.null(constrains)){ if(is.null(constrains)){
constMatrix <- constrains constMatrix <- constrains
constMatrix <- getOption("RMuso_constMatrix")[[fileType]][[as.character(getOption("RMuso_version"))]] constMatrix <- getOption("RMuso_constMatrix")[[fileType]][[as.character(getOption("RMuso_version"))]]
} else { } else {
constMatrix <- constrains constMatrix <- constrains
} }
parameters <- parameters[,-1] parameters <- parameters[,-1]
constMatrix <- constMatrix[,-1] constMatrix <- constMatrix[,-1]
depTableMaker <- function(constMatrix,parameters){ depTableMaker <- function(constMatrix,parameters){
# browser()
parameters <- parameters[order(parameters[,1]),] ## BUG!!! parameters <- parameters[order(parameters[,1]),] ## BUG!!!
selectedRows <- constMatrix[,"INDEX"] %in% parameters[,1] selectedRows <- constMatrix[,"INDEX"] %in% parameters[,1]
# constMatrix[constMatrix[,"INDEX"] %in% parameters[,1],]
rankList <- rank(constMatrix[selectedRows,2]) rankList <- rank(constMatrix[selectedRows,2])
constMatrix[selectedRows,c(5,6)] <- parameters[rankList,c(2,3)] constMatrix[selectedRows,c(5,6)] <- parameters[rankList,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
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])})),]
paragroups <- unique(constMatrix[constMatrix[,"GROUP"] != 0,"GROUP"])
missingMembers <- list()
for(group in paragroups){
groupMembers <- constMatrix[constMatrix[,"GROUP"] == group,"INDEX"]
missingMemberElems <- groupMembers[is.na(match(groupMembers,parameters[,1]))]
if(length(missingMemberElems) > 0){
missingMembers$indices <- c(missingMembers$indices,
match(missingMemberElems,constMatrix[,"INDEX"]))
if(is.null(sourceFile)){
stop(sprintf("All group members of the group (%s) have to be in parameters if sourceFile not(epc file)",group))
}
missingMembers$values <- c(missingMembers$values,
suppressWarnings(readValuesFromFile(sourceFile,missingMemberElems)))
}
}
list(depTable=constMatrix,missingMembers=missingMembers)
} }
# browser() # browser()
genMat0 <- function(dep){ genMat0 <- function(dep, missingIndices){
numberOfVariable <- nrow(dep) numberOfVariable <- nrow(dep)
G <- rbind(diag(numberOfVariable), -1*diag(numberOfVariable)) if(length(missingMembers) != 0){
h <- c(dependences[,5], -1*dependences[,6]) dep <- dep[-missingIndices,]
return(list(G=G,h=h)) }
G <- rbind(diag(numberOfVariable), -1*diag(numberOfVariable))
h <- c(dependences[,5], -1*dependences[,6])
return(list(G=G,h=h))
} }
genMat1 <- function(dep, N){ genMat1 <- function(dep, N){
## Range <- sapply(list(min,max),function(x){ ## Range <- sapply(list(min,max),function(x){
## x(as.numeric(rownames(dep))) ## x(as.numeric(rownames(dep)))
## }) It is more elegant, more general, but slower ## }) It is more elegant, more general, but slower
Range <- (function(x){ Range <- (function(x){
c(min(x), max(x)) c(min(x), max(x))
})(as.numeric(dep[,"rowIndex"])) })(as.numeric(dep[,"rowIndex"]))
numberOfVariables <- nrow(dep) numberOfVariables <- nrow(dep)
G<- -1*diag(numberOfVariables) G<- -1*diag(numberOfVariables)
for(i in 1:numberOfVariables){ for(i in 1:numberOfVariables){
if(dep[i,4]!=0){ if(dep[i,4]!=0){
G[i,dep[i,4]] <- 1 G[i,dep[i,4]] <- 1
} }
}
# browser()
G<-G[dep[,4]!=0,]
}
# browser()
G<-G[dep[,4]!=0,]
if(is.null(nrow(G))){ if(is.null(nrow(G))){
G<-t(as.matrix(G)) G<-t(as.matrix(G))
} }
numRowsInG <- nrow(G) numRowsInG <- nrow(G)
if(Range[1]==1){ if(Range[1]==1){
G<-cbind(G,matrix(ncol=(N-Range[2]),nrow=numRowsInG,data=0)) G<-cbind(G,matrix(ncol=(N-Range[2]),nrow=numRowsInG,data=0))
} else{ } else{
if(Range[2]==N){ if(Range[2]==N){
G<-cbind(matrix(ncol=(Range[1]-1),nrow=numRowsInG,data=0),G) G<-cbind(matrix(ncol=(Range[1]-1),nrow=numRowsInG,data=0),G)
} else { } else {
G <- cbind(matrix(ncol=(Range[1]-1),nrow=numRowsInG,data=0),G,matrix(ncol=(N-Range[2]),nrow=numRowsInG,data=0)) G <- cbind(matrix(ncol=(Range[1]-1),
} nrow=numRowsInG,data=0),
} G,
return(list(G=-1*G,h=-1*rep(0,nrow(G)))) matrix(ncol=(N-Range[2]),
nrow=numRowsInG,data=0))
}
}
return(list(G=-1*G,h=-1*rep(0,nrow(G))))
} }
genMat2 <- function(dep, N){ genMat2 <- function(dep, N){
G <- rep(1,nrow(dep)) G <- rep(1,nrow(dep))
Range <- (function(x){ Range <- (function(x){
c(min(x), max(x)) c(min(x), max(x))
})(as.numeric(dep[,"rowIndex"])) })(as.numeric(dep[,"rowIndex"]))
if(Range[1]==1){ if(Range[1]==1){
G<-c(G, numeric(N-Range[2])) G<-c(G, numeric(N-Range[2]))
} else{ } else{
if(Range[2]==N){ if(Range[2]==N){
G<-c(numeric(Range[1]-1), G) G<-c(numeric(Range[1]-1), G)
} else { } else {
G <- c(numeric(Range[1]-1), G, numeric(N-Range[2])) G <- c(numeric(Range[1]-1), G, numeric(N-Range[2]))
} }
} }
G <- t(matrix(sign(dep[2,4])*G)) G <- t(matrix(sign(dep[2,4])*G))
h <- abs(dep[1,4]) h <- abs(dep[1,4])
if(dep[1,"TYPE"]==2){ # This is not needed, I'll have to remove the if part, and keep the content if(dep[1,"TYPE"]==2){ # This is not needed, I'll have to remove the if part, and keep the content
G <- G*(-1) G <- G*(-1)
h <- h*(-1) h <- h*(-1)
} }
return(list(G=G,h=h)) return(list(G=G,h=h))
} }
genMat3 <- function(dep, N){ genMat3 <- function(dep, N){
Range <- (function(x){ Range <- (function(x){
c(min(x), max(x)) c(min(x), max(x))
})(as.numeric(dep[,"rowIndex"])) })(as.numeric(dep[,"rowIndex"]))
E <- rep(1,nrow(dep)) E <- rep(1,nrow(dep))
if(Range[1]==1){ if(Range[1]==1){
E<-c(E, numeric(N-Range[2])) E<-c(E, numeric(N-Range[2]))
} else{ } else{
if(Range[2]==N){ if(Range[2]==N){
E<-c(numeric(Range[1]-1), E) E<-c(numeric(Range[1]-1), E)
} else { } else {
E <- c(numeric(Range[1]-1), E, numeric(N-Range[2])) E <- c(numeric(Range[1]-1), E, numeric(N-Range[2]))
} }
} }
E <- t(matrix(E)) E <- t(matrix(E))
f <- dep[1,4] f <- dep[1,4]
return(list(E=E,f=f)) return(list(E=E,f=f))
} }
applyRandTypeG <- function(dep,N){ applyRandTypeG <- function(dep,N){
type <- unique(dep[,"TYPE"]) type <- unique(dep[,"TYPE"])
minR <- min(dep[,"rowIndex"]) minR <- min(dep[,"rowIndex"])
maxR <- max(dep[,"rowIndex"]) maxR <- max(dep[,"rowIndex"])
switch(type, switch(type,
invisible(Gh <- genMat1(dep, N)), invisible(Gh <- genMat1(dep, N)),
invisible(Gh <- genMat2(dep, N))) invisible(Gh <- genMat2(dep, N)))
return(Gh) return(Gh)
} }
applyRandTypeE <- function(dep,N){ applyRandTypeE <- function(dep,N){
type <- unique(dep[,"TYPE"]) type <- unique(dep[,"TYPE"])
minR <- min(dep[,"rowIndex"]) minR <- min(dep[,"rowIndex"])
maxR <- max(dep[,"rowIndex"]) maxR <- max(dep[,"rowIndex"])
switch(-type, switch(-type,
stop("Not implemented yet"), stop("Not implemented yet"),
stop("Not implemented yet"), stop("Not implemented yet"),
invisible(Ef <- genMat3(dep, N))) invisible(Ef <- genMat3(dep, N)))
return(Ef) return(Ef)
} }
dependences <- depTableMaker(constMatrix, parameters) dependences <- depTableMaker(constMatrix, parameters)
missingMembers <- dependences$missingMembers
dependences <- dependences$depTable
dependences <- cbind(dependences,1:nrow(dependences)) dependences <- cbind(dependences,1:nrow(dependences))
colnames(dependences)[ncol(dependences)] <- "rowIndex" colnames(dependences)[ncol(dependences)] <- "rowIndex"
# browser() # browser()
@ -167,21 +202,31 @@ musoRand <- function(parameters, iterations=3000, fileType="epc", constrains = N
Ef[[i]] <- applyRandTypeE(splitedDeps[[i]],nrow(dependences)) Ef[[i]] <- applyRandTypeE(splitedDeps[[i]],nrow(dependences))
} }
} }
Gh0<- genMat0(dependences) Gh0<- genMat0(dependences, missingMembers$indices)
G <- do.call(rbind,lapply(Gh,function(x){x$G})) G <- do.call(rbind,lapply(Gh,function(x){x$G}))
G<- rbind(Gh0$G,G) G<- rbind(Gh0$G,G)
h <- do.call(c,lapply(Gh,function(x){x$h})) h <- do.call(c,lapply(Gh,function(x){x$h}))
h <- c(Gh0$h,h) h <- c(Gh0$h,h)
E <- do.call(rbind,lapply(Ef,function(x){x$E})) E <- do.call(rbind,lapply(Ef,function(x){x$E}))
f <- do.call(c,lapply(Ef,function(x){x$f})) f <- do.call(c,lapply(Ef,function(x){x$f}))
# browser() # browser()
if(length(missingMembers$indices)!=0){
Ep <- matrix(data=0,ncol=numberOfVariable,nrow=length(missingMembers$indices))
Ep[1:length(missingMembers$indices),missingMembers$indices] <- 1
E <- rbind(E,Ep)
f <- c(f,missingMembers$values)
}
randVal <- suppressWarnings(limSolve::xsample(G=G,H=h,E=E,F=f,burninlength=burnin, iter = iterations))$X randVal <- suppressWarnings(limSolve::xsample(G=G,H=h,E=E,F=f,burninlength=burnin, iter = iterations))$X
} else{ } else{
Gh0<-genMat0(dependences) Gh0<-genMat0(dependences,NULL)
randVal <- suppressWarnings(xsample(G=Gh0$G,H=Gh0$h, iter = iterations))$X randVal <- suppressWarnings(xsample(G=Gh0$G,H=Gh0$h, iter = iterations))$X
} }
if(length(missingMembers$indices)!=0){
return(list(INDEX = dependences$INDEX[-missingMembers$indices],
randVal=randVal[,-missingMembers$indices]))
}
results <- list(INDEX =dependences$INDEX, randVal=randVal) results <- list(INDEX =dependences$INDEX, randVal=randVal)
return(results) return(results)
} }