Merge remote-tracking branch 'origin/parallellRun'
This commit is contained in:
Roland Hollós
commit
21a40fc100
@ -28,12 +28,9 @@ Imports:
|
||||
data.table,
|
||||
gridExtra,
|
||||
lubridate,
|
||||
ecmwfr,
|
||||
openxlsx,
|
||||
ncdf4,
|
||||
tcltk
|
||||
LinkingTo: Rcpp
|
||||
SystemRequirements: C++11
|
||||
Maintainer: Roland Hollo's <hollorol@gmail.com>
|
||||
RoxygenNote: 7.1.0
|
||||
Suggests: knitr,
|
||||
|
||||
@ -1,7 +1,8 @@
|
||||
# Generated by roxygen2: do not edit by hand
|
||||
|
||||
export(calibMuso)
|
||||
export(changeMusoC)
|
||||
export(calibrateMuso)
|
||||
export(changemulline)
|
||||
export(checkMeteoBGC)
|
||||
export(cleanupMuso)
|
||||
export(compareMuso)
|
||||
@ -11,10 +12,8 @@ export(createSoilFile)
|
||||
export(getAnnualOutputList)
|
||||
export(getConstMatrix)
|
||||
export(getDailyOutputList)
|
||||
export(getMeteoData1BGC)
|
||||
export(getyearlycum)
|
||||
export(getyearlymax)
|
||||
export(mtclim)
|
||||
export(musoDate)
|
||||
export(musoGlue)
|
||||
export(musoMapping)
|
||||
@ -22,7 +21,6 @@ export(musoMappingFind)
|
||||
export(musoMonte)
|
||||
export(musoQuickEffect)
|
||||
export(musoRand)
|
||||
export(musoRandomizer)
|
||||
export(musoSensi)
|
||||
export(normalMuso)
|
||||
export(optiMuso)
|
||||
@ -40,7 +38,6 @@ export(supportedMuso)
|
||||
export(updateMusoMapping)
|
||||
import(ggplot2)
|
||||
import(utils)
|
||||
importFrom(Rcpp,evalCpp)
|
||||
importFrom(data.table,':=')
|
||||
importFrom(data.table,data.table)
|
||||
importFrom(data.table,fread)
|
||||
@ -52,8 +49,7 @@ importFrom(dplyr,mutate)
|
||||
importFrom(dplyr,select)
|
||||
importFrom(dplyr,summarize)
|
||||
importFrom(dplyr,tbl_df)
|
||||
importFrom(ecmwfr,wf_request)
|
||||
importFrom(ecmwfr,wf_set_key)
|
||||
importFrom(future,future)
|
||||
importFrom(ggplot2,aes)
|
||||
importFrom(ggplot2,aes_string)
|
||||
importFrom(ggplot2,element_blank)
|
||||
@ -82,21 +78,12 @@ importFrom(limSolve,xsample)
|
||||
importFrom(lubridate,leap_year)
|
||||
importFrom(magrittr,'%<>%')
|
||||
importFrom(magrittr,'%>%')
|
||||
importFrom(ncdf4,nc_close)
|
||||
importFrom(ncdf4,nc_create)
|
||||
importFrom(ncdf4,nc_open)
|
||||
importFrom(ncdf4,ncdim_def)
|
||||
importFrom(ncdf4,ncvar_def)
|
||||
importFrom(ncdf4,ncvar_get)
|
||||
importFrom(ncdf4,ncvar_put)
|
||||
importFrom(openxlsx,read.xlsx)
|
||||
importFrom(rmarkdown,pandoc_version)
|
||||
importFrom(rmarkdown,render)
|
||||
importFrom(scales,percent)
|
||||
importFrom(stats,approx)
|
||||
importFrom(tcltk,tk_choose.dir)
|
||||
importFrom(tcltk,tk_choose.files)
|
||||
importFrom(tibble,rownames_to_column)
|
||||
importFrom(tidyr,gather)
|
||||
importFrom(tidyr,separate)
|
||||
useDynLib(RBBGCMuso)
|
||||
|
||||
@ -1,52 +0,0 @@
|
||||
# Generated by using Rcpp::compileAttributes() -> do not edit by hand
|
||||
# Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
|
||||
|
||||
#' mtclim
|
||||
#'
|
||||
#' This is the core mtclim function
|
||||
#' @importFrom Rcpp evalCpp
|
||||
#' @useDynLib RBBGCMuso
|
||||
#' @param iniFile is the name of the inifile
|
||||
#' @keywords internal
|
||||
#' @export
|
||||
mtclim <- function(iniFile) {
|
||||
invisible(.Call('_RBBGCMuso_mtclim', PACKAGE = 'RBBGCMuso', iniFile))
|
||||
}
|
||||
|
||||
getWritePositions <- function(a) {
|
||||
.Call('_RBBGCMuso_getWritePositions', PACKAGE = 'RBBGCMuso', a)
|
||||
}
|
||||
|
||||
#' changeMusoC
|
||||
#'
|
||||
#' This function is fastly randomize values based on min and max values
|
||||
#' @importFrom Rcpp evalCpp
|
||||
#' @useDynLib RBBGCMuso
|
||||
#' @param inFile is the big matrix
|
||||
#' @param outFile is the small matrix
|
||||
#' @export
|
||||
changeMusoC <- function(inFile, outFile, inMat) {
|
||||
invisible(.Call('_RBBGCMuso_changeMusoC', PACKAGE = 'RBBGCMuso', inFile, outFile, inMat))
|
||||
}
|
||||
|
||||
randTypeOne <- function(m) {
|
||||
.Call('_RBBGCMuso_randTypeOne', PACKAGE = 'RBBGCMuso', m)
|
||||
}
|
||||
|
||||
randTypeTwo <- function(m) {
|
||||
.Call('_RBBGCMuso_randTypeTwo', PACKAGE = 'RBBGCMuso', m)
|
||||
}
|
||||
|
||||
#' musoRandomizer
|
||||
#'
|
||||
#' This function is fastly randomize values based on min and max values,
|
||||
#' and row indexes.
|
||||
#' @importFrom Rcpp evalCpp
|
||||
#' @useDynLib RBBGCMuso
|
||||
#' @param A is the big matrix
|
||||
#' @param B is the small matrix
|
||||
#' @export
|
||||
musoRandomizer <- function(A, B) {
|
||||
.Call('_RBBGCMuso_musoRandomizer', PACKAGE = 'RBBGCMuso', A, B)
|
||||
}
|
||||
|
||||
386
RBBGCMuso/R/calibrateMuso.R
Normal file
386
RBBGCMuso/R/calibrateMuso.R
Normal file
@ -0,0 +1,386 @@
|
||||
#' calibrateMuso
|
||||
#'
|
||||
#' This funtion uses the Monte Carlo technique to uniformly sample the parameter space from user defined parameters of the Biome-BGCMuSo model. The sampling algorithm ensures that the parameters are constrained by the model logic which means that parameter dependencies are fully taken into account (parameter dependency means that e.g leaf C:N ratio must be smaller than C:N ratio of litter; more complicated rules apply to the allocation parameters where the allocation fractions to different plant compartments must sum up 1). This function implements a mathematically correct solution to provide uniform distriution for all selected parameters.
|
||||
#' @author Roland HOLLOS
|
||||
#' @importFrom future future
|
||||
#' @export
|
||||
calibrateMuso <- function(measuredData, parameters = NULL, startDate = NULL,
|
||||
endDate = NULL, formatString = "%Y-%m-%d",
|
||||
dataVar, outLoc = "./calib",
|
||||
preTag = "cal-", settings = setupMuso(),
|
||||
outVars = NULL, iterations = 100,
|
||||
skipSpinup = TRUE, plotName = "calib.jpg",
|
||||
modifyOriginal=TRUE, likelihood, uncertainity = NULL,
|
||||
naVal = NULL, postProcString = NULL,
|
||||
thread_prefix="thread", numCores = (parallel::detectCores()-1), pb = txtProgressBar(min=0, max=iterations, style=3),
|
||||
maxLikelihoodEpc=TRUE,
|
||||
pbUpdate = setTxtProgressBar, outputLoc="./", method="GLUE",lg = FALSE, w=NULL, ...){
|
||||
|
||||
future::plan(future::multisession)
|
||||
file.remove(list.files(path = settings$inputLoc, pattern="progress.txt", recursive = TRUE, full.names=TRUE))
|
||||
file.remove(list.files(path = settings$inputLoc, pattern="preservedCalib.csv", recursive = TRUE, full.names=TRUE))
|
||||
unlink(file.path(settings$inputLoc,"thread"),recursive=TRUE)
|
||||
|
||||
# ____ _ _ _ _
|
||||
# / ___|_ __ ___ __ _| |_ ___ | |_| |__ _ __ ___ __ _ __| |___
|
||||
# | | | '__/ _ \/ _` | __/ _ \ | __| '_ \| '__/ _ \/ _` |/ _` / __|
|
||||
# | |___| | | __/ (_| | || __/ | |_| | | | | | __/ (_| | (_| \__ \
|
||||
# \____|_| \___|\__,_|\__\___| \__|_| |_|_| \___|\__,_|\__,_|___/
|
||||
|
||||
|
||||
|
||||
copyToThreadDirs(thread_prefix, numcores = numCores, runDir = settings$inputLoc)
|
||||
|
||||
# ____ _ _ _
|
||||
# | _ \ _ _ _ __ | |_| |__ _ __ ___ __ _ __| |___
|
||||
# | |_) | | | | '_ \ | __| '_ \| '__/ _ \/ _` |/ _` / __|
|
||||
# | _ <| |_| | | | | | |_| | | | | | __/ (_| | (_| \__ \
|
||||
# |_| \_\\__,_|_| |_| \__|_| |_|_| \___|\__,_|\__,_|___/
|
||||
|
||||
threadCount <- distributeCores(iterations, numCores)
|
||||
|
||||
fut <- lapply(1:numCores, function(i) {
|
||||
# browser()
|
||||
future({
|
||||
tryCatch(
|
||||
musoSingleThread(measuredData, parameters, startDate,
|
||||
endDate, formatString,
|
||||
dataVar, outLoc,
|
||||
preTag, settings,
|
||||
outVars, iterations = threadCount[i],
|
||||
skipSpinup, plotName,
|
||||
modifyOriginal, likelihood, uncertainity,
|
||||
naVal, postProcString, i)
|
||||
, error = function(e){
|
||||
writeLines(as.character(iterations),"progress.txt")
|
||||
})
|
||||
|
||||
# musoSingleThread(measuredData, parameters, startDate,
|
||||
# endDate, formatString,
|
||||
# dataVar, outLoc,
|
||||
# preTag, settings,
|
||||
# outVars, iterations = threadCount[i],
|
||||
# skipSpinup, plotName,
|
||||
# modifyOriginal, likelihood, uncertainity,
|
||||
# naVal, postProcString, i)
|
||||
})
|
||||
})
|
||||
|
||||
# __ ___ _ _
|
||||
# \ \ / / |__ __ _| |_ ___| |__ _ __ _ __ ___ ___ ___ ___ ___
|
||||
# \ \ /\ / /| '_ \ / _` | __/ __| '_ \ | '_ \| '__/ _ \ / __/ _ \/ __/ __|
|
||||
# \ V V / | | | | (_| | || (__| | | | | |_) | | | (_) | (_| __/\__ \__ \
|
||||
# \_/\_/ |_| |_|\__,_|\__\___|_| |_| | .__/|_| \___/ \___\___||___/___/
|
||||
# |_|
|
||||
|
||||
getProgress <- function(){
|
||||
# threadfiles <- list.files(settings$inputLoc, pattern="progress.txt", recursive = TRUE)
|
||||
threadfiles <- list.files(pattern="progress.txt", recursive = TRUE)
|
||||
if(length(threadfiles)==0){
|
||||
return(0)
|
||||
} else {
|
||||
sum(sapply(threadfiles, function(x){
|
||||
partRes <- readLines(x)
|
||||
if(length(partRes)==0){
|
||||
return(0)
|
||||
} else {
|
||||
return(as.numeric(partRes))
|
||||
}
|
||||
|
||||
}))
|
||||
|
||||
}
|
||||
}
|
||||
|
||||
progress <- 0
|
||||
while(progress < iterations){
|
||||
Sys.sleep(1)
|
||||
progress <- tryCatch(getProgress(), error=function(e){progress})
|
||||
if(is.null(pb)){
|
||||
pbUpdate(as.numeric(progress))
|
||||
} else {
|
||||
pbUpdate(pb,as.numeric(progress))
|
||||
}
|
||||
}
|
||||
if(!is.null(pb)){
|
||||
close(pb)
|
||||
}
|
||||
|
||||
# ____ _ _
|
||||
# / ___|___ _ __ ___ | |__ (_)_ __ ___
|
||||
# | | / _ \| '_ ` _ \| '_ \| | '_ \ / _ \
|
||||
# | |__| (_) | | | | | | |_) | | | | | __/
|
||||
# \____\___/|_| |_| |_|_.__/|_|_| |_|\___|
|
||||
resultFiles <- list.files(pattern="preservedCalib.*csv$",recursive=TRUE)
|
||||
res0 <- read.csv(grep("thread_1/",resultFiles, value=TRUE),stringsAsFactors=FALSE)
|
||||
resultFilesSans0 <- grep("thread_1/", resultFiles, value=TRUE, invert=TRUE)
|
||||
# results <- do.call(rbind,lapply(resultFilesSans0, function(f){read.csv(f, stringsAsFactors=FALSE)}))
|
||||
resultsSans0 <- lapply(resultFilesSans0, function(f){read.csv(f, stringsAsFactors=FALSE, header=FALSE)})
|
||||
resultsSans0 <- do.call(rbind,resultsSans0)
|
||||
colnames(resultsSans0) <- colnames(res0)
|
||||
results <- (rbind(res0,resultsSans0))
|
||||
|
||||
switch(method,
|
||||
"GLUE"={
|
||||
musoGlue(results, parameters=parameters,settings=settings, w=w, lg=lg)
|
||||
},
|
||||
"agromo"={
|
||||
liks <- results[,sprintf("%s_likelihood",names(likelihood))]
|
||||
epcIndexes <- future::value(fut[[1]], stdout = FALSE, signal=FALSE)
|
||||
epcVals <- results[which.max(liks),1:length(epcIndexes)]
|
||||
epcPlace <- file.path(dirname(settings$inputFiles),settings$epc)[2]
|
||||
changemulline(filePaths= epcPlace, epcIndexes,
|
||||
epcVals, src =epcPlace,# settings$epcInput[2],
|
||||
outFiles = file.path(outputLoc, "maxLikelihood_epc.epc"))
|
||||
names(epcVals) <- epcIndexes
|
||||
xdate <- as.Date(measuredData$date)
|
||||
meanM <- measuredData[,sprintf("mean.%s", names(likelihood))]
|
||||
minsd <- meanM - measuredData[,sprintf("sd.%s", names(likelihood)[1])]
|
||||
maxsd <- meanM + measuredData[,sprintf("sd.%s", names(likelihood)[1])]
|
||||
minM <- measuredData[,sprintf("min.%s", names(likelihood)[1])]
|
||||
maxM <- measuredData[,sprintf("max.%s", names(likelihood)[1])]
|
||||
plot(xdate, minM, type="l", xlab=NA, ylim=c(min(minM)*0.8, max(maxM)*1.1), ylab = names(likelihood)[1])
|
||||
lines(xdate, maxM)
|
||||
polygon(c(xdate,rev(xdate)),c(minM,rev(maxM)), col="gray",border=NA)
|
||||
lines(xdate, minsd)
|
||||
lines(xdate, maxsd)
|
||||
polygon(c(xdate,rev(xdate)),c(minsd,rev(maxsd)), col="gray30",border=NA)
|
||||
points(xdate,meanM)
|
||||
|
||||
varIndex <- match(as.character(dataVar),settings$dailyVarCodes)
|
||||
apriori <- calibMuso(settings)
|
||||
modDates <- as.Date(row.names(apriori), format="%d.%m.%Y")
|
||||
lines(modDates, apriori[,varIndex],col="brown")
|
||||
calibrated <- calibMuso(settings, calibrationPar = as.numeric(names(epcVals)), parameters=epcVals)
|
||||
lines(modDates, calibrated[,varIndex],col="blue")
|
||||
|
||||
},
|
||||
stop(sprintf("method: %s not found, please choose from {GLUE, agromo}. See more about this in the documentation of the function!", method))
|
||||
)
|
||||
}
|
||||
|
||||
copyToThreadDirs <- function(prefix="thread", numcores=parallel::detectCores()-1, runDir="."){
|
||||
dir.create(file.path(runDir,prefix), showWarnings=TRUE)
|
||||
fileNames <- grep("^thread.*", list.files(runDir,full.names=TRUE), value=TRUE, invert=TRUE)
|
||||
invisible(sapply(1:numcores,function(corenum){
|
||||
threadDir <- file.path(runDir,prefix,paste0(prefix,"_",corenum))
|
||||
dir.create(threadDir, showWarnings=FALSE)
|
||||
file.copy(from=fileNames,to=threadDir, overwrite=FALSE)
|
||||
}))
|
||||
}
|
||||
|
||||
musoSingleThread <- function(measuredData, parameters = NULL, startDate = NULL,
|
||||
endDate = NULL, formatString = "%Y-%m-%d",
|
||||
dataVar, outLoc = "./calib",
|
||||
preTag = "cal-", settings = setupMuso(),
|
||||
outVars = NULL, iterations = 300,
|
||||
skipSpinup = TRUE, plotName = "calib.jpg",
|
||||
modifyOriginal=TRUE, likelihood, uncertainity = NULL,
|
||||
naVal = NULL, postProcString = NULL, threadNumber) {
|
||||
|
||||
setwd(paste0(settings$inputLoc, "/thread/thread_", threadNumber))
|
||||
iniFiles <- list.files(pattern=".*ini")
|
||||
if(length(iniFiles)==1){
|
||||
iniFiles <- rep(iniFiles, 2)
|
||||
}
|
||||
iniFiles <- iniFiles[1:2]
|
||||
settings <- setupMuso(iniInput = iniFiles)
|
||||
# Exanding likelihood
|
||||
likelihoodFull <- as.list(rep(NA,length(dataVar)))
|
||||
names(likelihoodFull) <- names(dataVar)
|
||||
if(!missing(likelihood)) {
|
||||
lapply(names(likelihood),function(x){
|
||||
likelihoodFull[[x]] <<- likelihood[[x]]
|
||||
})
|
||||
}
|
||||
defaultLikelihood <- which(is.na(likelihood))
|
||||
if(length(defaultLikelihood)>0){
|
||||
likelihoodFull[[defaultLikelihood]] <- (function(x, y){
|
||||
exp(-sqrt(mean((x-y)^2)))
|
||||
})
|
||||
}
|
||||
|
||||
mdata <- measuredData
|
||||
if(is.null(parameters)){
|
||||
parameters <- tryCatch(read.csv("parameters.csv", stringsAsFactor=FALSE), error = function (e) {
|
||||
stop("You need to specify a path for the parameters.csv, or a matrix.")
|
||||
})
|
||||
} else {
|
||||
if((!is.list(parameters)) & (!is.matrix(parameters))){
|
||||
parameters <- tryCatch(read.csv(parameters, stringsAsFactor=FALSE), error = function (e){
|
||||
stop("Cannot find neither parameters file neither the parameters matrix")
|
||||
})
|
||||
}}
|
||||
|
||||
outLoc <- normalizePath(outLoc)
|
||||
outLocPlain <- basename(outLoc)
|
||||
currDir <- getwd()
|
||||
|
||||
if(!dir.exists(outLoc)){
|
||||
dir.create(outLoc)
|
||||
warning(paste(outLoc," is not exists, so it was created"))
|
||||
}
|
||||
|
||||
outLoc <- normalizePath(outLoc)
|
||||
parameterNames <- parameters[,1]
|
||||
pretag <- file.path(outLoc,preTag)
|
||||
##reading the original epc file at the specified
|
||||
## row numbers
|
||||
print("optiMuso is randomizing the epc parameters now...",quote = FALSE)
|
||||
if(iterations < 3000){
|
||||
randVals <- musoRand(parameters = parameters,constrains = NULL, iterations = 3000)
|
||||
randVals[[2]]<- randVals[[2]][sample(1:3000,iterations),]
|
||||
} else {
|
||||
randVals <- musoRand(parameters = parameters,constrains = NULL, iterations = iterations)
|
||||
}
|
||||
|
||||
origEpc <- readValuesFromFile(settings$epc[2],randVals[[1]])
|
||||
partialResult <- matrix(ncol=length(randVals[[1]])+2*length(dataVar))
|
||||
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)))
|
||||
numParameters <- length(colN)
|
||||
partialResult[1:numParameters] <- origEpc
|
||||
## Prepare the preservedCalib matrix for the faster
|
||||
## run.
|
||||
|
||||
pretag <- file.path(outLoc,preTag)
|
||||
|
||||
musoCodeToIndex <- sapply(dataVar,function(musoCode){
|
||||
settings$dailyOutputTable[settings$dailyOutputTable$code == musoCode,"index"]
|
||||
})
|
||||
resultRange <- (numParameters + 1):(ncol(partialResult))
|
||||
## Creating function for generating separate
|
||||
## csv files for each run
|
||||
|
||||
settings$iniInput[2] %>%
|
||||
(function(x) paste0(dirname(x),"/",tools::file_path_sans_ext(basename(x)),"-tmp.",tools::file_ext(x))) %>%
|
||||
unlink
|
||||
randValues <- randVals[[2]]
|
||||
|
||||
settings$calibrationPar <- randVals[[1]]
|
||||
|
||||
if(!is.null(naVal)){
|
||||
measuredData <- as.data.frame(measuredData)
|
||||
measuredData[measuredData == naVal] <- NA
|
||||
}
|
||||
|
||||
alignIndexes <- alignMuso(settings,measuredData)
|
||||
if(!is.null(uncertainity)){
|
||||
uncert <- measuredData[alignIndexes$meas,uncertainity]
|
||||
} else {
|
||||
uncert <- NULL
|
||||
}
|
||||
# browser()
|
||||
if(threadNumber == 1){
|
||||
origModellOut <- calibMuso(settings=settings, silent=TRUE, skipSpinup = skipSpinup, postProcString=postProcString, modifyOriginal=modifyOriginal)
|
||||
partialResult[,resultRange] <- calcLikelihoodsAndRMSE(dataVar=dataVar,
|
||||
mod=origModellOut,
|
||||
mes=measuredData,
|
||||
likelihoods=likelihood,
|
||||
alignIndexes=alignIndexes,
|
||||
musoCodeToIndex = musoCodeToIndex,uncert=uncert)
|
||||
write.csv(x=origModellOut, file=paste0(pretag, 1, ".csv"))
|
||||
write.csv(x=partialResult, file="preservedCalib.csv",row.names=FALSE)
|
||||
}
|
||||
print("Running the model with the random epc values...", quote = FALSE)
|
||||
|
||||
# if(!is.null(postProcString)){
|
||||
# colNumb <- length(settings$dailyVarCodes) + 1
|
||||
# }
|
||||
|
||||
|
||||
for(i in 2:(iterations+1)){
|
||||
|
||||
tmp <- tryCatch(calibMuso(settings = settings,
|
||||
parameters = randValues[(i-1),],
|
||||
silent= TRUE,
|
||||
skipSpinup = skipSpinup, modifyOriginal=modifyOriginal, postProcString = postProcString), error = function (e) NULL)
|
||||
if(is.null(tmp)){
|
||||
partialResult[,resultRange] <- NA
|
||||
} else {
|
||||
partialResult[,resultRange] <- calcLikelihoodsAndRMSE(dataVar=dataVar,
|
||||
mod=tmp,
|
||||
mes=measuredData,
|
||||
likelihoods=likelihood,
|
||||
alignIndexes=alignIndexes,
|
||||
musoCodeToIndex = musoCodeToIndex, uncert = uncert)
|
||||
}
|
||||
|
||||
partialResult[1:numParameters] <- randValues[(i-1),]
|
||||
write.table(x=partialResult, file="preservedCalib.csv", append=TRUE, row.names=FALSE,
|
||||
sep=",", col.names=FALSE)
|
||||
write.csv(x=tmp, file=paste0(pretag, (i+1),".csv"))
|
||||
writeLines(as.character(i-1),"progress.txt")
|
||||
}
|
||||
|
||||
if(threadNumber == 1){
|
||||
return(randVals[[1]])
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
distributeCores <- function(iterations, numCores){
|
||||
perProcess<- iterations %/% numCores
|
||||
numSimu <- rep(perProcess,numCores)
|
||||
gainers <- sample(1:numCores, iterations %% numCores)
|
||||
numSimu[gainers] <- numSimu[gainers] + 1
|
||||
numSimu
|
||||
}
|
||||
|
||||
prepareFromAgroMo <- function(fName){
|
||||
obs <- read.table(fName, stringsAsFactors=FALSE, sep = ";", header=T)
|
||||
obs <- reshape(obs, timevar="var_id", idvar = "date", direction = "wide")
|
||||
dateCols <- apply(do.call(rbind,(strsplit(obs$date, split = "-"))),2,as.numeric)
|
||||
colnames(dateCols) <- c("year", "month", "day")
|
||||
cbind.data.frame(dateCols, obs)
|
||||
}
|
||||
|
||||
|
||||
calcLikelihoodsAndRMSE <- function(dataVar, mod, mes, likelihoods, alignIndexes, musoCodeToIndex, uncert){
|
||||
|
||||
# NOT COMPATIBLE WITH OLD MEASUREMENT DATA, mes have to be a matrix
|
||||
likelihoodRMSE <- sapply(names(dataVar),function(key){
|
||||
# browser()
|
||||
modelled <- mod[alignIndexes$mod,musoCodeToIndex[key]]
|
||||
selected <- grep(sprintf("%s$", key), colnames(mes))
|
||||
# browser()
|
||||
measured <- mes[alignIndexes$meas,selected]
|
||||
notNA <- sapply(1:nrow(measured), function(x){!any(is.na(measured[x,]))})
|
||||
modelled <- modelled[notNA]
|
||||
measured <- measured[notNA,]
|
||||
# uncert <- uncert[!is.na(measured)]
|
||||
|
||||
# measured <- measured[!is.na(measured)]
|
||||
apply(measured, 1, function(x){!any(is.na(x))})
|
||||
measured <- t(apply(measured, 1, function(x){if(!any(is.na(x))){x}} ))
|
||||
if(ncol(measured)!=1){
|
||||
m <- measured[,grep("^mean", colnames(measured))]
|
||||
}
|
||||
res <- c(likelihoods[[key]](modelled, measured),
|
||||
sqrt(mean((modelled-m)^2))
|
||||
)
|
||||
# browser()
|
||||
res
|
||||
})
|
||||
names(likelihoodRMSE) <- c(sprintf("%s_likelihood",dataVar), sprintf("%s_rmse",dataVar))
|
||||
|
||||
return(c(likelihoodRMSE[1,],likelihoodRMSE[2,]))
|
||||
}
|
||||
|
||||
agroLikelihood <- function(modVector,measured){
|
||||
mu <- measured[,grep("mean", colnames(measured))]
|
||||
stdev <- measured[,grep("^sd", colnames(measured))]
|
||||
ndata <- nrow(measured)
|
||||
sum(sapply(1:ndata, function(x){
|
||||
dnorm(modVector, mu[x], stdev[x], log = TRUE)
|
||||
}), na.rm=TRUE)
|
||||
}
|
||||
|
||||
|
||||
|
||||
maxLikelihoodAgromo <- function (results, imgPath, varName, ...) {
|
||||
|
||||
}
|
||||
@ -33,7 +33,7 @@ optiMuso <- function(measuredData, parameters = NULL, startDate = NULL,
|
||||
outVars = NULL, iterations = 30,
|
||||
skipSpinup = TRUE, plotName = "calib.jpg",
|
||||
modifyOriginal=TRUE, likelihood, uncertainity = NULL,
|
||||
naVal = NULL, postProcString = NULL, w=NULL, lg=FALSE) {
|
||||
naVal = NULL, postProcString = NULL, w=NULL, lg=FALSE, parallel = TRUE) {
|
||||
# Exanding likelihood
|
||||
likelihoodFull <- as.list(rep(NA,length(dataVar)))
|
||||
names(likelihoodFull) <- names(dataVar)
|
||||
@ -187,24 +187,24 @@ alignMuso <- function (settings,measuredData) {
|
||||
cbind.data.frame(model=modIndex,meas=measIndex)
|
||||
}
|
||||
|
||||
calcLikelihoodsAndRMSE <- function(dataVar, mod, mes, likelihoods, alignIndexes, musoCodeToIndex, uncert){
|
||||
|
||||
likelihoodRMSE <- sapply(names(dataVar),function(key){
|
||||
# browser()
|
||||
modelled <- mod[alignIndexes$mod,musoCodeToIndex[key]]
|
||||
measured <- mes[alignIndexes$meas,key]
|
||||
modelled <- modelled[!is.na(measured)]
|
||||
# uncert <- uncert[!is.na(measured)]
|
||||
measured <- measured[!is.na(measured)]
|
||||
res <- c(likelihoods[[key]](modelled, measured, uncert),
|
||||
sqrt(mean((modelled-measured)^2))
|
||||
)
|
||||
res
|
||||
})
|
||||
names(likelihoodRMSE) <- c(sprintf("%s_likelihood",dataVar), sprintf("%s_rmse",dataVar))
|
||||
|
||||
return(c(likelihoodRMSE[1,],likelihoodRMSE[2,]))
|
||||
}
|
||||
# calcLikelihoodsAndRMSE <- function(dataVar, mod, mes, likelihoods, alignIndexes, musoCodeToIndex, uncert){
|
||||
#
|
||||
# likelihoodRMSE <- sapply(names(dataVar),function(key){
|
||||
# # browser()
|
||||
# modelled <- mod[alignIndexes$mod,musoCodeToIndex[key]]
|
||||
# measured <- mes[alignIndexes$meas,key]
|
||||
# modelled <- modelled[!is.na(measured)]
|
||||
# # uncert <- uncert[!is.na(measured)]
|
||||
# measured <- measured[!is.na(measured)]
|
||||
# res <- c(likelihoods[[key]](modelled, measured, uncert),
|
||||
# sqrt(mean((modelled-measured)^2))
|
||||
# )
|
||||
# res
|
||||
# })
|
||||
# names(likelihoodRMSE) <- c(sprintf("%s_likelihood",dataVar), sprintf("%s_rmse",dataVar))
|
||||
#
|
||||
# return(c(likelihoodRMSE[1,],likelihoodRMSE[2,]))
|
||||
# }
|
||||
|
||||
#' musoGlue
|
||||
#'
|
||||
@ -215,7 +215,12 @@ calcLikelihoodsAndRMSE <- function(dataVar, mod, mes, likelihoods, alignIndexes,
|
||||
#' @export
|
||||
musoGlue <- function(presCalFile, w, delta = 0.17, settings=setupMuso(), parameters=read.csv("parameters.csv",
|
||||
stringsAsFactors=FALSE), lg=FALSE){
|
||||
preservedCalib<- read.csv(presCalFile)
|
||||
if(is.data.frame(presCalFile)){
|
||||
preservedCalib <- presCalFile
|
||||
} else {
|
||||
preservedCalib <- read.csv(presCalFile)
|
||||
}
|
||||
|
||||
paramIndex <- parameters[(match(colnames(preservedCalib),parameters[,1])),2]
|
||||
paramIndex <- paramIndex[!is.na(paramIndex)]
|
||||
paramIndex <- c(paramIndex,
|
||||
@ -242,7 +247,8 @@ musoGlue <- function(presCalFile, w, delta = 0.17, settings=setupMuso(), paramet
|
||||
parameterIndexes <- 1:(min(likeIndexes)-1)
|
||||
preservedCalib <- preservedCalib[!is.na(preservedCalib$combined),]
|
||||
unfilteredLikelihood <- preservedCalib$combined
|
||||
preservedCalibtop5 <- preservedCalib[preservedCalib$combined>quantile(preservedCalib$combined,0.95),]
|
||||
top5points <- preservedCalib$combined>quantile(preservedCalib$combined,0.95)
|
||||
preservedCalibtop5 <- preservedCalib[,]
|
||||
optRanges <-t(apply(preservedCalibtop5,2,function(x) quantile(x,c(0.05,0.5,0.95))))
|
||||
pdf("dotplot.pdf")
|
||||
if(lg){
|
||||
@ -261,20 +267,40 @@ musoGlue <- function(presCalFile, w, delta = 0.17, settings=setupMuso(), paramet
|
||||
abline(v=optRanges[i,3],col="red")
|
||||
|
||||
}
|
||||
|
||||
par(pari)
|
||||
dev.off()
|
||||
maxParValues <- preservedCalibtop5[which.max(preservedCalibtop5$combined),]
|
||||
maxParIndexes <- paramIndex
|
||||
write.csv(cbind.data.frame(calibrationPar=maxParValues,parameters=maxParIndexes),"maxLikelihood.csv")
|
||||
write.csv(optRanges,"optRanges.csv")
|
||||
optInterval <-t(apply(preservedCalibtop5,2,function(x) quantile(x,c(0.5-delta,0.5+delta))))
|
||||
optParamRange <- cbind.data.frame(rownames(optInterval)[parameterIndexes],as.numeric(paramIndex),optInterval[parameterIndexes,])
|
||||
optimalEpc <- musoRand(optParamRange,iterations = 2)
|
||||
optimalEpc[[2]] <- optimalEpc[[2]][1,]
|
||||
write.csv(as.data.frame(optimalEpc),"epcOptim.csv")
|
||||
print(head(optRanges,n=-2))
|
||||
calibMuso(calibrationPar=optimalEpc[[1]],parameters=optimalEpc[[2]])
|
||||
file.copy(settings$epcInput[2],"epcOptim.epc")
|
||||
# browser()
|
||||
# There are some serious problems with this implementation. The uncertainity bouns are not for the parameters, but for the output values. The median is pointwise median for all simulation.
|
||||
# And the 95 and 5 percentile also.
|
||||
# dataVec <- preservedCalibtop5$combined
|
||||
# closestToMedian <- function (dataVec) {
|
||||
# match(sort(dataVec)[min(which(sort(dataVec)>=median(dataVec)))], dataVec)
|
||||
# }
|
||||
#
|
||||
# while(is.null(optimalEpc)){
|
||||
# match(quantile(preservedCalibtop5$combined,0.5), preservedCalibtop5$combined)
|
||||
# optInterval <-t(apply(preservedCalibtop5,2,function(x) quantile(x,c(0.5-delta,0.5+delta))))
|
||||
# optParamRange <- cbind.data.frame(rownames(optInterval)[parameterIndexes],as.numeric(paramIndex),optInterval[parameterIndexes,])
|
||||
# optimalEpc <- tryCatch(musoRand(optParamRange,iterations = 2), error=function(e){NULL})
|
||||
# delta <- delta*1.05
|
||||
# if(delta > 0.5){
|
||||
# delta <- 0.5
|
||||
# }
|
||||
# if((delta == 0.5) && is.null(optimalEpc)){
|
||||
# stop("cannot find optimal value in the given range")
|
||||
# }
|
||||
# }
|
||||
# print("getOptim")
|
||||
# optimalEpc[[2]] <- optimalEpc[[2]][1,]
|
||||
# write.csv(as.data.frame(optimalEpc),"epcOptim.csv")
|
||||
# print(head(optRanges,n=-2))
|
||||
# calibMuso(calibrationPar=optimalEpc[[1]],parameters=optimalEpc[[2]])
|
||||
# file.copy(settings$epcInput[2],"epcOptim.epc")
|
||||
}
|
||||
|
||||
generateOptEpc <- function(optRanges,delta, maxLikelihood=FALSE){
|
||||
|
||||
@ -1,14 +1,11 @@
|
||||
#' This is the function which is capable to change multiple specific lines to others using their row numbers.
|
||||
#' changemulline
|
||||
#'
|
||||
#' The function uses the previous changspecline function to operate.
|
||||
##From now changespecline is in the forarcheologist file, because itis no longer needed
|
||||
#'
|
||||
#' @author Roland Hollos
|
||||
#' @keywords internal
|
||||
#'
|
||||
#' @export
|
||||
|
||||
|
||||
changemulline <- function(filePaths, calibrationPar, contents, src){
|
||||
changemulline <- function(filePaths, calibrationPar, contents, src, outFiles=filePaths){
|
||||
# browser()
|
||||
if(is.null(src)){
|
||||
src <- filePaths
|
||||
@ -19,7 +16,7 @@ changemulline <- function(filePaths, calibrationPar, contents, src){
|
||||
fileStringVector <<- changeByIndex(index, content, fileStringVector)
|
||||
|
||||
}, calibrationPar, contents)
|
||||
writeLines(fileStringVector, filePaths)
|
||||
writeLines(fileStringVector, outFiles)
|
||||
|
||||
}
|
||||
|
||||
|
||||
@ -1,533 +0,0 @@
|
||||
#' getMeteoData1BGC
|
||||
#'
|
||||
#' This function downloads hourly 2m air temperature and total precipitation values in NetCDF file format
|
||||
#' at one grid point to create MTClim files which contain daily data.
|
||||
#' Please note that, to download ERA5, you need Copernicus registration and API key.
|
||||
#' According to default settings, data will be downloaded in the gridpoint of Martonvasar (Hungary), in 2017.
|
||||
#'
|
||||
#' @author Erzsebet Kristof, Roland Hollos
|
||||
#' @param startYear Start year of the downloading data. It shall be greater than 1978.
|
||||
#' @param endYear End year of the downloading data. It shall be smaller than 2020.
|
||||
#' @param lon Geographical longitude of the selected grid point (negative values: W, positive values: E). It shall be between -180 and 180. The value is rounded to two decimal places.
|
||||
#' @param lat Geographical latitude of the selected grid point (negative values: S, positive values: N). It shall be between -90 and 90. The value is rounded to two decimal places.
|
||||
#' @param timeOut Time in seconds to wait to download from Copernicus.
|
||||
#' @param monthList Month selector (e.g. to download data for April then write "01", to download data for September and October then write c("04","05")
|
||||
#' @param dayList Day selector (e.g. to download data for the 1st day of the month(s) then write "01", to download data for the 2nd and 4th day of the month then write c("02","04")
|
||||
#' @param hourList Hour selector (e.g. to download data for 00 UTC then write "00:00", to download data for 01 UTC and 15 UTC then write c("01","15")
|
||||
#' @param fileDir Directory where the .ini and .mtcin files will be created
|
||||
#' @param destDir Directory where the wth file will be created. If it is NULL then destDir is the same as fileDir.
|
||||
#' @param apiFile Directory where the cdsapirc file is located
|
||||
#' @importFrom ecmwfr wf_set_key wf_request
|
||||
#' @importFrom ncdf4 nc_open ncvar_get nc_close ncvar_put ncdim_def ncvar_def nc_create
|
||||
#' @importFrom tcltk tk_choose.dir tk_choose.files
|
||||
#' @export
|
||||
|
||||
getMeteoData1BGC <- function(startYear=2017, endYear=2017, lon=18.8, lat=47.3, timeOut=7200,
|
||||
monthList=sprintf("%02d",1:12),
|
||||
dayList=sprintf("%02d",1:31),
|
||||
hourList=sprintf("%02d:00",0:23),
|
||||
destDir=NULL, apiFile=NULL, fileDir=NULL) {
|
||||
|
||||
if ((startYear<1979)|(endYear>2019)) {
|
||||
stop("Error, please choose a year between 1979 and 2019.")
|
||||
}
|
||||
|
||||
if (startYear>endYear) {
|
||||
stop("Error, start year shall be larger than end year.")
|
||||
}
|
||||
|
||||
if(is.null(destDir)){
|
||||
destDir <- "mtcFiles"
|
||||
}
|
||||
|
||||
# print("Please choose the file in the pop-up window which contains the CDS API key.")
|
||||
|
||||
# With tk_choose.files, it is not working in R Server.
|
||||
if(is.null(apiFile)){
|
||||
apiFile <- tk_choose.files(caption = "Please choose the file which contains the CDS API key.")
|
||||
print(sprintf("Apifile: %s is selected",apiFile))
|
||||
}
|
||||
|
||||
if(is.null(fileDir)){
|
||||
fileDir <- tk_choose.dir(caption = "Please choose the fileDir.")
|
||||
}
|
||||
|
||||
apiCodes <- suppressWarnings(readLines(apiFile)[2])
|
||||
apiCodes <- unlist(strsplit(apiCodes,split=":"))
|
||||
userID <- trimws(apiCodes[2])
|
||||
APIkey <- trimws(apiCodes[3])
|
||||
|
||||
# print("Please choose an empty folder in the pop-up window in which MTClim file will be generated.")
|
||||
currDir <- getwd()
|
||||
# fileDir <- tk_choose.dir(caption = "Please choose an empty folder in which MTClim file will be generated.")
|
||||
setwd(fileDir)
|
||||
dir.create(destDir)
|
||||
|
||||
lonList <- expand.grid(lon,lat)[,1]
|
||||
latList <- expand.grid(lon,lat)[,2]
|
||||
|
||||
for (grid in 1:length(lonList)) {
|
||||
|
||||
if ((lonList[grid]>=180.01)|(lonList[grid]<=-180.01)) {
|
||||
stop("Error, please choose a geographical longitude between -180 and 180.")
|
||||
}
|
||||
|
||||
if ((latList[grid]>=90.01)|(latList[grid]<=-90.01)) {
|
||||
stop("Error, please choose a geographical latitude between -90 and 90.")
|
||||
}
|
||||
|
||||
lon <- round(lonList[grid], digits=2)
|
||||
lat <- round(latList[grid], digits=2)
|
||||
|
||||
lonSub <- gsub("[.]", "_", as.character(lonList[grid]))
|
||||
latSub <- gsub("[.]", "_", as.character(latList[grid]))
|
||||
|
||||
print("-----------------------------------------------------------------")
|
||||
print("1/6. WAITING TO COPERNICUS TO VALIDATE USER ID...")
|
||||
# Download 2m temperature data from ERA5:
|
||||
userID <- wf_set_key(user = userID,
|
||||
key = APIkey,
|
||||
service = "cds")
|
||||
|
||||
print("-----------------------------------------------------------------")
|
||||
print("2/6. DOWNLOADING TEMPERATURE DATASET FROM ERA5 DATABASE. PLEASE WAIT...")
|
||||
|
||||
request <- list(
|
||||
"dataset" = "reanalysis-era5-single-levels",
|
||||
"class" = "ea",
|
||||
"expver" = "1",
|
||||
"stream" = "oper",
|
||||
"product_type" = "reanalysis",
|
||||
"variable" = "167.128",
|
||||
"year" = as.character(startYear:endYear),
|
||||
"month" = monthList,
|
||||
"day" = dayList,
|
||||
"time" = hourList,
|
||||
"area" = paste0(lat,"/",lon,"/",lat,"/",lon), # N, W, S, E
|
||||
"grid" = "0.1/0.1",
|
||||
"format" = "netcdf",
|
||||
"target" = paste0("ERA5_hourly_t2m_",startYear,"-",
|
||||
endYear,"_lat_",lat,"_lon_",lon,".nc"))
|
||||
|
||||
file <- wf_request(user = userID, # user ID (for authentification)
|
||||
request = request, # the request
|
||||
transfer = TRUE, # download the file
|
||||
path = fileDir,
|
||||
time_out = timeOut)
|
||||
|
||||
print("-----------------------------------------------------------------")
|
||||
print("3/6. DOWNLOADING PRECIPITATION DATASET FROM ERA5 DATABASE. PLEASE WAIT...")
|
||||
|
||||
# Download total precipitation data from ERA5:
|
||||
request <- list(
|
||||
"dataset" = "reanalysis-era5-single-levels",
|
||||
"class" = "ea",
|
||||
"expver" = "1",
|
||||
"stream" = "oper",
|
||||
"product_type" = "reanalysis",
|
||||
"variable" = "228.128",
|
||||
"year" = as.character(startYear:endYear),
|
||||
"month" = monthList,
|
||||
"day" = dayList,
|
||||
"time" = hourList,
|
||||
"area" = paste0(lat,"/",lon,"/",lat,"/",lon), # N, W, S, E
|
||||
"grid" = "0.1/0.1",
|
||||
"format" = "netcdf",
|
||||
"target" = paste0("ERA5_hourly_precip_",startYear,"-",endYear,"_lat_",lat,"_lon_",lon,".nc"))
|
||||
|
||||
file <- wf_request(user = userID, # user ID (for authentification)
|
||||
request = request, # the request
|
||||
transfer = TRUE, # download the file
|
||||
path = fileDir,
|
||||
time_out = timeOut)
|
||||
|
||||
print("-----------------------------------------------------------------")
|
||||
print("4/6. DOWNLOADING GEOPOTENTIAL DATASET FROM ERA5 DATABASE. PLEASE WAIT...")
|
||||
|
||||
# Download geopotential height data from ERA5:
|
||||
request <- list(
|
||||
"dataset" = "reanalysis-era5-single-levels",
|
||||
"class" = "ea",
|
||||
"expver" = "1",
|
||||
"stream" = "oper",
|
||||
"product_type" = "reanalysis",
|
||||
"variable" = "129.128",
|
||||
"year" = as.character(startYear:endYear),
|
||||
"month" = monthList,
|
||||
"day" = dayList,
|
||||
"time" = hourList,
|
||||
"area" = paste0(lat,"/",lon,"/",lat,"/",lon), # N, W, S, E
|
||||
"grid" = "0.1/0.1",
|
||||
"format" = "netcdf",
|
||||
"target" = paste0("ERA5_hourly_geopot_",startYear,"-",endYear,"_lat_",lat,"_lon_",lon,".nc"))
|
||||
|
||||
file <- wf_request(user = userID, # user ID (for authentification)
|
||||
request = request, # the request
|
||||
transfer = TRUE, # download the file
|
||||
path = fileDir,
|
||||
time_out = timeOut)
|
||||
|
||||
print("-----------------------------------------------------------------")
|
||||
print("5/6. CREATING MTCLIM FILES...")
|
||||
|
||||
### Creating MTClim files:
|
||||
|
||||
## Daily minimum and maximum temperature:
|
||||
|
||||
file.nc <- nc_open(paste0("ERA5_hourly_t2m_",startYear,"-",endYear,"_lat_",lat,"_lon_",lon,".nc"))
|
||||
longitude <- ncvar_get(file.nc, "longitude")
|
||||
latitude <- ncvar_get(file.nc, "latitude")
|
||||
timesteps <- ncvar_get(file.nc, "time")
|
||||
date <- as.POSIXct(timesteps*3600, origin="1900-01-01 00:00:0.0",tz="UTC")
|
||||
var <- ncvar_get(file.nc, "t2m")-273.15 # in Celsius
|
||||
nc_close(file.nc)
|
||||
|
||||
# Handling leap years:
|
||||
leapYear <- c("1952-12-31","1956-12-31","1960-12-31","1964-12-31","1968-12-31",
|
||||
"1972-12-31","1976-12-31","1980-12-31","1984-12-31","1988-12-31",
|
||||
"1992-12-31","1996-12-31","2000-12-31","2004-12-31","2008-12-31",
|
||||
"2012-12-31","2016-12-31","2020-12-31","2024-12-31")
|
||||
|
||||
leapYearIndex <- list()
|
||||
for (index in 1:length(leapYear)){
|
||||
if((length(which(grepl(leapYear[index], date)))>0)==TRUE){
|
||||
leapYearIndex[[index]] <- which(grepl(leapYear[index], date))
|
||||
}
|
||||
}
|
||||
|
||||
leapYearIndex <- unlist(leapYearIndex)
|
||||
|
||||
leapYearIndex <- na.omit(leapYearIndex)
|
||||
|
||||
if(length(leapYearIndex)>0){
|
||||
timesteps <- timesteps[-leapYearIndex]
|
||||
date <- date[-leapYearIndex]
|
||||
var <- var[-leapYearIndex]
|
||||
}
|
||||
|
||||
dailyT2mMin <- c(0)
|
||||
dailyT2mMax <- c(0)
|
||||
dailyT2mAvg <- c(0)
|
||||
|
||||
if(dim(var)%%24==0) {
|
||||
for (i in seq(1,dim(date),24)) {
|
||||
dailyT2mMin[i] <- min(var[i:(i+23)])
|
||||
|
||||
dailyT2mMax[i] <- max(var[i:(i+23)])
|
||||
|
||||
dailyT2mAvg[i] <- mean(var[i:(i+23)])
|
||||
|
||||
}
|
||||
}
|
||||
|
||||
dailyT2mMin <- na.omit(dailyT2mMin)
|
||||
dailyT2mMax <- na.omit(dailyT2mMax)
|
||||
|
||||
## Estimating elevation:
|
||||
file.nc <- nc_open(paste0("ERA5_hourly_geopot_",startYear,"-",endYear,"_lat_",lat,"_lon_",lon,".nc"))
|
||||
var2 <- ncvar_get(file.nc, "z") # in m**2/s**2
|
||||
nc_close(file.nc)
|
||||
|
||||
DB <- data.frame(0)
|
||||
DB[1,1] <- 1
|
||||
DB[1,2] <- 0
|
||||
DB[1,3] <- lat
|
||||
DB[1,4] <- lon
|
||||
DB[1,5] <- mean(var2)/9.80665
|
||||
DB[1,6] <- 0
|
||||
DB[1,7] <- 0
|
||||
DB[1,8] <- mean(var)
|
||||
DB[1,9] <- mean(dailyT2mAvg, na.rm=TRUE)
|
||||
|
||||
colnames(DB) <- c("new_id", "100m_rep_id", "lat (deg)", "long (deg)",
|
||||
"elev (m)", "fboritas", "nuts3", "Tavg", "dTavg")
|
||||
|
||||
# Save lon, lat values into csv:
|
||||
write.table(lon, "Lon.csv", sep=";", row.names=FALSE, col.names=FALSE)
|
||||
write.table(lat, "Lat.csv", sep=";", row.names=FALSE, col.names=FALSE)
|
||||
write.table(DB, "DB_GRID_TABLE.csv", sep=";", row.names=FALSE)
|
||||
|
||||
# Save the data into NetCDF files: tmin and tmax
|
||||
|
||||
lon_nc <- longitude
|
||||
lat_nc <- latitude
|
||||
time_nc <- timesteps[seq(1,dim(timesteps),24)]
|
||||
|
||||
longitude <- ncdim_def(name="longitude", units="degree", vals=lon_nc, longname="geographical longitude")
|
||||
latitude <- ncdim_def(name="latitude", units="degree", vals=lat_nc, longname="geographical latitude")
|
||||
time <- ncdim_def(name="time", units="day", vals=time_nc, longname="timesteps")
|
||||
|
||||
mv <- -999
|
||||
|
||||
variable_Tmin <- ncvar_def(name="Tmin", units="Celsius", dim=list(longitude,latitude,time),
|
||||
missval=mv, longname="Daily minimum temperature", prec="double")
|
||||
|
||||
variable_Tmax <- ncvar_def(name="Tmax", units="Celsius", dim=list(longitude,latitude,time),
|
||||
missval=mv, longname="Daily maximum temperature", prec="double")
|
||||
|
||||
nc_min <- nc_create(filename=paste0("ERA5_daily_t2m_min_",startYear,"-",endYear,"_lat_",lat,"_lon_",lon,".nc"), vars=list(variable_Tmin))
|
||||
nc_max <- nc_create(filename=paste0("ERA5_daily_t2m_max_",startYear,"-",endYear,"_lat_",lat,"_lon_",lon,".nc"), vars=list(variable_Tmax))
|
||||
|
||||
ncvar_put(nc_min, varid=variable_Tmin, vals=dailyT2mMin, start=c(1,1,1),
|
||||
count=c(dim(lon_nc),dim(lat_nc),length(timesteps[seq(1,dim(timesteps),24)])))
|
||||
|
||||
ncvar_put(nc_max, varid=variable_Tmax, vals=dailyT2mMax, start=c(1,1,1),
|
||||
count=c(dim(lon_nc),dim(lat_nc),length(timesteps[seq(1,dim(timesteps),24)])))
|
||||
|
||||
nc_close(nc_min)
|
||||
nc_close(nc_max)
|
||||
|
||||
## Daily precipitation sums:
|
||||
|
||||
file.nc <- nc_open(paste0("ERA5_hourly_precip_",startYear,"-",endYear,"_lat_",lat,"_lon_",lon,".nc"))
|
||||
longitude <- ncvar_get(file.nc, "longitude")
|
||||
latitude <- ncvar_get(file.nc, "latitude")
|
||||
timesteps <- ncvar_get(file.nc, "time")
|
||||
date <- as.POSIXct(timesteps*3600, origin="1900-01-01 00:00:0.0",tz="UTC")
|
||||
var <- ncvar_get(file.nc, "tp")*1000 # in mm
|
||||
nc_close(file.nc)
|
||||
|
||||
# Handling leap years:
|
||||
leapYearIndex <- list()
|
||||
for (index in 1:length(leapYear)){
|
||||
if((length(which(grepl(leapYear[index], date)))>0)==TRUE){
|
||||
leapYearIndex[[index]] <- which(grepl(leapYear[index], date))
|
||||
}
|
||||
}
|
||||
|
||||
leapYearIndex <- unlist(leapYearIndex)
|
||||
|
||||
leapYearIndex <- na.omit(leapYearIndex)
|
||||
|
||||
if(length(leapYearIndex)>0){
|
||||
timesteps <- timesteps[-leapYearIndex]
|
||||
date <- date[-leapYearIndex]
|
||||
var <- var[-leapYearIndex]
|
||||
}
|
||||
|
||||
dailyPrecipSum <- c(0)
|
||||
|
||||
if(dim(var)%%24==0) {
|
||||
for (i in seq(1,dim(date),24)) {
|
||||
dailyPrecipSum[i] <- sum(var[i:(i+23)])
|
||||
}
|
||||
}
|
||||
|
||||
dailyPrecipSum <- na.omit(dailyPrecipSum)
|
||||
summary(dailyPrecipSum)
|
||||
length(dailyPrecipSum)
|
||||
length(dailyPrecipSum)
|
||||
|
||||
# Save the data into NetCDF files: precip
|
||||
|
||||
# Dimensions:
|
||||
lon_nc <- longitude
|
||||
lat_nc <- latitude
|
||||
time_nc <- timesteps[seq(1,dim(timesteps),24)]
|
||||
|
||||
longitude <- ncdim_def(name="longitude", units="degree", vals=lon_nc, longname="geographical longitude")
|
||||
latitude <- ncdim_def(name="latitude", units="degree", vals=lat_nc, longname="geographical latitude")
|
||||
time <- ncdim_def(name="time", units="day", vals=time_nc, longname="timesteps")
|
||||
|
||||
mv <- -999
|
||||
|
||||
variable <- ncvar_def(name="prcp", units="mm", dim=list(longitude,latitude,time),
|
||||
missval=mv, longname="Daily precipitation sums", prec="double")
|
||||
|
||||
nc <- nc_create(filename=paste0("ERA5_daily_precip_sum_",startYear,"-",endYear,"_lat_",lat,"_lon_",lon,".nc"), vars=list(variable))
|
||||
|
||||
ncvar_put(nc, varid=variable, vals=dailyPrecipSum, start=c(1,1,1),
|
||||
count=c(dim(lon_nc),dim(lat_nc),length(timesteps[seq(1,dim(timesteps),24)])))
|
||||
|
||||
nc_close(nc)
|
||||
|
||||
listifyNCDF <- function(ncFile, dataLab, lat, lon, gridCoords){
|
||||
dataCon <- nc_open(ncFile)
|
||||
dataVal <- ncvar_get(dataCon, dataLab)
|
||||
lonVal <- lon
|
||||
latVal <- lat
|
||||
dataCoords <- expand.grid(latVal[1],lonVal[1])
|
||||
numberOfGridCells <- nrow(gridCoords)
|
||||
|
||||
dataOut <- list()
|
||||
for(i in 1: numberOfGridCells){
|
||||
dataOut[[i]] <- dataVal
|
||||
}
|
||||
return(dataOut)
|
||||
}
|
||||
|
||||
daily_precip.nc <- nc_open(paste0("ERA5_daily_precip_sum_", startYear,
|
||||
"-", endYear, "_lat_", lat, "_lon_", lon, ".nc"))
|
||||
daily_tmin.nc <- nc_open(paste0("ERA5_daily_t2m_min_", startYear,
|
||||
"-", endYear, "_lat_", lat, "_lon_", lon, ".nc"))
|
||||
daily_tmax.nc <- nc_open(paste0("ERA5_daily_t2m_max_", startYear,
|
||||
"-", endYear, "_lat_", lat, "_lon_", lon, ".nc"))
|
||||
|
||||
tmin <- ncvar_get(daily_tmin.nc, "Tmin")
|
||||
precip <- ncvar_get(daily_precip.nc, "prcp")
|
||||
tmax <- ncvar_get(daily_tmax.nc, "Tmax")
|
||||
|
||||
nc_close(daily_precip.nc)
|
||||
nc_close(daily_tmin.nc)
|
||||
nc_close(daily_tmax.nc)
|
||||
|
||||
lon <- read.csv2("Lon.csv", stringsAsFactors = FALSE, header = FALSE)
|
||||
lat <- read.csv2("Lat.csv", stringsAsFactors = FALSE, header = FALSE)
|
||||
gridCoords <- read.csv2("DB_GRID_TABLE.csv", stringsAsFactors = FALSE)
|
||||
gridSkeleton <- gridCoords[,c(1,3,4)]
|
||||
|
||||
precip <- listifyNCDF(ncFile = paste0("ERA5_daily_precip_sum_",startYear,"-",
|
||||
endYear,"_lat_",lat,"_lon_",lon,".nc"),
|
||||
dataLab = "prcp", # tp
|
||||
lon = lon,
|
||||
lat = lat,
|
||||
gridCoords = gridSkeleton)
|
||||
precip <- lapply(precip, function(x) x/10)
|
||||
|
||||
tmin <- listifyNCDF(ncFile = paste0("ERA5_daily_t2m_min_",startYear,"-",
|
||||
endYear,"_lat_",lat,"_lon_",lon,".nc"),
|
||||
dataLab = "Tmin",
|
||||
lon = lon,
|
||||
lat = lat,
|
||||
gridCoords = gridSkeleton)
|
||||
|
||||
tmax <- listifyNCDF(ncFile = paste0("ERA5_daily_t2m_max_",startYear,"-",
|
||||
endYear,"_lat_",lat,"_lon_",lon,".nc"),
|
||||
dataLab = "Tmax",
|
||||
lon = lon,
|
||||
lat = lat,
|
||||
gridCoords = gridSkeleton)
|
||||
numberOfSites <- length(tmax)
|
||||
tmp <- tmin
|
||||
|
||||
mtcMaker <- function(simulationName = "", executable, minYear, startYear, numYears,
|
||||
maxTemperatures, minTemperatures, precipitations, sites, destDir){
|
||||
# executable <- normalizePath(executable) # make absolute from relative path
|
||||
file.copy(executable,getwd())
|
||||
executable <- paste0("./",basename(executable))
|
||||
iniTemp <- c(paste0("Simulation is based on: ",simulationName),"","IOFILES",
|
||||
"1.mtcin",
|
||||
"1", "CONTROL", "0", ((endYear-startYear)+1)*365, #"365",
|
||||
"0", "0", "1", "PARAMETERS",
|
||||
"1000.0", "60.0", "45.0", "1000.0",
|
||||
"0.0", "0.0", "60.0", "0.0", "0.0",
|
||||
"-6.0", "-3.0", "END")
|
||||
endYear <- startYear + numYears - 1
|
||||
|
||||
mtDate <- function(startYear, numYears, endYear){
|
||||
## generate the first two column for mtcin
|
||||
year <- rep(startYear:endYear, each = 365)
|
||||
yearday <- rep(1:365,numYears)
|
||||
return(cbind(year,yearday))
|
||||
}
|
||||
|
||||
sliceData <- function(minYear, startYear, numYears, data){
|
||||
## get the data from the needed perion.
|
||||
baseDiff <- startYear-minYear
|
||||
startDate <- baseDiff*365+1
|
||||
endDate <- (baseDiff+numYears)*365
|
||||
return(data[startDate:endDate])
|
||||
}
|
||||
|
||||
nSites <- nrow(sites)
|
||||
for(i in 1:nSites) {
|
||||
print(i)
|
||||
iniTemp[4] <- sprintf("%d.mtcin",i)
|
||||
iniTemp[8] <- numYears*365
|
||||
iniTemp[5] <- file.path(destDir,i)
|
||||
iniTemp[13] <- iniTemp[16] <- sites[i,5]
|
||||
iniTemp[15] <- sites[i,3] #LAT is the first col.
|
||||
|
||||
write.table(iniTemp,paste(i, ".ini", sep=""),col.names=FALSE,row.names=FALSE,
|
||||
sep="\n",quote=FALSE)
|
||||
|
||||
itmax <- sliceData(minYear,startYear,numYears,maxTemperatures[[i]])
|
||||
itmin <- sliceData(minYear,startYear,numYears,minTemperatures[[i]])
|
||||
iprecip <- sliceData(minYear,startYear,numYears,precipitations[[i]])
|
||||
dateData <- mtDate(startYear,numYears,endYear)
|
||||
|
||||
write.table(cbind(dateData,itmax,itmin,iprecip),paste(i, ".mtcin", sep="")
|
||||
,row.names=FALSE,col.names=FALSE)
|
||||
|
||||
system2(executable, paste0(i, ".ini"), stdout=NULL)
|
||||
}
|
||||
}
|
||||
|
||||
executable <- if(Sys.info()["sysname"]=="Windows"){
|
||||
paste0(system.file("",package="MTClimMaker"),"/mtclim43.exe")
|
||||
} else {
|
||||
paste0(system.file("",package="MTClimMaker"),"/mtclim43")
|
||||
}
|
||||
|
||||
mtcMaker(simulationName = paste0("lat. ", gsub("_",".",latSub), ", lon. ", gsub("_",".",lonSub), ", elev. ",
|
||||
round(as.numeric(gridCoords[1,5]), digits=1), " m, ", "Note that VPD and srad are computed by MTClim."),
|
||||
executable = executable,
|
||||
# executable = paste0(system.file("",package="MTClimMaker"),"/mtclim43"),
|
||||
minYear = startYear,
|
||||
startYear = startYear,
|
||||
numYears = (endYear-startYear)+1,
|
||||
maxTemperatures = tmax,
|
||||
minTemperatures = tmin,
|
||||
precipitations = precip,
|
||||
sites = gridCoords,
|
||||
destDir = destDir)
|
||||
setwd(currDir)
|
||||
|
||||
print("-----------------------------------------------------------------")
|
||||
# print("6/6. MOVING .mtcin, .ini AND .wth FILES INTO THE CORRECT FOLDER.")
|
||||
print("6/6. RENAMING .mtcin, .ini AND .wth FILES...")
|
||||
|
||||
|
||||
### Move the ini, mtcin, mtc43 files into the correct folder.
|
||||
# Moving files to the correct folder:
|
||||
# dir.create(paste0("lat", latSub, "_lon", lonSub))
|
||||
# file.copy("1.ini", paste0("lat", latSub, "_lon", lonSub))
|
||||
# file.copy("1.mtcin", paste0("lat", latSub, "_lon", lonSub))
|
||||
# file.copy(paste0(destDir,"/1.mtc43"), paste0("lat", latSub, "_lon", lonSub))
|
||||
|
||||
# file.rename(paste0("lat", latSub, "_lon", lonSub, "/1.ini"),
|
||||
# paste0("lat", latSub, "_lon", lonSub, "/", grid,
|
||||
# "_lat", latSub, "_lon", lonSub, ".ini"))
|
||||
#
|
||||
# file.rename(paste0("lat", latSub, "_lon", lonSub, "/1.mtcin"),
|
||||
# paste0("lat", latSub, "_lon", lonSub, "/", grid,
|
||||
# "_lat", latSub, "_lon", lonSub, ".mtcin"))
|
||||
#
|
||||
# file.rename(paste0("lat", latSub, "_lon", lonSub, "/1.wth"),
|
||||
# paste0("lat", latSub, "_lon", lonSub, "/", grid,
|
||||
# "_lat", latSub, "_lon", lonSub, ".wth"))
|
||||
###
|
||||
|
||||
#file.rename("1.ini",
|
||||
# paste0(grid,
|
||||
# "_lat", latSub, "_lon", lonSub, ".ini")) # ID number (1,2,...) can be added to the title by using object grid befor "_lat"
|
||||
|
||||
#file.rename("1.mtcin",
|
||||
# paste0(grid,
|
||||
# "_lat", latSub, "_lon", lonSub, ".mtcin")) # ID number (1,2,...) can be added to the title by using object grid befor "_lat"
|
||||
|
||||
file.rename(paste0(fileDir, "/", destDir, "/1.mtc43"),
|
||||
paste0(fileDir, "/", destDir, "/",
|
||||
"_lat", latSub, "_lon", lonSub, ".wth")) # ID number (1,2,...) can be added to the title by using object grid befor "_lat"
|
||||
|
||||
file.copy(paste0(fileDir, "/", destDir, "/", "_lat", latSub, "_lon", lonSub, ".wth"), fileDir)
|
||||
# file.rename("1.ini", paste0(sprintf('%0.4d', gridID),".ini"))
|
||||
#
|
||||
# file.rename("1.mtcin", paste0(sprintf('%0.4d', gridID),".mtcin"))
|
||||
#
|
||||
# file.rename("1.wth", paste0(sprintf('%0.4d', gridID),".wth"))
|
||||
|
||||
print(paste0("MTCLIM FILES ARE CREATED FOR THE GRID POINT: LAT ",
|
||||
latList[grid], " & LON ", lonList[grid], "."))
|
||||
|
||||
print(paste0("SUMMARY: ",
|
||||
"elevation: ", round(as.numeric(gridCoords[1,5]), digits=1), " m, ",
|
||||
"yearly average temperature: ", round(as.numeric(gridCoords[1,8]), digits=1), " C"))
|
||||
|
||||
# Removing unnecessary files:
|
||||
file.remove("DB_GRID_TABLE.csv", "Lat.csv", "Lon.csv", "1.ini", "1.mtcin",
|
||||
"mtclim43.exe", list.files(pattern="ERA5_hourly*"), list.files(pattern="ERA5_daily*"))
|
||||
}
|
||||
|
||||
unlink(destDir, recursive=TRUE)
|
||||
}
|
||||
@ -68,7 +68,7 @@ setupMuso <- function(executable=NULL,
|
||||
#
|
||||
|
||||
inputParser <- function(string,fileName,counter,value=TRUE){
|
||||
unlist(strsplit(grep(string,fileName,value=TRUE),"[\ \t]"))[counter]
|
||||
unlist(strsplit(grep(string,fileName,value=TRUE, perl = TRUE),"[\ \t]", useBytes = TRUE))[counter]
|
||||
}
|
||||
|
||||
# outMaker <- function(inputVar,grepString,filep){
|
||||
@ -104,8 +104,8 @@ setupMuso <- function(executable=NULL,
|
||||
#iniChangedp <- FALSE
|
||||
|
||||
if(is.null(iniInput)){
|
||||
spinups<-grep("s.ini$",list.files(inputLoc),value=TRUE)
|
||||
normals<-grep("n.ini$",list.files(inputLoc),value=TRUE)
|
||||
spinups<-grep("s.ini$",list.files(inputLoc),value=TRUE, perl = TRUE)
|
||||
normals<-grep("n.ini$",list.files(inputLoc),value=TRUE, perl = TRUE)
|
||||
|
||||
if(length(spinups)==1){
|
||||
iniInput[1] <- file.path(inputLoc,spinups)
|
||||
@ -124,8 +124,8 @@ setupMuso <- function(executable=NULL,
|
||||
##read the ini files for the further changes
|
||||
|
||||
iniFiles<-lapply(iniInput, function (x) readLines(x,-1))
|
||||
iniFiles[[1]] <- gsub("\\","/", iniFiles[[1]],fixed=TRUE) #replacing \ to /
|
||||
iniFiles[[2]] <- gsub("\\","/", iniFiles[[2]],fixed=TRUE) #replacing \ to /
|
||||
iniFiles[[1]] <- gsub("\\\\","/", iniFiles[[1]], perl = TRUE) #replacing \ to /
|
||||
iniFiles[[2]] <- gsub("\\\\","/", iniFiles[[2]], perl = TRUE) #replacing \ to /
|
||||
names(iniFiles) <- c("spinup","normal")
|
||||
|
||||
|
||||
@ -156,21 +156,21 @@ setupMuso <- function(executable=NULL,
|
||||
|
||||
# if(is.null(mapData)){
|
||||
#
|
||||
outIndex<-grep("DAILY_OUTPUT",iniFiles[[2]])+1
|
||||
numVar<-as.numeric(unlist(strsplit(iniFiles[[2]][outIndex],"[\ \t]"))[1])
|
||||
outIndex<-grep("DAILY_OUTPUT",iniFiles[[2]], perl = TRUE)+1
|
||||
numVar<-as.numeric(unlist(strsplit(iniFiles[[2]][outIndex],"[\ \t]", useBytes = TRUE))[1])
|
||||
dailyVarCodes<-tryCatch(iniFiles[[2]][(outIndex+1):(outIndex+numVar)],
|
||||
error = function(e){
|
||||
stop("Cannot read indexes of output variables from the normal ini file, please make sure you have not skiped a line after the flag: \"DAILY_OUTPUT\"")
|
||||
})
|
||||
|
||||
dailyVarCodes<-unlist(lapply(dailyVarCodes, function(x) unlist(strsplit(x,"[\ \t]"))[1]))
|
||||
dailyVarnames<-unlist(lapply(dailyVarCodes, function(x) musoMapping(unlist(strsplit(x,"[\ \t]"))[1])))
|
||||
dailyVarCodes<-unlist(lapply(dailyVarCodes, function(x) unlist(strsplit(x,"[\ \t]", useBytes = TRUE))[1]))
|
||||
dailyVarnames<-unlist(lapply(dailyVarCodes, function(x) musoMapping(unlist(strsplit(x,"[\ \t]", useBytes = TRUE))[1])))
|
||||
|
||||
outIndex<-grep("ANNUAL_OUTPUT",iniFiles[[2]])+1
|
||||
numVar<-as.numeric(unlist(strsplit(iniFiles[[2]][outIndex],"[\ \t]"))[1])
|
||||
outIndex<-grep("ANNUAL_OUTPUT",iniFiles[[2]], perl = TRUE)+1
|
||||
numVar<-as.numeric(unlist(strsplit(iniFiles[[2]][outIndex],"[\ \t]", useBytes = TRUE))[1])
|
||||
annualVarCodes<-iniFiles[[2]][(outIndex+1):(outIndex+numVar)]
|
||||
annualVarCodes<-unlist(lapply(annualVarCodes, function(x) unlist(strsplit(x,"[\ \t]"))[1]))
|
||||
annualVarnames<-unlist(lapply(annualVarCodes, function(x) musoMapping(unlist(strsplit(x,"[\ \t]"))[1])))
|
||||
annualVarCodes<-unlist(lapply(annualVarCodes, function(x) unlist(strsplit(x,"[\ \t]", useBytes = TRUE))[1]))
|
||||
annualVarnames<-unlist(lapply(annualVarCodes, function(x) musoMapping(unlist(strsplit(x,"[\ \t]", useBytes = TRUE))[1])))
|
||||
outputVars<-list(dailyVarnames,annualVarnames)
|
||||
# browser()
|
||||
# } else {
|
||||
@ -206,8 +206,8 @@ setupMuso <- function(executable=NULL,
|
||||
}
|
||||
|
||||
outputName <- character(2)
|
||||
outputName[1] <- basename(unlist(strsplit(iniFiles[[1]][grep("OUTPUT_CONTROL",iniFiles[[1]])+1],"[\ \t]"))[1])
|
||||
outputName[2] <- basename(unlist(strsplit(iniFiles[[2]][grep("OUTPUT_CONTROL",iniFiles[[2]])+1],"[\ \t]"))[1])
|
||||
outputName[1] <- basename(unlist(strsplit(iniFiles[[1]][grep("OUTPUT_CONTROL",iniFiles[[1]], perl = TRUE)+1],"[\ \t]", useBytes = TRUE))[1])
|
||||
outputName[2] <- basename(unlist(strsplit(iniFiles[[2]][grep("OUTPUT_CONTROL",iniFiles[[2]], perl = TRUE)+1],"[\ \t]", useBytes = TRUE))[1])
|
||||
## outputName <- unlist(strsplit(grep("output",grep("prefix",iniFiles[[2]],value=TRUE),value=TRUE),"[\ \t]"))[1]
|
||||
##THIS IS AN UGLY SOLUTION, WHICH NEEDS AN UPGRADE!!! FiXED (2017.09.11)
|
||||
## outputName <- unlist(strsplit(grep("prefix for output files",iniFiles[[2]],value=TRUE),"[\ \t]"))[1]
|
||||
@ -220,7 +220,7 @@ setupMuso <- function(executable=NULL,
|
||||
|
||||
if(is.null(outputLoc)){
|
||||
## outputLoc<-paste((rev(rev(unlist(strsplit(outputName,"/")))[-1])),collapse="/")
|
||||
outputLoc <- dirname(unlist(strsplit(iniFiles[[2]][grep("OUTPUT_CONTROL",iniFiles[[2]])+1],"[\ \t]"))[1])
|
||||
outputLoc <- dirname(unlist(strsplit(iniFiles[[2]][grep("OUTPUT_CONTROL",iniFiles[[2]], perl = TRUE)+1],"[\ \t]", useBytes = TRUE))[1])
|
||||
if(substr(outputLoc,start = 1,stop = 1)!="/"){
|
||||
##if the outputName is not absolute path make it absolute
|
||||
outputLoc <- file.path(inputLoc,outputLoc)
|
||||
@ -233,12 +233,12 @@ setupMuso <- function(executable=NULL,
|
||||
|
||||
inputFiles<-c(iniInput,epcInput,metInput)
|
||||
numData<-rep(NA,3)
|
||||
numYears <- as.numeric(unlist(strsplit(iniFiles[[2]][grep("TIME_DEFINE",iniFiles[[2]])+1],"[\ \t]"))[1])
|
||||
numYears <- as.numeric(unlist(strsplit(iniFiles[[2]][grep("TIME_DEFINE",iniFiles[[2]], perl = TRUE)+1],"[\ \t]", useBytes = TRUE))[1])
|
||||
## numYears<-unlist(read.table(iniInput[2],skip = 14,nrows = 1)[1])
|
||||
numValues <- as.numeric(unlist(strsplit(iniFiles[[2]][grep("DAILY_OUTPUT",iniFiles[[2]])+1],"[\ \t]"))[1])
|
||||
numValues <- as.numeric(unlist(strsplit(iniFiles[[2]][grep("DAILY_OUTPUT",iniFiles[[2]], perl = TRUE)+1],"[\ \t]", useBytes = TRUE))[1])
|
||||
## numValues will be replaced to numVar
|
||||
## numValues<-unlist(read.table(iniInput[2],skip=102,nrows = 1)[1])
|
||||
startYear <- as.numeric(unlist(strsplit(iniFiles[[2]][grep("TIME_DEFINE",iniFiles[[2]])+2],"[\ \t]"))[1])
|
||||
startYear <- as.numeric(unlist(strsplit(iniFiles[[2]][grep("TIME_DEFINE",iniFiles[[2]], perl = TRUE)+2],"[\ \t]", useBytes = TRUE))[1])
|
||||
numData[1] <- numValues * numYears * 365 # Have to corrigate leapyears
|
||||
|
||||
numData[2] <- numYears * numValues*12
|
||||
@ -263,9 +263,9 @@ setupMuso <- function(executable=NULL,
|
||||
searchBellow <- function(inFile, key, stringP = TRUE, n=1, management = FALSE){
|
||||
|
||||
if(stringP){
|
||||
unlist(strsplit(inFile[grep(key,inFile,perl=TRUE)+n],split = "\\s+"))[1]
|
||||
unlist(strsplit(inFile[grep(key,inFile, perl=TRUE)+n],split = "\\s+", useBytes = TRUE))[1]
|
||||
} else {
|
||||
as.numeric(unlist(strsplit(inFile[grep(key,inFile,perl=TRUE)+n],split = "\\s+"))[1])
|
||||
as.numeric(unlist(strsplit(inFile[grep(key,inFile,perl=TRUE)+n],split = "\\s+", useBytes = TRUE))[1])
|
||||
}
|
||||
}
|
||||
soilFile <- NULL
|
||||
|
||||
42
RBBGCMuso/man/calibrateMuso.Rd
Normal file
42
RBBGCMuso/man/calibrateMuso.Rd
Normal file
@ -0,0 +1,42 @@
|
||||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/calibrateMuso.R
|
||||
\name{calibrateMuso}
|
||||
\alias{calibrateMuso}
|
||||
\title{calibrateMuso}
|
||||
\usage{
|
||||
calibrateMuso(
|
||||
measuredData,
|
||||
parameters = NULL,
|
||||
startDate = NULL,
|
||||
endDate = NULL,
|
||||
formatString = "\%Y-\%m-\%d",
|
||||
dataVar,
|
||||
outLoc = "./calib",
|
||||
preTag = "cal-",
|
||||
settings = setupMuso(),
|
||||
outVars = NULL,
|
||||
iterations = 100,
|
||||
skipSpinup = TRUE,
|
||||
plotName = "calib.jpg",
|
||||
modifyOriginal = TRUE,
|
||||
likelihood,
|
||||
uncertainity = NULL,
|
||||
naVal = NULL,
|
||||
postProcString = NULL,
|
||||
thread_prefix = "thread",
|
||||
numCores = (parallel::detectCores() - 1),
|
||||
pb = txtProgressBar(min = 0, max = iterations, style = 3),
|
||||
maxLikelihoodEpc = TRUE,
|
||||
pbUpdate = setTxtProgressBar,
|
||||
method = "GLUE",
|
||||
lg = FALSE,
|
||||
w = NULL,
|
||||
...
|
||||
)
|
||||
}
|
||||
\description{
|
||||
This funtion uses the Monte Carlo technique to uniformly sample the parameter space from user defined parameters of the Biome-BGCMuSo model. The sampling algorithm ensures that the parameters are constrained by the model logic which means that parameter dependencies are fully taken into account (parameter dependency means that e.g leaf C:N ratio must be smaller than C:N ratio of litter; more complicated rules apply to the allocation parameters where the allocation fractions to different plant compartments must sum up 1). This function implements a mathematically correct solution to provide uniform distriution for all selected parameters.
|
||||
}
|
||||
\author{
|
||||
Roland HOLLOS
|
||||
}
|
||||
@ -1,16 +0,0 @@
|
||||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/RcppExports.R
|
||||
\name{changeMusoC}
|
||||
\alias{changeMusoC}
|
||||
\title{changeMusoC}
|
||||
\usage{
|
||||
changeMusoC(inFile, outFile, inMat)
|
||||
}
|
||||
\arguments{
|
||||
\item{inFile}{is the big matrix}
|
||||
|
||||
\item{outFile}{is the small matrix}
|
||||
}
|
||||
\description{
|
||||
This function is fastly randomize values based on min and max values
|
||||
}
|
||||
@ -2,16 +2,9 @@
|
||||
% Please edit documentation in R/changeMuso.R
|
||||
\name{changemulline}
|
||||
\alias{changemulline}
|
||||
\title{This is the function which is capable to change multiple specific lines to others using their row numbers.}
|
||||
\title{changemulline}
|
||||
\usage{
|
||||
changemulline(
|
||||
filePaths,
|
||||
calibrationPar,
|
||||
contents,
|
||||
fileOut,
|
||||
fileToChange,
|
||||
modifyOriginal = FALSE
|
||||
)
|
||||
changemulline(filePaths, calibrationPar, contents, src, outFiles = filePaths)
|
||||
}
|
||||
\description{
|
||||
The function uses the previous changspecline function to operate.
|
||||
@ -19,4 +12,3 @@ The function uses the previous changspecline function to operate.
|
||||
\author{
|
||||
Roland Hollos
|
||||
}
|
||||
\keyword{internal}
|
||||
|
||||
@ -1,52 +0,0 @@
|
||||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/getMeteoData1.R
|
||||
\name{getMeteoData1BGC}
|
||||
\alias{getMeteoData1BGC}
|
||||
\title{getMeteoData1BGC}
|
||||
\usage{
|
||||
getMeteoData1BGC(
|
||||
startYear = 2017,
|
||||
endYear = 2017,
|
||||
lon = 18.8,
|
||||
lat = 47.3,
|
||||
timeOut = 7200,
|
||||
monthList = sprintf("\%02d", 1:12),
|
||||
dayList = sprintf("\%02d", 1:31),
|
||||
hourList = sprintf("\%02d:00", 0:23),
|
||||
destDir = NULL,
|
||||
apiFile = NULL,
|
||||
fileDir = NULL
|
||||
)
|
||||
}
|
||||
\arguments{
|
||||
\item{startYear}{Start year of the downloading data. It shall be greater than 1978.}
|
||||
|
||||
\item{endYear}{End year of the downloading data. It shall be smaller than 2020.}
|
||||
|
||||
\item{lon}{Geographical longitude of the selected grid point (negative values: W, positive values: E). It shall be between -180 and 180. The value is rounded to two decimal places.}
|
||||
|
||||
\item{lat}{Geographical latitude of the selected grid point (negative values: S, positive values: N). It shall be between -90 and 90. The value is rounded to two decimal places.}
|
||||
|
||||
\item{timeOut}{Time in seconds to wait to download from Copernicus.}
|
||||
|
||||
\item{monthList}{Month selector (e.g. to download data for April then write "01", to download data for September and October then write c("04","05")}
|
||||
|
||||
\item{dayList}{Day selector (e.g. to download data for the 1st day of the month(s) then write "01", to download data for the 2nd and 4th day of the month then write c("02","04")}
|
||||
|
||||
\item{hourList}{Hour selector (e.g. to download data for 00 UTC then write "00:00", to download data for 01 UTC and 15 UTC then write c("01","15")}
|
||||
|
||||
\item{destDir}{Directory where the wth file will be created. If it is NULL then destDir is the same as fileDir.}
|
||||
|
||||
\item{apiFile}{Directory where the cdsapirc file is located}
|
||||
|
||||
\item{fileDir}{Directory where the .ini and .mtcin files will be created}
|
||||
}
|
||||
\description{
|
||||
This function downloads hourly 2m air temperature and total precipitation values in NetCDF file format
|
||||
at one grid point to create MTClim files which contain daily data.
|
||||
Please note that, to download ERA5, you need Copernicus registration and API key.
|
||||
According to default settings, data will be downloaded in the gridpoint of Martonvasar (Hungary), in 2017.
|
||||
}
|
||||
\author{
|
||||
Erzsebet Kristof, Roland Hollos
|
||||
}
|
||||
@ -1,15 +0,0 @@
|
||||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/RcppExports.R
|
||||
\name{mtclim}
|
||||
\alias{mtclim}
|
||||
\title{mtclim}
|
||||
\usage{
|
||||
mtclim(iniFile)
|
||||
}
|
||||
\arguments{
|
||||
\item{iniFile}{is the name of the inifile}
|
||||
}
|
||||
\description{
|
||||
This is the core mtclim function
|
||||
}
|
||||
\keyword{internal}
|
||||
@ -4,7 +4,14 @@
|
||||
\alias{musoGlue}
|
||||
\title{musoGlue}
|
||||
\usage{
|
||||
musoGlue(preservedCalib, w)
|
||||
musoGlue(
|
||||
presCalFile,
|
||||
w,
|
||||
delta = 0.17,
|
||||
settings = setupMuso(),
|
||||
parameters = read.csv("parameters.csv", stringsAsFactors = FALSE),
|
||||
lg = FALSE
|
||||
)
|
||||
}
|
||||
\arguments{
|
||||
\item{plotName}{u}
|
||||
|
||||
@ -1,17 +0,0 @@
|
||||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/RcppExports.R
|
||||
\name{musoRandomizer}
|
||||
\alias{musoRandomizer}
|
||||
\title{musoRandomizer}
|
||||
\usage{
|
||||
musoRandomizer(A, B)
|
||||
}
|
||||
\arguments{
|
||||
\item{A}{is the big matrix}
|
||||
|
||||
\item{B}{is the small matrix}
|
||||
}
|
||||
\description{
|
||||
This function is fastly randomize values based on min and max values,
|
||||
and row indexes.
|
||||
}
|
||||
@ -20,9 +20,12 @@ optiMuso(
|
||||
plotName = "calib.jpg",
|
||||
modifyOriginal = TRUE,
|
||||
likelihood,
|
||||
uncertainity = NULL,
|
||||
naVal = NULL,
|
||||
postProcString = NULL,
|
||||
w = NULL
|
||||
w = NULL,
|
||||
lg = FALSE,
|
||||
parallel = TRUE
|
||||
)
|
||||
}
|
||||
\arguments{
|
||||
|
||||
@ -1,89 +0,0 @@
|
||||
// Generated by using Rcpp::compileAttributes() -> do not edit by hand
|
||||
// Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
|
||||
|
||||
#include <Rcpp.h>
|
||||
|
||||
using namespace Rcpp;
|
||||
|
||||
// mtclim
|
||||
void mtclim(std::string iniFile);
|
||||
RcppExport SEXP _RBBGCMuso_mtclim(SEXP iniFileSEXP) {
|
||||
BEGIN_RCPP
|
||||
Rcpp::RNGScope rcpp_rngScope_gen;
|
||||
Rcpp::traits::input_parameter< std::string >::type iniFile(iniFileSEXP);
|
||||
mtclim(iniFile);
|
||||
return R_NilValue;
|
||||
END_RCPP
|
||||
}
|
||||
// getWritePositions
|
||||
IntegerVector getWritePositions(double a);
|
||||
RcppExport SEXP _RBBGCMuso_getWritePositions(SEXP aSEXP) {
|
||||
BEGIN_RCPP
|
||||
Rcpp::RObject rcpp_result_gen;
|
||||
Rcpp::RNGScope rcpp_rngScope_gen;
|
||||
Rcpp::traits::input_parameter< double >::type a(aSEXP);
|
||||
rcpp_result_gen = Rcpp::wrap(getWritePositions(a));
|
||||
return rcpp_result_gen;
|
||||
END_RCPP
|
||||
}
|
||||
// changeMusoC
|
||||
void changeMusoC(std::string inFile, std::string outFile, NumericMatrix inMat);
|
||||
RcppExport SEXP _RBBGCMuso_changeMusoC(SEXP inFileSEXP, SEXP outFileSEXP, SEXP inMatSEXP) {
|
||||
BEGIN_RCPP
|
||||
Rcpp::RNGScope rcpp_rngScope_gen;
|
||||
Rcpp::traits::input_parameter< std::string >::type inFile(inFileSEXP);
|
||||
Rcpp::traits::input_parameter< std::string >::type outFile(outFileSEXP);
|
||||
Rcpp::traits::input_parameter< NumericMatrix >::type inMat(inMatSEXP);
|
||||
changeMusoC(inFile, outFile, inMat);
|
||||
return R_NilValue;
|
||||
END_RCPP
|
||||
}
|
||||
// randTypeOne
|
||||
NumericMatrix randTypeOne(NumericMatrix m);
|
||||
RcppExport SEXP _RBBGCMuso_randTypeOne(SEXP mSEXP) {
|
||||
BEGIN_RCPP
|
||||
Rcpp::RObject rcpp_result_gen;
|
||||
Rcpp::RNGScope rcpp_rngScope_gen;
|
||||
Rcpp::traits::input_parameter< NumericMatrix >::type m(mSEXP);
|
||||
rcpp_result_gen = Rcpp::wrap(randTypeOne(m));
|
||||
return rcpp_result_gen;
|
||||
END_RCPP
|
||||
}
|
||||
// randTypeTwo
|
||||
NumericMatrix randTypeTwo(NumericMatrix m);
|
||||
RcppExport SEXP _RBBGCMuso_randTypeTwo(SEXP mSEXP) {
|
||||
BEGIN_RCPP
|
||||
Rcpp::RObject rcpp_result_gen;
|
||||
Rcpp::RNGScope rcpp_rngScope_gen;
|
||||
Rcpp::traits::input_parameter< NumericMatrix >::type m(mSEXP);
|
||||
rcpp_result_gen = Rcpp::wrap(randTypeTwo(m));
|
||||
return rcpp_result_gen;
|
||||
END_RCPP
|
||||
}
|
||||
// musoRandomizer
|
||||
NumericMatrix musoRandomizer(NumericMatrix A, NumericMatrix B);
|
||||
RcppExport SEXP _RBBGCMuso_musoRandomizer(SEXP ASEXP, SEXP BSEXP) {
|
||||
BEGIN_RCPP
|
||||
Rcpp::RObject rcpp_result_gen;
|
||||
Rcpp::RNGScope rcpp_rngScope_gen;
|
||||
Rcpp::traits::input_parameter< NumericMatrix >::type A(ASEXP);
|
||||
Rcpp::traits::input_parameter< NumericMatrix >::type B(BSEXP);
|
||||
rcpp_result_gen = Rcpp::wrap(musoRandomizer(A, B));
|
||||
return rcpp_result_gen;
|
||||
END_RCPP
|
||||
}
|
||||
|
||||
static const R_CallMethodDef CallEntries[] = {
|
||||
{"_RBBGCMuso_mtclim", (DL_FUNC) &_RBBGCMuso_mtclim, 1},
|
||||
{"_RBBGCMuso_getWritePositions", (DL_FUNC) &_RBBGCMuso_getWritePositions, 1},
|
||||
{"_RBBGCMuso_changeMusoC", (DL_FUNC) &_RBBGCMuso_changeMusoC, 3},
|
||||
{"_RBBGCMuso_randTypeOne", (DL_FUNC) &_RBBGCMuso_randTypeOne, 1},
|
||||
{"_RBBGCMuso_randTypeTwo", (DL_FUNC) &_RBBGCMuso_randTypeTwo, 1},
|
||||
{"_RBBGCMuso_musoRandomizer", (DL_FUNC) &_RBBGCMuso_musoRandomizer, 2},
|
||||
{NULL, NULL, 0}
|
||||
};
|
||||
|
||||
RcppExport void R_init_RBBGCMuso(DllInfo *dll) {
|
||||
R_registerRoutines(dll, NULL, CallEntries, NULL, NULL);
|
||||
R_useDynamicSymbols(dll, FALSE);
|
||||
}
|
||||
@ -1,156 +0,0 @@
|
||||
/*
|
||||
ini.h
|
||||
Peter Thornton, NTSG
|
||||
8/6/93
|
||||
|
||||
Header file for functions that read *.ini files and either
|
||||
store values in variables or open files for input or output
|
||||
General *.ini file format:
|
||||
value/string (whitespace) comment, not required (\n)
|
||||
*/
|
||||
|
||||
|
||||
|
||||
/* structure definition for filename handling */
|
||||
typedef struct {
|
||||
char name[128];
|
||||
FILE *ptr;
|
||||
} file;
|
||||
|
||||
/* function prototypes */
|
||||
int file_open (file *target, char mode);
|
||||
int scan_value (file ini, void *var, char mode);
|
||||
int scan_open (file ini,file *target,char mode);
|
||||
|
||||
|
||||
/* file_open is the generic file opening routine using the file structure
|
||||
defined above */
|
||||
int file_open (file *target, char mode)
|
||||
/* Possible values for mode
|
||||
'r' for read binary
|
||||
'i' for read ascii
|
||||
'w' for write binary
|
||||
'o' for write ascii
|
||||
*/
|
||||
{
|
||||
int ok=1;
|
||||
|
||||
switch (mode)
|
||||
{
|
||||
case 'r':
|
||||
if ((target->ptr = fopen(target->name,"rb")) == NULL)
|
||||
{
|
||||
printf("Can't open %s for binary read ... Exiting\n",target->name);
|
||||
ok=0;
|
||||
}
|
||||
break;
|
||||
|
||||
case 'i':
|
||||
if ((target->ptr = fopen(target->name,"r")) == NULL)
|
||||
{
|
||||
printf("Can't open %s for ascii read ... Exiting\n",target->name);
|
||||
ok=0;
|
||||
}
|
||||
break;
|
||||
|
||||
case 'w':
|
||||
if ((target->ptr = fopen(target->name,"wb")) == NULL)
|
||||
{
|
||||
printf("Can't open %s for binary write ... Exiting\n",target->name);
|
||||
ok=0;
|
||||
}
|
||||
break;
|
||||
|
||||
case 'o':
|
||||
if ((target->ptr = fopen(target->name,"w")) == NULL)
|
||||
{
|
||||
printf("Can't open %s for ascii write ... Exiting\n",target->name);
|
||||
ok=0;
|
||||
}
|
||||
break;
|
||||
|
||||
default:
|
||||
printf("Invalid mode specification for file_open ... Exiting\n");
|
||||
ok=0;
|
||||
}
|
||||
return(!ok);
|
||||
}
|
||||
|
||||
|
||||
/* scan_value is the generic ascii input function for use with text
|
||||
initialization files. Reads the first whitespace delimited word on a line,
|
||||
and discards the remainder of the line. Returns a value depending on the
|
||||
specified scan type */
|
||||
int scan_value (file ini, void *var, char type)
|
||||
/* Possible values for type
|
||||
'i' for integer
|
||||
'd' for double
|
||||
's' for string
|
||||
*/
|
||||
|
||||
{
|
||||
int ok_scan;
|
||||
int ok=1;
|
||||
|
||||
switch (type)
|
||||
{
|
||||
case 'i':
|
||||
ok_scan = fscanf(ini.ptr, "%d%*[^\n]",(int*)var);
|
||||
if (ok_scan == 0 || ok_scan == EOF)
|
||||
{
|
||||
printf("Error reading int value from %s ... exiting\n",ini.name);
|
||||
ok=0;
|
||||
}
|
||||
break;
|
||||
|
||||
case 'd':
|
||||
ok_scan = fscanf(ini.ptr, "%lf%*[^\n]",(double*)var);
|
||||
if (ok_scan == 0 || ok_scan == EOF)
|
||||
{
|
||||
printf("Error reading double value from %s... exiting\n",ini.name);
|
||||
ok=0;
|
||||
}
|
||||
break;
|
||||
|
||||
case 's':
|
||||
ok_scan = fscanf(ini.ptr, "%s%*[^\n]",(char*)var);
|
||||
if (ok_scan == 0 || ok_scan == EOF)
|
||||
{
|
||||
printf("Error reading string value from %s... exiting\n",ini.name);
|
||||
ok=0;
|
||||
}
|
||||
break;
|
||||
|
||||
default:
|
||||
printf("Invalid type specifier for scan_value ... Exiting\n");
|
||||
ok=0;
|
||||
}
|
||||
return(!ok);
|
||||
}
|
||||
|
||||
/* combines scan_value with file_open for reading a filename from an
|
||||
initialization file and then opening it with a specified access mode */
|
||||
int scan_open (file ini,file *target,char mode)
|
||||
/* Possible values for mode
|
||||
'r' for read binary
|
||||
'i' for read ascii
|
||||
'w' for write binary
|
||||
'o' for write ascii
|
||||
*/
|
||||
{
|
||||
int ok=1;
|
||||
|
||||
if (scan_value(ini,target->name,'s'))
|
||||
{
|
||||
printf("Error reading filename from %s... Exiting\n",ini.name);
|
||||
ok=0;
|
||||
}
|
||||
if (ok)
|
||||
{
|
||||
if (file_open(target,mode))
|
||||
{
|
||||
ok=0;
|
||||
}
|
||||
}
|
||||
return(!ok);
|
||||
}
|
||||
@ -1,28 +0,0 @@
|
||||
#include <Rcpp.h>
|
||||
#include <numeric>
|
||||
#include <iostream>
|
||||
#include <algorithm>
|
||||
#include <numeric>
|
||||
#include <ctime>
|
||||
|
||||
|
||||
using namespace Rcpp;
|
||||
using namespace std;
|
||||
extern "C" {
|
||||
void mtc(char*);
|
||||
};
|
||||
|
||||
//' mtclim
|
||||
//'
|
||||
//' This is the core mtclim function
|
||||
//' @importFrom Rcpp evalCpp
|
||||
//' @useDynLib RBBGCMuso
|
||||
//' @param iniFile is the name of the inifile
|
||||
//' @keywords internal
|
||||
//' @export
|
||||
// [[Rcpp::export]]
|
||||
void mtclim(std::string iniFile){
|
||||
char *y = new char[iniFile.length() + 1]; // Allocate memory for char array input
|
||||
std::strcpy(y, iniFile.c_str()); // Copy c++ string to that input.
|
||||
mtc(y);
|
||||
}
|
||||
File diff suppressed because it is too large
Load Diff
@ -1,29 +0,0 @@
|
||||
/*
|
||||
mtclim43_constants.h
|
||||
physical constants for MTCLIM 4.3
|
||||
|
||||
Peter Thornton
|
||||
NTSG, School of Forestry
|
||||
University of Montana
|
||||
1/20/2000
|
||||
|
||||
(dim) stands for dimensionless values
|
||||
*/
|
||||
|
||||
#define SECPERRAD 13750.9871 /* seconds per radian of hour angle */
|
||||
#define RADPERDAY 0.017214 /* radians of Earth orbit per julian day */
|
||||
#define RADPERDEG 0.01745329 /* radians per degree */
|
||||
#define MINDECL -0.4092797 /* minimum declination (radians) */
|
||||
#define DAYSOFF 11.25 /* julian day offset of winter solstice */
|
||||
#define SRADDT 600.0 /* timestep for radiation routine (seconds) */
|
||||
|
||||
#define MA 28.9644e-3 /* (kg mol-1) molecular weight of air */
|
||||
#define MW 18.0148e-3 /* (kg mol-1) molecular weight of water */
|
||||
#define R 8.3143 /* (m3 Pa mol-1 K-1) gas law constant */
|
||||
#define G_STD 9.80665 /* (m s-2) standard gravitational accel. */
|
||||
#define P_STD 101325.0 /* (Pa) standard pressure at 0.0 m elevation */
|
||||
#define T_STD 288.15 /* (K) standard temp at 0.0 m elevation */
|
||||
#define CP 1010.0 /* (J kg-1 K-1) specific heat of air */
|
||||
#define LR_STD 0.0065 /* (-K m-1) standard temperature lapse rate */
|
||||
#define EPS 0.62196351 /* (MW/MA) unitless ratio of molec weights */
|
||||
#define PI 3.14159265 /* pi */
|
||||
@ -1,35 +0,0 @@
|
||||
/*
|
||||
mtclim43_parameters.h
|
||||
model parameters for MTCLIM 4.3
|
||||
|
||||
Some model parameters are set in the *.ini file. Others are set here.
|
||||
|
||||
Peter Thornton
|
||||
NTSG, School of Forestry
|
||||
University of Montana
|
||||
1/20/2000
|
||||
|
||||
(dim) stands for dimensionless values
|
||||
*/
|
||||
|
||||
/* parameters for the Tair algorithm */
|
||||
#define TDAYCOEF 0.45 /* (dim) daylight air temperature coefficient (dim) */
|
||||
|
||||
/* parameters for the snowpack algorithm */
|
||||
#define SNOW_TCRIT -6.0 /* (deg C) critical temperature for snowmelt */
|
||||
#define SNOW_TRATE 0.042 /* (cm/degC/day) snowmelt rate */
|
||||
|
||||
/* parameters for the radiation algorithm */
|
||||
#define TBASE 0.870 /* (dim) max inst. trans., 0m, nadir, dry atm */
|
||||
#define ABASE -6.1e-5 /* (1/Pa) vapor pressure effect on transmittance */
|
||||
#define C 1.5 /* (dim) radiation parameter */
|
||||
#define B0 0.013 /* (dim) radiation parameter */
|
||||
#define B1 0.201 /* (dim) radiation parameter */
|
||||
#define B2 0.185 /* (dim) radiation parameter */
|
||||
#define RAIN_SCALAR 0.75 /* (dim) correction to trans. for rain day */
|
||||
#define DIF_ALB 0.6 /* (dim) diffuse albedo for horizon correction */
|
||||
#define SC_INT 1.32 /* (MJ/m2/day) snow correction intercept */
|
||||
#define SC_SLOPE 0.096 /* (MJ/m2/day/cm) snow correction slope */
|
||||
|
||||
/* output file extension */
|
||||
#define POSTFIX ".mtc43" /* extension added to output filename prefix */
|
||||
@ -1,138 +0,0 @@
|
||||
#include <Rcpp.h>
|
||||
#include <numeric>
|
||||
#include <iostream>
|
||||
#include <fstream>
|
||||
#include <string>
|
||||
#include <new>
|
||||
#include <algorithm>
|
||||
#include <numeric>
|
||||
#include <ctime>
|
||||
#include <math.h>
|
||||
|
||||
|
||||
using namespace Rcpp;
|
||||
using namespace std;
|
||||
// [[Rcpp::plugins(cpp11)]]
|
||||
|
||||
// [[Rcpp::export]]
|
||||
IntegerVector getWritePositions(double a){
|
||||
//getWritePositions returns abstract rownumbers to rownumbers and other indexek
|
||||
// getWritePositions(173.62) = c(173,7,3) // it supports up to 10 subvalues
|
||||
IntegerVector outVec(3); // outVec is vector of rowIndex, colNumber, choosen Index
|
||||
a = a * 100;
|
||||
a = round(a); //without this line 155.92 ~= 155.9199999999, (int) 155.9199999999*100 = 15591
|
||||
outVec[0] = (int)a / 100;
|
||||
outVec[1] = ((int)a /10) % 10 + 1;
|
||||
outVec[2] = (int)a % 10;
|
||||
|
||||
|
||||
return outVec;
|
||||
}
|
||||
|
||||
IntegerMatrix getPositions(NumericVector v){
|
||||
|
||||
int numVari = v.size();
|
||||
IntegerMatrix indexek(numVari,3);
|
||||
IntegerVector positions(3);
|
||||
for(int i = 0; i < numVari; ++i){
|
||||
positions = getWritePositions(v[i]);
|
||||
indexek(i,_) = positions;
|
||||
}
|
||||
return indexek;
|
||||
}
|
||||
|
||||
|
||||
void goNextLine(std::ifstream& fin){
|
||||
char c='a';
|
||||
while((c!='\n')&&(fin.get(c))){}
|
||||
}
|
||||
|
||||
#define NEXT goNextLine(fin)
|
||||
int fileChanger(std::string inFile, std::string outFile, IntegerVector linum, NumericVector num, IntegerVector colnum, IntegerVector colindex){
|
||||
std::ifstream fin(inFile);
|
||||
if (!fin.is_open()) {
|
||||
stop("Cannot open " + inFile + " for read");
|
||||
}
|
||||
std::ofstream fot(outFile);
|
||||
|
||||
if (!fot.is_open()) {
|
||||
stop("Cannot open " + outFile + " for read");
|
||||
}
|
||||
string tempString;
|
||||
|
||||
int counter = 1;
|
||||
int counterV = 0;
|
||||
while (!fin.eof()) {
|
||||
|
||||
|
||||
if(counter == linum[counterV]){
|
||||
if(colnum[counterV]==1){
|
||||
fot << num[counterV] << "\n";
|
||||
NEXT;
|
||||
} else {
|
||||
double * elements;
|
||||
elements = new double [colnum[counterV]];
|
||||
if(linum[counterV]!=linum[counterV+1]){
|
||||
for(int i=0;i<colnum[counterV];++i){
|
||||
|
||||
fin >> elements[i];
|
||||
|
||||
if(i==colindex[counterV]){
|
||||
elements[i]=num[counterV];
|
||||
}
|
||||
// std::cout << colnum[counterV] << " " << colindex[counterV] << " " << elements[i] << " "<< i <<"\n";
|
||||
// std::cout << colindex[counterV] << getWritePositions(155.92) <<"\n";
|
||||
// std::cout << "======================== \n";
|
||||
fot << elements[i] << '\t';
|
||||
}
|
||||
} else {
|
||||
int k=0;
|
||||
for(int i=0;i<colnum[counterV];++i){
|
||||
|
||||
fin >> elements[i];
|
||||
if(i==colindex[counterV + k]){
|
||||
elements[i]=num[counterV + k];
|
||||
if(linum[counterV +k]==linum[counterV + k + 1]){
|
||||
++k;
|
||||
}
|
||||
}
|
||||
fot << elements[i] << '\t';
|
||||
|
||||
}
|
||||
counterV = counterV + k;
|
||||
}
|
||||
|
||||
fot << "\n";
|
||||
delete [] elements;
|
||||
NEXT;
|
||||
}
|
||||
++counterV;
|
||||
} else {
|
||||
getline(fin,tempString);
|
||||
fot << tempString << "\n";
|
||||
}
|
||||
++counter;
|
||||
if(counter > 1000){
|
||||
stop("You modified a line which has not as many columns as you specified.");
|
||||
}
|
||||
}
|
||||
fin.close();
|
||||
fot.close();
|
||||
return 0;
|
||||
}
|
||||
|
||||
//' changeMusoC
|
||||
//'
|
||||
//' This function is fastly randomize values based on min and max values
|
||||
//' @importFrom Rcpp evalCpp
|
||||
//' @useDynLib RBBGCMuso
|
||||
//' @param inFile is the big matrix
|
||||
//' @param outFile is the small matrix
|
||||
//' @export
|
||||
// [[Rcpp::export]]
|
||||
void changeMusoC(std::string inFile, std::string outFile, NumericMatrix inMat){
|
||||
int numChanges = inMat.nrow();
|
||||
IntegerMatrix indexes(numChanges,3);
|
||||
indexes = getPositions(inMat(_,0));
|
||||
fileChanger(inFile,outFile,indexes(_,0),inMat(_,1),indexes(_,1),indexes(_,2));
|
||||
}
|
||||
@ -1,245 +0,0 @@
|
||||
#include <Rcpp.h>
|
||||
#include <numeric>
|
||||
#include <iostream>
|
||||
#include <algorithm>
|
||||
#include <numeric>
|
||||
#include <ctime>
|
||||
|
||||
|
||||
using namespace Rcpp;
|
||||
using namespace std;
|
||||
// [[Rcpp::plugins(cpp11)]]
|
||||
|
||||
|
||||
|
||||
NumericMatrix randTypeZero(NumericMatrix m){
|
||||
/*
|
||||
A typical matrix like m:
|
||||
|
||||
| INDEX | DEPENDENCE | MIN | MAX |
|
||||
|-------+------------+------+------|
|
||||
| 21 | 0 | 0 | 364 |
|
||||
| 57 | 0 | bkla | asdf |
|
||||
|
||||
This randomization type is the easiest,
|
||||
the function produces a matrix which first
|
||||
column contains the indexes, and the second contains
|
||||
random numbers, which was drawn from uniform distribution
|
||||
with the corresponding min and max parameters, specified
|
||||
by the matrix m.
|
||||
|
||||
*/
|
||||
int n=m.nrow()-1;
|
||||
NumericMatrix M(n+1,2);
|
||||
M(_,0)=m(_,0);
|
||||
for(int i=0;i<=n;++i){
|
||||
double min=m(i,2);
|
||||
double max=m(i,3);
|
||||
M(i,1)=runif(1,min,max)[0];
|
||||
}
|
||||
return M;
|
||||
}
|
||||
|
||||
// [[Rcpp::export]]
|
||||
NumericMatrix randTypeOne(NumericMatrix m){
|
||||
/*
|
||||
The stucture of matrix m here is the same
|
||||
as in randTypeZero.
|
||||
|
||||
|
||||
|
||||
*/
|
||||
|
||||
|
||||
NumericVector dependence=m(_,2);
|
||||
int n=m.nrow()-1;
|
||||
NumericMatrix M(n+1,2);
|
||||
M(_,0)=m(_,0);
|
||||
M(0,1)=runif(1,m(0,2),m(0,3))[0];
|
||||
for(int i=1;i<=n;++i){
|
||||
int dep=m(i,1)-1;
|
||||
double min=max(M(dep,1),m(i,2));
|
||||
double max=m(i,3);
|
||||
M(i,1)=runif(1,min,max)[0];
|
||||
}
|
||||
return M;
|
||||
}
|
||||
|
||||
|
||||
|
||||
IntegerVector orderDec(NumericVector v){
|
||||
//This function is order a vector decreasingly
|
||||
Function f("order");
|
||||
return f(v,_["decreasing"]=1);
|
||||
}
|
||||
|
||||
// NumericMatrix randTypeTwo(NumericMatrix m){
|
||||
// int n=m.nrow()-1;
|
||||
// int N=n-1;
|
||||
// NumericMatrix mv=m(Range(0,(n-1)),_);
|
||||
// NumericVector dependence=m(_,2);
|
||||
// NumericMatrix M(n+1,2);
|
||||
// M(_,0)=m(_,0);
|
||||
// IntegerVector indexes=orderDec(mv(_,2));
|
||||
// NumericVector sorban=mv(_,2);
|
||||
// sorban.sort(true);
|
||||
// NumericVector sor=cumsum(sorban);
|
||||
// sor.sort(true);
|
||||
// for(int i=0;i<=N;++i){
|
||||
// if(i!=N){
|
||||
// mv((indexes[i]-1),3)-= sor[i+1];
|
||||
// }
|
||||
// }
|
||||
|
||||
// double rollingNumber=0;
|
||||
|
||||
// for(int i=0;i<=N;++i){
|
||||
// double minimum=mv((indexes[i]-1),2);
|
||||
// double maximum=mv((indexes[i]-1),3)-rollingNumber;
|
||||
// M(i,1)=runif(1,minimum,maximum)[0];
|
||||
// rollingNumber+=M(i,1);
|
||||
// // cout << "minimum:\t" << minimum << endl;
|
||||
// // cout << "maximum:\t" << maximum << endl;
|
||||
// // cout << "indexes:\t" << indexes[i] << endl;
|
||||
// // cout << "rollingNumber:\t" << rollingNumber << endl;
|
||||
// // cout << "choosen:\t" << M(i,1) <<endl;
|
||||
// // cout << "sor:\t" << sor <<endl;
|
||||
// // cout << "\n\n\n" << mv;
|
||||
// }
|
||||
// M(n,1)=1-rollingNumber;
|
||||
// return M;
|
||||
// }
|
||||
|
||||
|
||||
//[[Rcpp::export]]
|
||||
NumericMatrix randTypeTwo(NumericMatrix m){
|
||||
int n = m.nrow()-1; //Just for optimalization (indexing from 0)
|
||||
int N = n-1; //Just for optimalization (indexing from 0)
|
||||
NumericMatrix mv = m(Range(0,(n-1)),_); // We take off the first n-1 element. What about the last element?????????
|
||||
NumericVector dependence = m(_,2); // Th dependence vector represent the matrix and other information for function based on the elements.
|
||||
NumericMatrix M(n+1,2); // M is the randomizated matrix. It will have n+1 rows (identical to m).
|
||||
M(_,0) = m(_,0); //Insert the indexes
|
||||
IntegerVector indexes = orderDec(mv(_,2)); // Why not use the dependence variable?
|
||||
NumericVector sorban = mv(_,2); // Original ordering of the dependence variable?
|
||||
sorban.sort(true); // With the previous line, it sorts the dependence variable.
|
||||
NumericVector sor=cumsum(sorban); // ?????
|
||||
sor.sort(true); // ??????
|
||||
for(int i=0;i<=N;++i){
|
||||
if(i!=N){
|
||||
mv((indexes[i]-1),3)-= sor[i+1];
|
||||
}
|
||||
}
|
||||
|
||||
double rollingNumber=0;
|
||||
|
||||
for(int i=0;i<=N;++i){
|
||||
double minimum=mv((indexes[i]-1),2);
|
||||
double maximum=mv((indexes[i]-1),3)-rollingNumber;
|
||||
M(i,1)=runif(1,minimum,maximum)[0];
|
||||
rollingNumber+=M(i,1);
|
||||
// cout << "minimum:\t" << minimum << endl;
|
||||
// cout << "maximum:\t" << maximum << endl;
|
||||
// cout << "indexes:\t" << indexes[i] << endl;
|
||||
// cout << "rollingNumber:\t" << rollingNumber << endl;
|
||||
// cout << "choosen:\t" << M(i,1) <<endl;
|
||||
// cout << "sor:\t" << sor <<endl;
|
||||
// cout << "\n\n\n" << mv;
|
||||
}
|
||||
M(n,1)=1-rollingNumber;
|
||||
return M;
|
||||
}
|
||||
|
||||
NumericMatrix randTypeThree(NumericMatrix m){
|
||||
int n=m.nrow()-1;
|
||||
int N=n-1;
|
||||
NumericMatrix mv=m(Range(0,(n-1)),_);
|
||||
NumericVector dependence=m(_,2);
|
||||
NumericMatrix M(n+1,2);
|
||||
M(_,0)=m(_,0);
|
||||
IntegerVector indexes=orderDec(mv(_,2));
|
||||
NumericVector sorban=mv(_,2);
|
||||
sorban.sort(true);
|
||||
NumericVector sor=cumsum(sorban);
|
||||
sor.sort(true);
|
||||
for(int i=0;i<=N;++i){
|
||||
if(i!=N){
|
||||
mv((indexes[i]-1),3)-= sor[i+1];
|
||||
}
|
||||
}
|
||||
|
||||
double rollingNumber=0;
|
||||
|
||||
for(int i=0;i<=N;++i){
|
||||
double minimum=mv((indexes[i]-1),2);
|
||||
double maximum=mv((indexes[i]-1),3)-rollingNumber;
|
||||
M(i,1)=runif(1,minimum,maximum)[0];
|
||||
rollingNumber+=M(i,1);
|
||||
// cout << "minimum:\t" << minimum << endl;
|
||||
// cout << "maximum:\t" << maximum << endl;
|
||||
// cout << "indexes:\t" << indexes[i] << endl;
|
||||
// cout << "rollingNumber:\t" << rollingNumber << endl;
|
||||
// cout << "choosen:\t" << M(i,1) <<endl;
|
||||
// cout << "sor:\t" << sor <<endl;
|
||||
// cout << "\n\n\n" << mv;
|
||||
}
|
||||
M(n,1)=1-rollingNumber;
|
||||
return M;
|
||||
}
|
||||
|
||||
|
||||
|
||||
NumericMatrix copyMatSpec(NumericMatrix A, NumericMatrix B, int u, int v){
|
||||
int k=0;
|
||||
for(int i=u;i<=v;++i){
|
||||
A(i,_)=B(k,_);
|
||||
k+=1;
|
||||
}
|
||||
return A;
|
||||
}
|
||||
|
||||
|
||||
|
||||
//' musoRandomizer
|
||||
//'
|
||||
//' This function is fastly randomize values based on min and max values,
|
||||
//' and row indexes.
|
||||
//' @importFrom Rcpp evalCpp
|
||||
//' @useDynLib RBBGCMuso
|
||||
//' @param A is the big matrix
|
||||
//' @param B is the small matrix
|
||||
//' @export
|
||||
// [[Rcpp::export]]
|
||||
NumericMatrix musoRandomizer(NumericMatrix A, NumericMatrix B){
|
||||
NumericMatrix M(A.nrow(),2);
|
||||
int nGroup = B.nrow()-1;
|
||||
int k=0;
|
||||
for(int i=0;i<=nGroup;++i)
|
||||
{
|
||||
int b=B(i,0)-1;
|
||||
int till=b+k;
|
||||
int t=B(i,1);
|
||||
// cout << b << "\t" << t <<endl;
|
||||
switch(t){
|
||||
case 0:
|
||||
M=copyMatSpec(M,randTypeZero(A(Range(k,till),_)),k,till);
|
||||
// cout << M << endl;
|
||||
break;
|
||||
case 1:
|
||||
M=copyMatSpec(M,randTypeOne(A(Range(k,till),_)),k,till);
|
||||
// cout << M << endl;
|
||||
break;
|
||||
case 2:
|
||||
M=copyMatSpec(M,randTypeTwo(A(Range(k,till),_)),k,till);
|
||||
// cout << M << endl;
|
||||
break;
|
||||
}
|
||||
k=till+1;
|
||||
// cout << k << endl;
|
||||
}
|
||||
return M;
|
||||
}
|
||||
|
||||
std::string concatenate(std::string A, std::string B){
|
||||
std::string C = A + B;
|
||||
return C;
|
||||
}
|
||||
295
calibrateMuso.R
Normal file
295
calibrateMuso.R
Normal file
@ -0,0 +1,295 @@
|
||||
#' calibrateMuso
|
||||
#'
|
||||
#' This funtion uses the Monte Carlo technique to uniformly sample the parameter space from user defined parameters of the Biome-BGCMuSo model. The sampling algorithm ensures that the parameters are constrained by the model logic which means that parameter dependencies are fully taken into account (parameter dependency means that e.g leaf C:N ratio must be smaller than C:N ratio of litter; more complicated rules apply to the allocation parameters where the allocation fractions to different plant compartments must sum up 1). This function implements a mathematically correct solution to provide uniform distriution for all selected parameters.
|
||||
#' @author Roland HOLLOS
|
||||
#' @export
|
||||
calibrateMuso <- function(measuredData, parameters = NULL, startDate = NULL,
|
||||
endDate = NULL, formatString = "%Y-%m-%d",
|
||||
dataVar, outLoc = "./calib",
|
||||
preTag = "cal-", settings = setupMuso(),
|
||||
outVars = NULL, iterations = 30,
|
||||
skipSpinup = TRUE, plotName = "calib.jpg",
|
||||
modifyOriginal=TRUE, likelihood, uncertainity = NULL,
|
||||
naVal = NULL, postProcString = NULL,
|
||||
tread_prefix="thread", numcores = (parallel::detectCores()-1), pb = txtProgressBar(min=0, max=iterations, style=3),
|
||||
pbUpdate = setTxtProgressBar){
|
||||
|
||||
# ____ _ _ _ _
|
||||
# / ___|_ __ ___ __ _| |_ ___ | |_| |__ _ __ ___ __ _ __| |___
|
||||
# | | | '__/ _ \/ _` | __/ _ \ | __| '_ \| '__/ _ \/ _` |/ _` / __|
|
||||
# | |___| | | __/ (_| | || __/ | |_| | | | | | __/ (_| | (_| \__ \
|
||||
# \____|_| \___|\__,_|\__\___| \__|_| |_|_| \___|\__,_|\__,_|___/
|
||||
|
||||
|
||||
copyToThreadDirs(thread_prefix, numcores = numcores, runDir = settings$inputLoc)
|
||||
|
||||
# ____ _ _ _
|
||||
# | _ \ _ _ _ __ | |_| |__ _ __ ___ __ _ __| |___
|
||||
# | |_) | | | | '_ \ | __| '_ \| '__/ _ \/ _` |/ _` / __|
|
||||
# | _ <| |_| | | | | | |_| | | | | | __/ (_| | (_| \__ \
|
||||
# |_| \_\\__,_|_| |_| \__|_| |_|_| \___|\__,_|\__,_|___/
|
||||
|
||||
threadCount <- distributeCores(iterations, numCores)
|
||||
|
||||
fut <- lapply(1:numCores, function(i) {
|
||||
future({
|
||||
musoSingleThread(measuredData, parameters, startDate,
|
||||
endDate, formatString,
|
||||
dataVar, outLoc,
|
||||
preTag, settings,
|
||||
outVars, iterations = threadCount[i],
|
||||
skipSpinup, plotName,
|
||||
modifyOriginal, likelihood, uncertainity,
|
||||
naVal, postProcString, i)
|
||||
})
|
||||
})
|
||||
|
||||
# __ ___ _ _
|
||||
# \ \ / / |__ __ _| |_ ___| |__ _ __ _ __ ___ ___ ___ ___ ___
|
||||
# \ \ /\ / /| '_ \ / _` | __/ __| '_ \ | '_ \| '__/ _ \ / __/ _ \/ __/ __|
|
||||
# \ V V / | | | | (_| | || (__| | | | | |_) | | | (_) | (_| __/\__ \__ \
|
||||
# \_/\_/ |_| |_|\__,_|\__\___|_| |_| | .__/|_| \___/ \___\___||___/___/
|
||||
# |_|
|
||||
|
||||
getProgress <- function(){
|
||||
threadfiles <- list.files(settings$inputLoc, pattern="progress.txt", recursive = TRUE)
|
||||
if(length(threadfiles)==0){
|
||||
return(0)
|
||||
} else {
|
||||
sum(sapply(threadfiles, function(x){
|
||||
partRes <- readLines(x)
|
||||
if(length(partRes)==0){
|
||||
return(0)
|
||||
} else {
|
||||
return(as.numeric(partRes))
|
||||
}
|
||||
|
||||
}))
|
||||
|
||||
}
|
||||
}
|
||||
|
||||
progress <- 0
|
||||
while(progress < 400){
|
||||
Sys.sleep(1)
|
||||
progress <- getProgress()
|
||||
pbUpdate(pb,as.numeric(progress))
|
||||
}
|
||||
close(pb)
|
||||
|
||||
# ____ _ _
|
||||
# / ___|___ _ __ ___ | |__ (_)_ __ ___
|
||||
# | | / _ \| '_ ` _ \| '_ \| | '_ \ / _ \
|
||||
# | |__| (_) | | | | | | |_) | | | | | __/
|
||||
# \____\___/|_| |_| |_|_.__/|_|_| |_|\___|
|
||||
|
||||
|
||||
# ____ _ _ _ _____
|
||||
# / ___| | | | | | ____|
|
||||
# | | _| | | | | | _|
|
||||
# | |_| | |__| |_| | |___
|
||||
# \____|_____\___/|_____|
|
||||
|
||||
|
||||
# musoGlue("preservedCalib.csv",w=w, lg = lg)
|
||||
}
|
||||
|
||||
copyToThreadDirs <- function(prefix="thread", numcores=parallel::detectCores()-1, runDir="."){
|
||||
browser()
|
||||
dir.create(file.path(runDir,prefix), showWarnings=TRUE)
|
||||
fileNames <- grep("^thread.*", list.files(runDir), value=TRUE, invert=TRUE)
|
||||
invisible(sapply(1:numcores,function(corenum){
|
||||
threadDir <- file.path(runDir,prefix,paste0(prefix,"_",corenum))
|
||||
dir.create(threadDir, showWarnings=FALSE)
|
||||
file.copy(from=fileNames,to=threadDir, overwrite=FALSE)
|
||||
}))
|
||||
}
|
||||
|
||||
musoSingleThread <- function(measuredData, parameters = NULL, startDate = NULL,
|
||||
endDate = NULL, formatString = "%Y-%m-%d",
|
||||
dataVar, outLoc = "./calib",
|
||||
preTag = "cal-", settings = setupMuso(),
|
||||
outVars = NULL, iterations = 30,
|
||||
skipSpinup = TRUE, plotName = "calib.jpg",
|
||||
modifyOriginal=TRUE, likelihood, uncertainity = NULL,
|
||||
naVal = NULL, postProcString = NULL, threadNumber) {
|
||||
|
||||
setwd(paste0("thread/thread-",threadNumber))
|
||||
# Exanding likelihood
|
||||
likelihoodFull <- as.list(rep(NA,length(dataVar)))
|
||||
names(likelihoodFull) <- names(dataVar)
|
||||
if(!missing(likelihood)) {
|
||||
lapply(names(likelihood),function(x){
|
||||
likelihoodFull[[x]] <<- likelihood[[x]]
|
||||
})
|
||||
}
|
||||
defaultLikelihood <- which(is.na(likelihood))
|
||||
if(length(defaultLikelihood)>0){
|
||||
likelihoodFull[[defaultLikelihood]] <- (function(x, y){
|
||||
exp(-sqrt(mean((x-y)^2)))
|
||||
})
|
||||
}
|
||||
|
||||
mdata <- measuredData
|
||||
if(is.null(parameters)){
|
||||
parameters <- tryCatch(read.csv("parameters.csv", stringsAsFactor=FALSE), error = function (e) {
|
||||
stop("You need to specify a path for the parameters.csv, or a matrix.")
|
||||
})
|
||||
} else {
|
||||
if((!is.list(parameters)) & (!is.matrix(parameters))){
|
||||
parameters <- tryCatch(read.csv(parameters, stringsAsFactor=FALSE), error = function (e){
|
||||
stop("Cannot find neither parameters file neither the parameters matrix")
|
||||
})
|
||||
}}
|
||||
|
||||
outLoc <- normalizePath(outLoc)
|
||||
outLocPlain <- basename(outLoc)
|
||||
currDir <- getwd()
|
||||
|
||||
if(!dir.exists(outLoc)){
|
||||
dir.create(outLoc)
|
||||
warning(paste(outLoc," is not exists, so it was created"))
|
||||
}
|
||||
|
||||
outLoc <- normalizePath(outLoc)
|
||||
parameterNames <- parameters[,1]
|
||||
pretag <- file.path(outLoc,preTag)
|
||||
##reading the original epc file at the specified
|
||||
## row numbers
|
||||
print("optiMuso is randomizing the epc parameters now...",quote = FALSE)
|
||||
if(iterations < 3000){
|
||||
randVals <- musoRand(parameters = parameters,constrains = NULL, iterations = 3000)
|
||||
randVals[[2]]<- randVals[[2]][sample(1:3000,iterations),]
|
||||
} else {
|
||||
randVals <- musoRand(parameters = parameters,constrains = NULL, iterations = iterations)
|
||||
}
|
||||
|
||||
origEpc <- readValuesFromFile(settings$epc[2],randVals[[1]])
|
||||
partialResult <- matrix(ncol=length(randVals[[1]])+2*length(dataVar))
|
||||
colN <- randVals[[1]]
|
||||
colN[match(parameters[,2],randVals[[1]])] <- parameters[,1]
|
||||
colnames(partialResult) <- c(colN,sprintf("%s_likelihood",names(dataVar)),
|
||||
sprintf("%s_rmse",names(dataVar)))
|
||||
numParameters <- length(colN)
|
||||
partialResult[1:numParameters] <- origEpc
|
||||
## Prepare the preservedCalib matrix for the faster
|
||||
## run.
|
||||
|
||||
pretag <- file.path(outLoc,preTag)
|
||||
|
||||
musoCodeToIndex <- sapply(dataVar,function(musoCode){
|
||||
settings$dailyOutputTable[settings$dailyOutputTable$code == musoCode,"index"]
|
||||
})
|
||||
resultRange <- (numParameters + 1):(ncol(partialResult))
|
||||
## Creating function for generating separate
|
||||
## csv files for each run
|
||||
|
||||
progBar <- txtProgressBar(1,iterations,style=3)
|
||||
settings$iniInput[2] %>%
|
||||
(function(x) paste0(dirname(x),"/",tools::file_path_sans_ext(basename(x)),"-tmp.",tools::file_ext(x))) %>%
|
||||
unlink
|
||||
randValues <- randVals[[2]]
|
||||
|
||||
settings$calibrationPar <- randVals[[1]]
|
||||
|
||||
if(!is.null(naVal)){
|
||||
measuredData <- as.data.frame(measuredData)
|
||||
measuredData[measuredData == naVal] <- NA
|
||||
}
|
||||
|
||||
alignIndexes <- alignMuso(settings,measuredData)
|
||||
if(!is.null(uncertainity)){
|
||||
uncert <- measuredData[alignIndexes$meas,uncertainity]
|
||||
} else {
|
||||
uncert <- NULL
|
||||
}
|
||||
# browser()
|
||||
origModellOut <- calibMuso(settings=settings, silent=TRUE, skipSpinup = skipSpinup, postProcString=postProcString, modifyOriginal=modifyOriginal)
|
||||
partialResult[,resultRange] <- calcLikelihoodsAndRMSE(dataVar=dataVar,
|
||||
mod=origModellOut,
|
||||
mes=measuredData,
|
||||
likelihoods=likelihood,
|
||||
alignIndexes=alignIndexes,
|
||||
musoCodeToIndex = musoCodeToIndex,uncert=uncert)
|
||||
write.csv(x=origModellOut, file=paste0(pretag, 1, ".csv"))
|
||||
print("Running the model with the random epc values...", quote = FALSE)
|
||||
|
||||
# if(!is.null(postProcString)){
|
||||
# colNumb <- length(settings$dailyVarCodes) + 1
|
||||
# }
|
||||
|
||||
write.csv(x=partialResult, file="preservedCalib.csv",row.names=FALSE)
|
||||
for(i in 2:(iterations+1)){
|
||||
# browser()
|
||||
tmp <- tryCatch(calibMuso(settings = settings,
|
||||
parameters = randValues[(i-1),],
|
||||
silent= TRUE,
|
||||
skipSpinup = skipSpinup, modifyOriginal=modifyOriginal, postProcString = postProcString), error = function (e) NULL)
|
||||
if(is.null(tmp)){
|
||||
partialResult[,resultRange] <- NA
|
||||
} else {
|
||||
partialResult[,resultRange] <- calcLikelihoodsAndRMSE(dataVar=dataVar,
|
||||
mod=tmp,
|
||||
mes=measuredData,
|
||||
likelihoods=likelihood,
|
||||
alignIndexes=alignIndexes,
|
||||
musoCodeToIndex = musoCodeToIndex, uncert = uncert)
|
||||
}
|
||||
|
||||
|
||||
partialResult[1:numParameters] <- randValues[(i-1),]
|
||||
write.table(x=partialResult, file="preservedCalib.csv", append=TRUE, row.names=FALSE,
|
||||
sep=",", col.names=FALSE)
|
||||
write.csv(x=tmp, file=paste0(pretag, (i+1),".csv"))
|
||||
writeLines(as.character(i),"progress.txt")
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
distributeCores <- function(iterations, numCores){
|
||||
perProcess<- iterations %/% numCores
|
||||
numSimu <- rep(perProcess,numCores)
|
||||
gainers <- sample(1:numCores, iterations %% numCores)
|
||||
numSimu[gainers] <- numSimu[gainers] + 1
|
||||
numSimu
|
||||
}
|
||||
|
||||
prepareFromAgroMo <- function(fName){
|
||||
obs <- read.table(fName, stringsAsFactors=FALSE, sep = ";", header=T)
|
||||
obs <- reshape(obs, timevar="var_id", idvar = "date", direction = "wide")
|
||||
dateCols <- apply(do.call(rbind,(strsplit(obs$date, split = "-"))),2,as.numeric)
|
||||
colnames(dateCols) <- c("year", "month", "day")
|
||||
cbind.data.frame(dateCols, obs)
|
||||
}
|
||||
|
||||
|
||||
calcLikelihoodsAndRMSE <- function(dataVar, mod, mes, likelihoods, alignIndexes, musoCodeToIndex, uncert){
|
||||
|
||||
likelihoodRMSE <- sapply(names(dataVar),function(key){
|
||||
# browser()
|
||||
modelled <- mod[alignIndexes$mod,musoCodeToIndex[key]]
|
||||
selected <- grep(sprintf("%s$", key), colnames(mes))
|
||||
measured <- mes[alignIndexes$meas,selected]
|
||||
modelled <- modelled[!is.na(measured)]
|
||||
# uncert <- uncert[!is.na(measured)]
|
||||
measured <- measured[!is.na(measured)]
|
||||
res <- c(likelihoods[[key]](modelled, measured, uncert),
|
||||
sqrt(mean((modelled-measured)^2))
|
||||
)
|
||||
res
|
||||
})
|
||||
names(likelihoodRMSE) <- c(sprintf("%s_likelihood",dataVar), sprintf("%s_rmse",dataVar))
|
||||
|
||||
return(c(likelihoodRMSE[1,],likelihoodRMSE[2,]))
|
||||
}
|
||||
|
||||
agroLikelihood <- function(modVector,measured){
|
||||
mu <- measured[,grep("^mean", colnames(measured))]
|
||||
stdev <- measured[,grep("^sd", colnames(measured))]
|
||||
ndata <- nrow(measured)
|
||||
sum(sapply(1:ndata, function(x){
|
||||
dnorm(modVector, mu[x], stdev[x], log = TRUE)
|
||||
}))
|
||||
}
|
||||
|
||||
# prepareFromAgroMo("/home/hollorol/agromo/calibration/martonvasar/MV_highN.obs")
|
||||
90
parallelRun.R
Normal file
90
parallelRun.R
Normal file
@ -0,0 +1,90 @@
|
||||
library(parallel)
|
||||
library('future')
|
||||
plan(multiprocess)
|
||||
library('RBBGCMuso')
|
||||
|
||||
a <- tempdir()
|
||||
setwd(a)
|
||||
file.copy(from="~/R/x86_64-pc-linux-gnu-library/3.5/RBBGCMuso/examples/hhs",to="./", recursive = TRUE)
|
||||
setwd("hhs")
|
||||
list.files()
|
||||
|
||||
settings <- setupMuso()
|
||||
setupMuso()
|
||||
settings$outputLoc
|
||||
|
||||
|
||||
copyToThreadDirs <- function(prefix="thread", numcores=parallel::detectCores()-1, runDir="."){
|
||||
dir.create(file.path(runDir,prefix), showWarnings=TRUE)
|
||||
fileNames <- grep("^thread.*", list.files(runDir), value=TRUE, invert=TRUE)
|
||||
invisible(sapply(1:numcores,function(corenum){
|
||||
threadDir <- file.path(runDir,prefix,paste0(prefix,"_",corenum))
|
||||
dir.create(threadDir, showWarnings=FALSE)
|
||||
file.copy(from=fileNames,to=threadDir, overwrite=FALSE)
|
||||
}))
|
||||
}
|
||||
|
||||
copyToThreadDirs()
|
||||
unlink("thread", recursive=TRUE)
|
||||
|
||||
procFun <- function(index){
|
||||
progressState <- tempfile(pattern=paste("thread",index,sep="-", tmpdir="./"))
|
||||
for(i in 1:100){
|
||||
Sys.sleep(1)
|
||||
writeLines(as.character(i),paste("thread",index,sep="-"))
|
||||
}
|
||||
}
|
||||
|
||||
futu <- vector(mode="list", length=4)
|
||||
names(futu) <- 1:4
|
||||
futu
|
||||
|
||||
|
||||
getProgress <- function(){
|
||||
threadfiles <- list.files(pattern="thread*")
|
||||
if(length(threadfiles)==0){
|
||||
return(0)
|
||||
} else {
|
||||
sum(sapply(threadfiles, function(x){
|
||||
partRes <- readLines(x)
|
||||
if(length(partRes)==0){
|
||||
return(0)
|
||||
} else {
|
||||
return(as.numeric(partRes))
|
||||
}
|
||||
|
||||
}))
|
||||
|
||||
}
|
||||
}
|
||||
|
||||
getProgress()
|
||||
futu
|
||||
list.files()
|
||||
readLines("threadi-1")
|
||||
procFun(8)
|
||||
file.remove(pattern="thread*")
|
||||
file.remove((list.files(pattern="thread*")))
|
||||
|
||||
|
||||
wachProgress <- function(){
|
||||
progress <- 0
|
||||
while(progress < 400){
|
||||
Sys.sleep(1)
|
||||
progress <- getProgress()
|
||||
print(paste(as.numeric(progress)/400*100,"%"))
|
||||
}
|
||||
}
|
||||
|
||||
for(i in 1:4){
|
||||
futu[[as.character(i)]] <- future({procFun(i)})
|
||||
}
|
||||
lapply(1:4,function(i) future({procFun(i)}))
|
||||
pb <- txtProgressBar(min=0,max=400,style=3)
|
||||
progress <- 0
|
||||
while(progress < 400){
|
||||
Sys.sleep(1)
|
||||
progress <- getProgress()
|
||||
setTxtProgressBar(pb,as.numeric(progress))
|
||||
}
|
||||
close(pb)
|
||||
Loading…
Reference in New Issue
Block a user