From c70cdc4ef62832cff29570b85d0feb310de9c7fd Mon Sep 17 00:00:00 2001 From: Hollos Roland Date: Tue, 22 Jun 2021 12:52:57 +0200 Subject: [PATCH] no burnin bug, faile cathegories --- RBBGCMuso/R/calibrateMuso.R | 14 ++++++------- RBBGCMuso/R/multiSite.R | 40 +++++++++++++++++++++++++------------ 2 files changed, 34 insertions(+), 20 deletions(-) diff --git a/RBBGCMuso/R/calibrateMuso.R b/RBBGCMuso/R/calibrateMuso.R index 2782593..936c0ea 100644 --- a/RBBGCMuso/R/calibrateMuso.R +++ b/RBBGCMuso/R/calibrateMuso.R @@ -56,13 +56,13 @@ calibrateMuso <- function(measuredData, parameters =read.csv("parameters.csv", s }) # musoSingleThread(measuredData, parameters, startDate, - # endDate, formatString, - # dataVar, outLoc, - # preTag, settings, - # outVars, iterations = threadCount[i], - # skipSpinup, plotName, - # modifyOriginal, likelihood, uncertainity, - # naVal, postProcString, i) + # endDate, formatString, + # dataVar, outLoc, + # preTag, settings, + # outVars, iterations = threadCount[i], + # skipSpinup, plotName, + # modifyOriginal, likelihood, uncertainity, + # naVal, postProcString, i) }) }) diff --git a/RBBGCMuso/R/multiSite.R b/RBBGCMuso/R/multiSite.R index 67bf092..5643046 100644 --- a/RBBGCMuso/R/multiSite.R +++ b/RBBGCMuso/R/multiSite.R @@ -17,6 +17,17 @@ SELECT <- function(x, selectPart){ } } +bVectToInt<- function(bin_vector){ + bin_vector <- rev(as.integer(bin_vector)) + packBits(as.raw(c(bin_vector,numeric(32-length(bin_vector)))),"integer") +} + +constMatToDec <- function(constRes){ + tab <- table(apply(constRes,2,function(x){paste(x,collapse=" ")})) + bitvect <- strsplit(names(tab[which.max(tab)]),split=" ")[[1]] + bVectToInt(bitvect) +} + compose <- function(expr){ splt <- strsplit(expr,split="\\|")[[1]] lhs <- splt[1] @@ -131,14 +142,16 @@ multiSiteCalib <- function(measurements, threadCount <- distributeCores(iterations, numCores) fut <- lapply(1:numCores, function(i) { - # browser() future({ tryCatch( - multiSiteThread(measuredData = measurements, parameters = parameters, calTable=calTable, - dataVar = dataVar, iterations = threadCount[i], - likelihood = likelihood, threadNumber= i, burnin=burnin,constraints=constraints, th=th) - # setwd("../") + { + multiSiteThread(measuredData = measurements, parameters = parameters, calTable=calTable, + dataVar = dataVar, iterations = threadCount[i], + likelihood = likelihood, threadNumber= i, constraints=constraints, th=th) + # setwd("../") + } + , error = function(e){ saveRDS(e,"error.RDS") writeLines(as.character(iterations),"progress.txt") @@ -321,15 +334,15 @@ multiSiteThread <- function(measuredData, parameters = NULL, startDate = NULL, }} print("optiMuso is randomizing the epc parameters now...",quote = FALSE) - randVals <- musoRand(parameters = parameters,constrains = NULL, iterations = iterations, burnin = burnin) + randVals <- musoRand(parameters = parameters,constrains = NULL, iterations = iterations) origEpc <- readValuesFromFile(epcFile, randVals[[1]]) - partialResult <- matrix(ncol=length(randVals[[1]])+2*length(dataVar) + 1) + partialResult <- matrix(ncol=length(randVals[[1]])+2*length(dataVar) + 2) colN <- randVals[[1]] colN[match(parameters[,2],randVals[[1]])] <- parameters[,1] colN[match(parameters[,2], randVals[[1]])[!is.na(match(parameters[,2],randVals[[1]]))]] <- parameters[,1] colnames(partialResult) <- c(colN,sprintf("%s_likelihood",names(dataVar)), - sprintf("%s_rmse",names(dataVar)),"Const") + sprintf("%s_rmse",names(dataVar)),"Const", "failType") numParameters <- length(colN) partialResult[1:numParameters] <- origEpc ## Prepare the preservedCalib matrix for the faster @@ -380,7 +393,6 @@ multiSiteThread <- function(measuredData, parameters = NULL, startDate = NULL, print("Running the model with the random epc values...", quote = FALSE) for(i in 2:(iterations+1)){ - # browser() tmp <- lapply(resIterate, function(siteI){ dirName <- tools::file_path_sans_ext(basename(calTable[siteI,1])) setwd(dirName) @@ -446,6 +458,8 @@ calcLikelihoodsForGroups <- function(dataVar, mod, mes, constRes<- sapply(mod,function(m){ compoVect(m,constraints) }) + + failType <- constMatToDec(constRes) } likelihoodRMSE <- sapply(names(dataVar),function(key){ @@ -475,10 +489,10 @@ calcLikelihoodsForGroups <- function(dataVar, mod, mes, res }) - likelihoodRMSE <- c(likelihoodRMSE[1,],likelihoodRMSE[2,], - ifelse((100 * sum(apply(constRes,2,prod)) / ncol(constRes)) >= th, - 1,0)) - names(likelihoodRMSE) <- c(sprintf("%s_likelihood",dataVar), sprintf("%s_rmse",dataVar), "Const") + likelihoodRMSE <- c(likelihoodRMSE[1,], likelihoodRMSE[2,], + ifelse((100 * sum(apply(constRes, 2, prod)) / ncol(constRes)) >= th, + 1,0), failType) + names(likelihoodRMSE) <- c(sprintf("%s_likelihood",dataVar), sprintf("%s_rmse",dataVar), "Const", "failType") return(likelihoodRMSE) }