musoMonte function
This commit is contained in:
parent
a5873da2c6
commit
5156c7e0a5
@ -10,8 +10,13 @@ NeedsCompilation: no
|
||||
Packaged: 2017-07-19 14:00:04 UTC; hollorol
|
||||
Author: Roland Hollo's [aut, cre]
|
||||
Imports:
|
||||
stats,
|
||||
utils,
|
||||
graphics
|
||||
graphics,
|
||||
Rcpp,
|
||||
magrittr,
|
||||
dplyr
|
||||
LinkingTo: Rcpp
|
||||
Maintainer: Roland Hollo's <hollorol@gmail.com>
|
||||
RoxygenNote: 6.0.1
|
||||
Suggests: knitr,
|
||||
|
||||
@ -1,5 +1,6 @@
|
||||
# Generated by roxygen2: do not edit by hand
|
||||
|
||||
export(OtableMaker)
|
||||
export(calibMuso)
|
||||
export(cleanupMuso)
|
||||
export(corrigMuso)
|
||||
@ -8,11 +9,17 @@ export(getyearlycum)
|
||||
export(getyearlymax)
|
||||
export(musoDate)
|
||||
export(musoMapping)
|
||||
export(musoRandomizer)
|
||||
export(plotMuso)
|
||||
export(rungetMuso)
|
||||
export(setupMuso)
|
||||
export(spinupMuso)
|
||||
export(supportedMuso)
|
||||
export(updateMusoMapping)
|
||||
import(dplyr)
|
||||
import(graphics)
|
||||
import(magrittr)
|
||||
import(stats)
|
||||
import(utils)
|
||||
importFrom(Rcpp,evalCpp)
|
||||
useDynLib(RBBGCMuso)
|
||||
|
||||
121
RBBGCMuso/R/#musoMonte.R#
Normal file
121
RBBGCMuso/R/#musoMonte.R#
Normal file
@ -0,0 +1,121 @@
|
||||
musoMonte <- function(settings=NULL,
|
||||
parameters,
|
||||
inputDir = "./",
|
||||
outLoc = "./calib",
|
||||
iterations = 10,
|
||||
preTag = "mont-",
|
||||
inputName = paste0(pretag,"epcs.csv"),
|
||||
outputType = "moreCsv",
|
||||
fun=mean,
|
||||
varIndex=8,
|
||||
doSensitivity=FALSE,
|
||||
onDisk=FALSE,
|
||||
...){
|
||||
|
||||
currDir <- getwd()
|
||||
tmp <- file.path(outLoc,"tmp/")
|
||||
|
||||
if(!dir.exists(outLoc)){
|
||||
dir.create(outLoc)
|
||||
warning(paste(outLoc," is not exists, so it was created"))
|
||||
}
|
||||
|
||||
if(dir.exists(tmp){
|
||||
stop("There is a tmp directory inside the output location, please replace it. tmp is an important temporary directory for the function")
|
||||
}
|
||||
dir.create(tmp)
|
||||
inputFiles <- file.path(inputDir,grep(basename(outLoc),list.files(inputDir),invert = TRUE,value = TRUE))
|
||||
|
||||
|
||||
for(i in inputFiles){
|
||||
file.copy(i,tmp)
|
||||
}
|
||||
setwd(tmp)
|
||||
|
||||
if(is.null(settings)){
|
||||
settings <- setupMuso()
|
||||
}
|
||||
|
||||
parameterNames <- parameters[,1]
|
||||
parReal <- parameters[,-1]
|
||||
Otable <- OtableMaker(parReal)
|
||||
A <- as.matrix(Otable[[1]][,c(2,4,5,6)])
|
||||
B <- as.matrix(Otable[[2]])
|
||||
settings$calibrationPar <- A[,1]
|
||||
pretag <- file.path(outLoc,preTag)
|
||||
|
||||
##reading the original epc file at the specified
|
||||
## row numbers
|
||||
|
||||
origEpcFile <- readLines(settings$epcInput[2])
|
||||
|
||||
origEpc <- unlist(lapply(settings$calibrationPar, function (x) {
|
||||
as.numeric(unlist(strsplit(origEpcFile[x],split="[\t ]"))[1])
|
||||
}))
|
||||
|
||||
## Prepare the preservedEpc matrix for the faster
|
||||
## run.
|
||||
preservedEpc <- matrix(nrow = (iterations +1 ), ncol = length(settings$calibrationPar))
|
||||
preservedEpc[1,] <- origEpc
|
||||
colnames(preservedEpc) <- Otable[[1]][,1]
|
||||
|
||||
## Save the backupEpc, while change the settings
|
||||
## variable and set the output.
|
||||
file.copy(settings$epc[2],"savedEpc",overwrite = TRUE) # do I need this?
|
||||
pretag <- file.path(outLoc,preTag)
|
||||
|
||||
## Creating function for generating separate
|
||||
## csv files for each run
|
||||
a<-1:100000
|
||||
moreCsv <- function(){
|
||||
for(i in 1:iterations){
|
||||
parVar <- musoRandomizer(A,B)[,2]
|
||||
#preservedEpc[(i+1),] <- parVar
|
||||
exportName <- paste0(preTag,i,".csv")
|
||||
tryCatch (calibMuso(settings,debugging = "stamplog",
|
||||
parameters = parVar,export = exportName,
|
||||
keepEpc = TRUE),error=function(e) NA )
|
||||
}
|
||||
return(preservedEpc)
|
||||
}
|
||||
|
||||
## Creating function for generating one
|
||||
## csv files for each run
|
||||
|
||||
oneCsv <- function () {
|
||||
numDays <- settings$numdata[1]
|
||||
if(!onDisk){
|
||||
for(i in 1:iterations){
|
||||
|
||||
parVar <- apply(parameters,1,function (x) {
|
||||
runif(1, as.numeric(x[3]), as.numeric(x[4]))})
|
||||
preservedEpc[(i+1),] <- parVar
|
||||
exportName <- paste0(preTag,".csv")
|
||||
write.csv(parvar,"preservedEpc.csv",append=TRUE)
|
||||
calibMuso(settings,debugging = "stamplog",
|
||||
parameters = parVar,keepEpc = TRUE) %>%
|
||||
{mutate(.,iD = i)} %>%
|
||||
{write.csv(.,file=exportName,append=TRUE)}
|
||||
}
|
||||
|
||||
return(preservedEpc)
|
||||
} else {
|
||||
|
||||
}
|
||||
}
|
||||
|
||||
netCDF <- function () {
|
||||
stop("This function is not inplemented yet")
|
||||
}
|
||||
|
||||
## Call one function according to the outputType
|
||||
switch(outputType,
|
||||
"oneCsv" = (preservedEpc <- oneCsv()),
|
||||
"moreCsv" = (preservedEpc <- moreCsv()),
|
||||
"netCDF" = (preservedEpc <- netCDF()))
|
||||
|
||||
## Change back the epc file to the original
|
||||
|
||||
file.copy(savedEpc,settings$epc[2],overwrite = TRUE)
|
||||
write.csv(preservedEpc,"preservedEpc.csv")
|
||||
}
|
||||
256
RBBGCMuso/R/#setupMuso.R#
Normal file
256
RBBGCMuso/R/#setupMuso.R#
Normal file
@ -0,0 +1,256 @@
|
||||
#' setupMuso
|
||||
#'
|
||||
#' This funcion is fundamental for the BiomBGC-MuSo modell related functions like spinupMuso, normalMuso, rungetMuso, because it sets the modells environment.
|
||||
#'
|
||||
#' @author Roland Hollos
|
||||
#' @param parallel Do you want to run multiple modell paralelly, if yes, set this variable to TRUE
|
||||
#' @param executable This parameter stores the place of the modell-executable file. In normal usage, you don't have to be set this, because a RBBgcmuso package contains allways the latest modell executable. In spite of this, if you would like to use this package for modell development or just want to use different models (for example for comparison), you will find it useful
|
||||
#' @param calibrationPar You may want to change some parameters in your epc file, before you run the modell. You have to select the appropirate modell parameters. You can refence to these with the number of the line in the epc file where the variables are. It indexes from one. You should use a vector for this, like: c(1,5,8)
|
||||
#' @param outputLoc Where should the modell puts its outputs. You should give a location for it via this variable, for example: outputLoc="/place/of/the/outputs/"
|
||||
#' @param inputLoc Usually it is the root directory, where you put the iniFiles for the modell
|
||||
#' @param metInput Via metInput parameter, you can tell the modell where are the meteorological files. As default it reads this from the iniFiles.
|
||||
#' @param CO2Input Via CO2 parameter, you can tell the modell where are the CO2 data files. As default it reads this from the iniFiles.
|
||||
#' @param plantInput Via planting parameter, you can tell the modell where are the data files, which contains the planting informations. As default it reads this from the iniFiles.
|
||||
#' @param thinInput Via thining parameter, you can tell the modell where are the data files, which contains the thining informations. As default it reads this from the iniFiles.
|
||||
#' @param mowInput Via mowing parameter, you can tell the modell where are the data files, which contains the mowing informations. As default it reads this from the iniFiles.
|
||||
#' @param grazInput Via grazing parameter, you can tell the modell where are the data files, which contains the grazing informations. As default it reads this from the iniFiles.
|
||||
#' @param harvInput Via harvesting parameter, you can tell the modell where are the data files, which contains the harvesting informations. As default it reads this from the iniFiles.
|
||||
#' @param plougInput Via ploughing parameter, you can tell the modell where are the data files, which contains the ploughing informations. As default it reads this from the iniFiles.
|
||||
#' @param fertInput Via fertilizing parameter, you can tell the modell where are the fertilizing data files, which contains the fertilizing informations. As default it reads this from the iniFiles.
|
||||
#' @param irrInput Via irrigation parameter, you can tell the modell where are the data files, which contains the irrigation informations. As default it reads this from the iniFiles.
|
||||
#' @param nitInput Via this parameter, you can tell the modell where are the NO2 data files. As default it reads this from the iniFiles.
|
||||
#' @param iniInput Via this parameter, you can tell the modell where are the ini files. As default it reads this from the iniFiles.
|
||||
#' @param epcInput Via this parameter, you can tell the modell where are the epc data files. As default it reads this from the iniFiles.
|
||||
#' @usage setupMuso(executable=NULL, parallel = F, calibrationPar =c(1),
|
||||
#' outputLoc=NULL, inputLoc=NULL,
|
||||
#' metInput=NULL, CO2Input=NULL,
|
||||
#' plantInput=NULL, thinInput=NULL,
|
||||
#' mowInput=NULL, grazInput=NULL,
|
||||
#' harvInput=NULL, plougInput=NULL,
|
||||
#' fertInput=NULL, irrInput=NULL,
|
||||
#' nitInput=NULL, iniInput=NULL, epcInput=NULL)
|
||||
#' @return The output is a the modell setting list wich contains the following elements:
|
||||
#' executable, calibrationPar, outputLoc, outputName, inputLoc, iniInput, metInput, epcInput,thinInput,CO2Input, mowInput, grazInput, harvInput, plougInput, fertInput, irrInput, nitInput, inputFiles, numData, startyear, numYears, outputVars
|
||||
#' @export
|
||||
setupMuso <- function(executable=NULL,
|
||||
parallel = F,
|
||||
calibrationPar =c(1),
|
||||
outputLoc=NULL,
|
||||
inputLoc=NULL,
|
||||
metInput=NULL,
|
||||
CO2Input=NULL,
|
||||
plantInput=NULL,
|
||||
thinInput=NULL,
|
||||
mowInput=NULL,
|
||||
grazInput=NULL,
|
||||
harvInput=NULL,
|
||||
plougInput=NULL,
|
||||
fertInput=NULL,
|
||||
irrInput=NULL,
|
||||
nitInput=NULL,
|
||||
iniInput=NULL,
|
||||
epcInput=NULL,
|
||||
mapData=NULL,
|
||||
leapYear=FALSE,
|
||||
version=5
|
||||
){
|
||||
|
||||
Linuxp <-(Sys.info()[1]=="Linux")
|
||||
writep <- 0
|
||||
|
||||
if(is.null(mapData)&version==4){
|
||||
mData <- mMapping4
|
||||
}
|
||||
|
||||
inputParser <- function(string,fileName,counter,value=TRUE){
|
||||
unlist(strsplit(grep(string,fileName,value=TRUE),"[\ \t]"))[counter]
|
||||
}
|
||||
|
||||
outMaker <- function(inputVar,grepString,filep){
|
||||
tempVar <- eval(parse(text=inputVar))
|
||||
if(is.null(tempVar)){
|
||||
writep <<- writep+1
|
||||
if(filep)
|
||||
{
|
||||
tempVar["spinup"] <- paste0(inputLoc,inputParser(string=grepString,fileName=iniFiles$spinup,counter=1,value=TRUE))
|
||||
tempVar["normal"] <- paste0(inputLoc,inputParser(string=grepString,fileName=iniFiles$normal,counter=1,value=TRUE))
|
||||
} else {
|
||||
tempVar["spinup"] <- inputParser(string=grepString,fileName=iniFiles$spinup,counter=1,value=TRUE)
|
||||
tempVar["normal"] <- inputParser(string=grepString,fileName=iniFiles$normal,counter=1,value=TRUE)
|
||||
|
||||
}
|
||||
|
||||
} else {
|
||||
iniFiles$spinup[grep(grepString,iniFiles$spinup)] <<- paste0(tempVar[1],"\t ",grepString)
|
||||
|
||||
if(length(tempVar)==2){
|
||||
iniFiles$normal[grep(" grepString",iniFiles$normal)] <<- paste0(tempVar[2],"\t ",grepString)
|
||||
}
|
||||
}
|
||||
return(tempVar)
|
||||
}
|
||||
|
||||
if(is.null(inputLoc)){
|
||||
inputLoc<- "./"}
|
||||
|
||||
#iniChangedp <- FALSE
|
||||
|
||||
if(is.null(iniInput)){
|
||||
spinups<-grep("s.ini$",list.files(inputLoc),value=TRUE)
|
||||
normals<-grep("n.ini$",list.files(inputLoc),value=TRUE)
|
||||
|
||||
if(length(spinups)==1){
|
||||
iniInput[1]<-file.path(inputLoc,spinups)
|
||||
} else {stop("There are multiple or no spinup ini files, please choose")}
|
||||
|
||||
|
||||
if(length(normals)==1){
|
||||
iniInput[2]<-file.path(inputLoc,normals)
|
||||
} else {stop("There are multiple or no normal ini files, please choose")}
|
||||
|
||||
}
|
||||
|
||||
##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 /
|
||||
names(iniFiles) <- c("spinup","normal")
|
||||
|
||||
|
||||
|
||||
|
||||
inputs <- lapply(1:nrow(grepHelper), function (x) {
|
||||
|
||||
outMaker(grepHelper[x,1],grepHelper[x,2],grepHelper[x,3])
|
||||
|
||||
})
|
||||
names(inputs) <- grepHelper$inputVar
|
||||
## grepHelper is in sysdata.rda it is a table like this:
|
||||
##
|
||||
## inputVar string isFile
|
||||
## 1 epcInput EPC file name TRUE
|
||||
## 2 metInput met file name TRUE
|
||||
## 3 CO2Input CO2 file TRUE
|
||||
## 4 nitInput N-dep file TRUE
|
||||
## 5 thinInput do THINNING FALSE
|
||||
## 6 plantInput do PLANTING FALSE
|
||||
## 7 mowInput do MOWING FALSE
|
||||
## 8 grazInput do GRAZING FALSE
|
||||
## 9 harvInput do HARVESTING FALSE
|
||||
## 10 plougInput do PLOUGHING FALSE
|
||||
## 11 fertInput do FERTILIZING FALSE
|
||||
## 12 irrInput do IRRIGATION FALSE
|
||||
# return(inputs) debug element
|
||||
|
||||
|
||||
if(is.null(mapData)){
|
||||
|
||||
c<-grep("DAILY_OUTPUT",iniFiles[[2]])+1
|
||||
numVar<-as.numeric(unlist(strsplit(iniFiles[[2]][c],"[\ \t]"))[1])
|
||||
dailyVarCodes<-iniFiles[[2]][(c+1):(c+numVar)]
|
||||
dailyVarnames<-lapply(dailyVarCodes, function(x) musoMapping(unlist(strsplit(x,"[\ \t]"))[1]))
|
||||
|
||||
c<-grep("ANNUAL_OUTPUT",iniFiles[[2]])+1
|
||||
numVar<-as.numeric(unlist(strsplit(iniFiles[[2]][c],"[\ \t]"))[1])
|
||||
annualVarCodes<-iniFiles[[2]][(c+1):(c+numVar)]
|
||||
annualVarnames<-lapply(annualVarCodes, function(x) musoMapping(unlist(strsplit(x,"[\ \t]"))[1]))
|
||||
outputVars<-list(dailyVarnames,annualVarnames)} else {
|
||||
|
||||
c<-grep("DAILY_OUTPUT",iniFiles[[2]])+1
|
||||
numVar<-as.numeric(unlist(strsplit(iniFiles[[2]][c],"[\ \t]"))[1])
|
||||
dailyVarCodes<-iniFiles[[2]][(c+1):(c+numVar)]
|
||||
dailyVarnames<-lapply(dailyVarCodes, function(x) musoMapping(unlist(strsplit(x,"[\ \t]"))[1],mapData))
|
||||
|
||||
c<-grep("ANNUAL_OUTPUT",iniFiles[[2]])+1
|
||||
numVar<-as.numeric(unlist(strsplit(iniFiles[[2]][c],"[\ \t]"))[1])
|
||||
annualVarCodes<-iniFiles[[2]][(c+1):(c+numVar)]
|
||||
annualVarnames<-lapply(annualVarCodes, function(x) musoMapping(unlist(strsplit(x,"[\ \t]"))[1],mapData))
|
||||
outputVars<-list(dailyVarnames,annualVarnames)
|
||||
|
||||
|
||||
|
||||
}
|
||||
|
||||
|
||||
|
||||
if(is.null(executable)){
|
||||
if(Linuxp){
|
||||
executable<-file.path(inputLoc,"muso")
|
||||
} else {
|
||||
executable<-file.path(inputLoc,"muso.exe")
|
||||
}
|
||||
} else {
|
||||
file.copy(executable,inputLoc)
|
||||
}
|
||||
|
||||
outputName <- unlist(strsplit(iniFiles[[2]][grep("OUTPUT_CONTROL",iniFiles[[2]])+1],"[\ \t]"))[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]
|
||||
if(is.null(outputName)){
|
||||
stop("I cannot find outputName in your default ini file \n Please make sure that the line wich contains the name also contains the prefix and the outmut keywords!")
|
||||
|
||||
}
|
||||
## outputName<-unlist(read.table(iniInput[2],skip=93,nrows = 1))[1]
|
||||
|
||||
|
||||
if(is.null(outputLoc)){
|
||||
## outputLoc<-paste((rev(rev(unlist(strsplit(outputName,"/")))[-1])),collapse="/")
|
||||
outputLoc <- dirname(outputName)
|
||||
}
|
||||
|
||||
|
||||
|
||||
inputFiles<-c(iniInput,epcInput,metInput)
|
||||
numData<-rep(NA,3)
|
||||
numYears <- as.numeric(unlist(strsplit(grep("simulation years",iniFiles[[2]],value=TRUE),"[\ \t]"))[1])
|
||||
## numYears<-unlist(read.table(iniInput[2],skip = 14,nrows = 1)[1])
|
||||
numValues <- as.numeric(unlist(strsplit(grep("number of daily output variables",iniFiles[[2]],value=TRUE),"[\ \t]"))[1])
|
||||
## numValues will be replaced to numVar
|
||||
## numValues<-unlist(read.table(iniInput[2],skip=102,nrows = 1)[1])
|
||||
startyear <- as.numeric(unlist(strsplit(grep("first simulation year",iniFiles[[2]],value=TRUE),"[\ \t]"))[1])
|
||||
numData[1] <- numValues * sumDaysOfPeriod(startyear,numYears,corrigated=leapYear)
|
||||
|
||||
numData[2] <- numYears * numValues*12
|
||||
numData[3] <- numYears * numValues
|
||||
|
||||
##Writing out changed ini-file
|
||||
|
||||
writeLines(iniFiles[[1]],iniInput[1])
|
||||
writeLines(iniFiles[[2]],iniInput[2])
|
||||
|
||||
settings = list(executable = executable,
|
||||
calibrationPar = calibrationPar,
|
||||
outputLoc=outputLoc,
|
||||
outputNames=outputName,
|
||||
inputLoc=inputLoc,
|
||||
iniInput=iniInput,
|
||||
metInput=inputs$metInput,
|
||||
epcInput=inputs$epcInput,
|
||||
thinInput=inputs$thinInput,
|
||||
CO2Input=inputs$CO2Input,
|
||||
mowInput=inputs$mowInput,
|
||||
grazInput=inputs$grazInput,
|
||||
harvInput=inputs$harvInput,
|
||||
plougInput=inputs$plougInput,
|
||||
fertInput=inputs$fertInput,
|
||||
irrInput=inputs$irrInput,
|
||||
nitInput=inputs$nitInput,
|
||||
inputFiles=inputFiles,
|
||||
numData=numData,
|
||||
startyear=startyear,
|
||||
numYears=numYears,
|
||||
outputVars=outputVars
|
||||
)
|
||||
|
||||
if(writep!=nrow(grepHelper)){
|
||||
writeLines(iniFiles[[1]],iniInput[[1]])
|
||||
if(epcInput[1]!=epcInput[2]){ #Change need here
|
||||
writeLines(iniFiles[[2]],iniInput[[2]])
|
||||
}
|
||||
}
|
||||
return(settings)
|
||||
|
||||
}
|
||||
|
||||
50
RBBGCMuso/R/OtableMaker.R
Normal file
50
RBBGCMuso/R/OtableMaker.R
Normal file
@ -0,0 +1,50 @@
|
||||
#'OtableMaker
|
||||
#'
|
||||
#'This function is generating A and B table for musoRandomizer
|
||||
#'
|
||||
#'@param paramsReal The matrix of the parameters
|
||||
#'@return List of two matrices: A and B matrix for musoRandomizer
|
||||
#'@import stats
|
||||
#'@import magrittr
|
||||
#'@import dplyr
|
||||
#'@export
|
||||
|
||||
OtableMaker <- function(parametersReal){
|
||||
constMatrix %<>% arrange(TYPE,GROUP)
|
||||
|
||||
OTF<- t(apply(parametersReal,1,function(x){
|
||||
Group <- constMatrix[constMatrix$INDEX==x[1],"GROUP"]
|
||||
Type <- constMatrix[constMatrix$INDEX==x[1],"TYPE"]
|
||||
return(unlist(c(x,GROUP=Group,TYPE=Type)))
|
||||
})) %>% tbl_df() %>% arrange(TYPE,GROUP)
|
||||
|
||||
|
||||
groupIDs <- unique(OTF$GROUP)[-1]
|
||||
otfIndexes <- OTF$INDEX
|
||||
zeroIndexes <- OTF[OTF$GROUP==0,"INDEX"] %>% as.data.frame() %>% unlist()
|
||||
OTFzero <- OTF[OTF$GROUP==0,]
|
||||
OT0 <- constMatrix [constMatrix$INDEX %in% zeroIndexes,] %>%
|
||||
mutate(MIN=OTFzero$MIN,MAX=OTFzero$MAX)
|
||||
|
||||
sliced <- constMatrix %>%
|
||||
dplyr::filter(GROUP %in% groupIDs)
|
||||
OTbig <- rbind(OT0,sliced) %>% data.frame()
|
||||
parnumbers <- nrow(OTbig)
|
||||
|
||||
for(i in 1:parnumbers){
|
||||
if(OTbig[i,1] %in% otfIndexes){
|
||||
OTbig[i,3] <- OTF[OTF$INDEX==OTbig[i,1],2]
|
||||
OTbig[i,4] <- OTF[OTF$INDEX==OTbig[i,1],3]
|
||||
if(OTbig$Type[i]==2){
|
||||
OTbig$DEPENDENCE[i] <-2
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
summaries <- OTbig %>%
|
||||
group_by(TYPE,GROUP) %>%
|
||||
summarize(nGroup=n()) %>%
|
||||
select(nGroup,TYPE)
|
||||
return(list(Otable=OTbig,driver=summaries))
|
||||
|
||||
}
|
||||
20
RBBGCMuso/R/RcppExports.R
Normal file
20
RBBGCMuso/R/RcppExports.R
Normal file
@ -0,0 +1,20 @@
|
||||
# Generated by using Rcpp::compileAttributes() -> do not edit by hand
|
||||
# Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
|
||||
|
||||
randTypeOne <- function(m) {
|
||||
.Call('_RBBGCMuso_randTypeOne', 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)
|
||||
}
|
||||
|
||||
@ -7,7 +7,7 @@
|
||||
#' @param timee The required timesteps in the modell output. It can be "d", if it is daily, "m", if it's monthly, "y", it it is yearly
|
||||
#' @param debugging If it is TRUE, it copies the log file to a Log directory to store it, if it is stamplog it contatenate a number before the logfile, which is one more than the maximum of the represented ones in the LOG directory. If it is true or stamplog it collects the "wrong" logfiles
|
||||
#' @param keepEpc If TRUE, it keeps the epc file and stamp it, after these copies it to the EPCS directory. If debugging True or false, it copies the wrong epc files to the wrong epc directory.
|
||||
#' @param export if it is yes or you give a filename here, it converts the output to the specific extension. For example, if you set export to "example.csv", it converts the output to "csv", if you set it to "example.xls" it converts to example.xls with the xlsx package. If it is not installed it gives back a warning message and converts it to csv.
|
||||
#' @param export if it is yes or you give a filename here, it converts the ouxtput to the specific extension. For example, if you set export to "example.csv", it converts the output to "csv", if you set it to "example.xls" it converts to example.xls with the xlsx package. If it is not installed it gives back a warning message and converts it to csv.
|
||||
#' @param silent If you set it TRUE all off the modells output to the screen will be suppressed. It can be usefull, because it increases the model-speed.
|
||||
#' @param aggressive It deletes every possible modell-outputs from the previous modell runs.
|
||||
#' @param parameters In the settings variable you have set the row indexes of the variables, you wish to change. In this parameter you can give an exact value for them in a vector like: c(1,2,3,4)
|
||||
|
||||
121
RBBGCMuso/R/musoMonte.R
Normal file
121
RBBGCMuso/R/musoMonte.R
Normal file
@ -0,0 +1,121 @@
|
||||
musoMonte <- function(settings=NULL,
|
||||
parameters,
|
||||
inputDir = "./",
|
||||
outLoc = "./calib",
|
||||
iterations = 10,
|
||||
preTag = "mont-",
|
||||
inputName = paste0(pretag,"epcs.csv"),
|
||||
outputType = "moreCsv",
|
||||
fun=mean,
|
||||
varIndex=8,
|
||||
doSensitivity=FALSE,
|
||||
onDisk=FALSE,
|
||||
...){
|
||||
|
||||
currDir <- getwd()
|
||||
tmp <- file.path(outLoc,"tmp/")
|
||||
|
||||
if(!dir.exists(outLoc)){
|
||||
dir.create(outLoc)
|
||||
warning(paste(outLoc," is not exists, so it was created"))
|
||||
}
|
||||
|
||||
if(dir.exists(tmp){
|
||||
stop("There is a tmp directory inside the output location, please replace it. tmp is an important temporary directory for the function")
|
||||
}
|
||||
dir.create(tmp)
|
||||
inputFiles <- file.path(inputDir,grep(basename(outLoc),list.files(inputDir),invert = TRUE,value = TRUE))
|
||||
|
||||
|
||||
for(i in inputFiles){
|
||||
file.copy(i,tmp)
|
||||
}
|
||||
setwd(tmp)
|
||||
|
||||
if(is.null(settings)){
|
||||
settings <- setupMuso()
|
||||
}
|
||||
|
||||
parameterNames <- parameters[,1]
|
||||
parReal <- parameters[,-1]
|
||||
Otable <- OtableMaker(parReal)
|
||||
A <- as.matrix(Otable[[1]][,c(2,4,5,6)])
|
||||
B <- as.matrix(Otable[[2]])
|
||||
settings$calibrationPar <- A[,1]
|
||||
pretag <- file.path(outLoc,preTag)
|
||||
|
||||
##reading the original epc file at the specified
|
||||
## row numbers
|
||||
|
||||
origEpcFile <- readLines(settings$epcInput[2])
|
||||
|
||||
origEpc <- unlist(lapply(settings$calibrationPar, function (x) {
|
||||
as.numeric(unlist(strsplit(origEpcFile[x],split="[\t ]"))[1])
|
||||
}))
|
||||
|
||||
## Prepare the preservedEpc matrix for the faster
|
||||
## run.
|
||||
preservedEpc <- matrix(nrow = (iterations +1 ), ncol = length(settings$calibrationPar))
|
||||
preservedEpc[1,] <- origEpc
|
||||
colnames(preservedEpc) <- Otable[[1]][,1]
|
||||
|
||||
## Save the backupEpc, while change the settings
|
||||
## variable and set the output.
|
||||
file.copy(settings$epc[2],"savedEpc",overwrite = TRUE) # do I need this?
|
||||
pretag <- file.path(outLoc,preTag)
|
||||
|
||||
## Creating function for generating separate
|
||||
## csv files for each run
|
||||
a<-1:100000
|
||||
moreCsv <- function(){
|
||||
for(i in 1:iterations){
|
||||
parVar <- musoRandomizer(A,B)[,2]
|
||||
#preservedEpc[(i+1),] <- parVar
|
||||
exportName <- paste0(preTag,i,".csv")
|
||||
tryCatch (calibMuso(settings,debugging = "stamplog",
|
||||
parameters = parVar,export = exportName,
|
||||
keepEpc = TRUE),error=function(e) NA )
|
||||
}
|
||||
return(preservedEpc)
|
||||
}
|
||||
|
||||
## Creating function for generating one
|
||||
## csv files for each run
|
||||
|
||||
oneCsv <- function () {
|
||||
numDays <- settings$numdata[1]
|
||||
if(!onDisk){
|
||||
for(i in 1:iterations){
|
||||
|
||||
parVar <- apply(parameters,1,function (x) {
|
||||
runif(1, as.numeric(x[3]), as.numeric(x[4]))})
|
||||
preservedEpc[(i+1),] <- parVar
|
||||
exportName <- paste0(preTag,".csv")
|
||||
write.csv(parvar,"preservedEpc.csv",append=TRUE)
|
||||
calibMuso(settings,debugging = "stamplog",
|
||||
parameters = parVar,keepEpc = TRUE) %>%
|
||||
{mutate(.,iD = i)} %>%
|
||||
{write.csv(.,file=exportName,append=TRUE)}
|
||||
}
|
||||
|
||||
return(preservedEpc)
|
||||
} else {
|
||||
|
||||
}
|
||||
}
|
||||
|
||||
netCDF <- function () {
|
||||
stop("This function is not inplemented yet")
|
||||
}
|
||||
|
||||
## Call one function according to the outputType
|
||||
switch(outputType,
|
||||
"oneCsv" = (preservedEpc <- oneCsv()),
|
||||
"moreCsv" = (preservedEpc <- moreCsv()),
|
||||
"netCDF" = (preservedEpc <- netCDF()))
|
||||
|
||||
## Change back the epc file to the original
|
||||
|
||||
file.copy(savedEpc,settings$epc[2],overwrite = TRUE)
|
||||
write.csv(preservedEpc,"preservedEpc.csv")
|
||||
}
|
||||
123
RBBGCMuso/R/musoMonte.R~
Normal file
123
RBBGCMuso/R/musoMonte.R~
Normal file
@ -0,0 +1,123 @@
|
||||
musoMonte <- function(settings=NULL,parameters,
|
||||
inputDir = "./"
|
||||
outLoc = "./calib",
|
||||
iterations = 10,
|
||||
preTag = "mont-",
|
||||
inputName = paste0(pretag,"epcs.csv"),
|
||||
outputType = "moreCsv",
|
||||
fun=mean,
|
||||
varIndex=8,
|
||||
doSensitivity=FALSE,
|
||||
onDisk=FALSE,
|
||||
...){
|
||||
|
||||
currDir <- getwd()
|
||||
tmp <- file.path(outLoc,"tmp/")
|
||||
|
||||
if(!dir.exists(outLoc)){
|
||||
dir.create(outLoc)
|
||||
warning(paste(outLoc," is not exists, so it was created"))
|
||||
}
|
||||
|
||||
if(dir.exists(tmp){
|
||||
stop("There is a tmp directory inside the output location, please replace it. tmp is an important temporary directory for the function")
|
||||
}
|
||||
dir.create(tmp)
|
||||
|
||||
|
||||
inputFiles <- file.path(inputDir,grep(basename(outLoc),list.files(inputDir),invert = TRUE,value = TRUE))
|
||||
|
||||
|
||||
for(i in inputFiles){
|
||||
file.copy(i,tmp)
|
||||
}
|
||||
setwd(tmp)
|
||||
|
||||
if(is.null(settings)){
|
||||
settings <- setupMuso()
|
||||
}
|
||||
|
||||
parameterNames <- parameters[,1]
|
||||
parReal <- parameters[,-1]
|
||||
|
||||
|
||||
|
||||
##reading the original epc file at the specified
|
||||
## row numbers
|
||||
|
||||
origEpcFile <- readLines(settings$epcinput[2])
|
||||
origEpc <- unlist( lapply(parameters[,2], function (x) {
|
||||
as.numeric(unlist(strsplit(origEpcFile[x],split="[\t ]"))[1])
|
||||
}))
|
||||
|
||||
## Prepare the preservedEpc matrix for the faster
|
||||
## run.
|
||||
preservedEpc <- matrix(nrow = (iterations +1 ), ncol = nrow(parameters))
|
||||
preservedEpc[1,] <- origEpc
|
||||
colnames(preservedEpc) <- parameters[,1]
|
||||
|
||||
## Save the backupEpc, while change the settings
|
||||
## variable and set the output.
|
||||
file.copy(settings$epc[2],savedEpc,overwrite = TRUE) # do I need this?
|
||||
Otable <- OtableMaker(parReal)
|
||||
A <- as.matrix(Otable[[1]][,c(2,4,5,6)])
|
||||
B <- as.matrix(Otable[[2]])
|
||||
settings$calibrationpar <- A[,1]
|
||||
pretag <- file.path(outLoc,preTag)
|
||||
|
||||
## Creating function for generating separate
|
||||
## csv files for each run
|
||||
moreCsv <- function(){
|
||||
for(i in 1:iterations){
|
||||
|
||||
parVar <- apply(parameters,1,function (x) {
|
||||
runif(1, as.numeric(x[3]), as.numeric(x[4]))})
|
||||
preservedEpc[(i+1),] <- parVar
|
||||
exportName <- paste0(preTag,i,".csv")
|
||||
calibMuso(settings,debugging = "stamplog",
|
||||
parameters = parVar,export = exportName,
|
||||
keepEpc = TRUE)
|
||||
}
|
||||
return(preservedEpc)
|
||||
}
|
||||
|
||||
## Creating function for generating one
|
||||
## csv files for each run
|
||||
|
||||
oneCsv <- function () {
|
||||
numDays <- settings$numdata[1]
|
||||
if(!onDisk){
|
||||
for(i in 1:iterations){
|
||||
|
||||
parVar <- apply(parameters,1,function (x) {
|
||||
runif(1, as.numeric(x[3]), as.numeric(x[4]))})
|
||||
preservedEpc[(i+1),] <- parVar
|
||||
exportName <- paste0(preTag,".csv")
|
||||
write.csv(parvar,"preservedEpc.csv",append=TRUE)
|
||||
calibMuso(settings,debugging = "stamplog",
|
||||
parameters = parVar,keepEpc = TRUE) %>%
|
||||
{mutate(.,iD = i)} %>%
|
||||
{write.csv(.,file=exportName,append=TRUE)}
|
||||
}
|
||||
|
||||
return(preservedEpc)
|
||||
} else {
|
||||
|
||||
}
|
||||
}
|
||||
|
||||
netCDF <- function () {
|
||||
stop("This function is not inplemented yet")
|
||||
}
|
||||
|
||||
## Call one function according to the outputType
|
||||
switch(outputType,
|
||||
"oneCsv" = (preservedEpc <- oneCsv()),
|
||||
"moreCsv" = (preservedEpc <- moreCsv()),
|
||||
"netCDF" = (preservedEpc <- netCDF()))
|
||||
|
||||
## Change back the epc file to the original
|
||||
|
||||
file.copy(savedEpc,settings$epc[2],overwrite = TRUE)
|
||||
write.csv(preservedEpc,"preservedEpc.csv")
|
||||
}
|
||||
0
RBBGCMuso/R/package.R
Normal file
0
RBBGCMuso/R/package.R
Normal file
Binary file not shown.
17
RBBGCMuso/man/OtableMaker.Rd
Normal file
17
RBBGCMuso/man/OtableMaker.Rd
Normal file
@ -0,0 +1,17 @@
|
||||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/OtableMaker.R
|
||||
\name{OtableMaker}
|
||||
\alias{OtableMaker}
|
||||
\title{OtableMaker}
|
||||
\usage{
|
||||
OtableMaker(parametersReal)
|
||||
}
|
||||
\arguments{
|
||||
\item{paramsReal}{The matrix of the parameters}
|
||||
}
|
||||
\value{
|
||||
List of two matrices: A and B matrix for musoRandomizer
|
||||
}
|
||||
\description{
|
||||
This function is generating A and B table for musoRandomizer
|
||||
}
|
||||
@ -20,7 +20,7 @@ keepEpc=FALSE, export=FALSE, silent=FALSE, aggressive=FALSE, leapYear=FALSE)
|
||||
|
||||
\item{keepEpc}{If TRUE, it keeps the epc file and stamp it, after these copies it to the EPCS directory. If debugging True or false, it copies the wrong epc files to the wrong epc directory.}
|
||||
|
||||
\item{export}{if it is yes or you give a filename here, it converts the output to the specific extension. For example, if you set export to "example.csv", it converts the output to "csv", if you set it to "example.xls" it converts to example.xls with the xlsx package. If it is not installed it gives back a warning message and converts it to csv.}
|
||||
\item{export}{if it is yes or you give a filename here, it converts the ouxtput to the specific extension. For example, if you set export to "example.csv", it converts the output to "csv", if you set it to "example.xls" it converts to example.xls with the xlsx package. If it is not installed it gives back a warning message and converts it to csv.}
|
||||
|
||||
\item{silent}{If you set it TRUE all off the modells output to the screen will be suppressed. It can be usefull, because it increases the model-speed.}
|
||||
|
||||
|
||||
@ -4,7 +4,7 @@
|
||||
\alias{changemulline}
|
||||
\title{This is the function which is capable change multiple specific lines to other using their row numbers.}
|
||||
\usage{
|
||||
changemulline(filename, calibrationpar, contents)
|
||||
changemulline(filename, calibrationPar, contents)
|
||||
}
|
||||
\description{
|
||||
he function uses the previous changspecline function to operate.
|
||||
|
||||
17
RBBGCMuso/man/musoRandomizer.Rd
Normal file
17
RBBGCMuso/man/musoRandomizer.Rd
Normal file
@ -0,0 +1,17 @@
|
||||
% 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.
|
||||
}
|
||||
@ -4,55 +4,55 @@
|
||||
\alias{setupMuso}
|
||||
\title{setupMuso}
|
||||
\usage{
|
||||
setupMuso(executable=NULL, parallel = F, calibrationpar =c(1),
|
||||
outputloc=NULL, inputloc=NULL,
|
||||
metinput=NULL, CO2input=NULL,
|
||||
plantinput=NULL, thininput=NULL,
|
||||
mowinput=NULL, grazinput=NULL,
|
||||
harvinput=NULL, plouginput=NULL,
|
||||
fertinput=NULL, irrinput=NULL,
|
||||
nitinput=NULL, ininput=NULL, epcinput=NULL)
|
||||
setupMuso(executable=NULL, parallel = F, calibrationPar =c(1),
|
||||
outputLoc=NULL, inputLoc=NULL,
|
||||
metInput=NULL, CO2Input=NULL,
|
||||
plantInput=NULL, thinInput=NULL,
|
||||
mowInput=NULL, grazInput=NULL,
|
||||
harvInput=NULL, plougInput=NULL,
|
||||
fertInput=NULL, irrInput=NULL,
|
||||
nitInput=NULL, iniInput=NULL, epcInput=NULL)
|
||||
}
|
||||
\arguments{
|
||||
\item{executable}{This parameter stores the place of the modell-executable file. In normal usage, you don't have to be set this, because a RBBgcmuso package contains allways the latest modell executable. In spite of this, if you would like to use this package for modell development or just want to use different models (for example for comparison), you will find it useful}
|
||||
|
||||
\item{parallel}{Do you want to run multiple modell paralelly, if yes, set this variable to TRUE}
|
||||
|
||||
\item{calibrationpar}{You may want to change some parameters in your epc file, before you run the modell. You have to select the appropirate modell parameters. You can refence to these with the number of the line in the epc file where the variables are. It indexes from one. You should use a vector for this, like: c(1,5,8)}
|
||||
\item{calibrationPar}{You may want to change some parameters in your epc file, before you run the modell. You have to select the appropirate modell parameters. You can refence to these with the number of the line in the epc file where the variables are. It indexes from one. You should use a vector for this, like: c(1,5,8)}
|
||||
|
||||
\item{outputloc}{Where should the modell puts its outputs. You should give a location for it via this variable, for example: outputloc="/place/of/the/outputs/"}
|
||||
\item{outputLoc}{Where should the modell puts its outputs. You should give a location for it via this variable, for example: outputLoc="/place/of/the/outputs/"}
|
||||
|
||||
\item{inputloc}{Usually it is the root directory, where you put the inifiles for the modell}
|
||||
\item{inputLoc}{Usually it is the root directory, where you put the iniFiles for the modell}
|
||||
|
||||
\item{metinput}{Via metinput parameter, you can tell the modell where are the meteorological files. As default it reads this from the inifiles.}
|
||||
\item{metInput}{Via metInput parameter, you can tell the modell where are the meteorological files. As default it reads this from the iniFiles.}
|
||||
|
||||
\item{CO2input}{Via CO2 parameter, you can tell the modell where are the CO2 data files. As default it reads this from the inifiles.}
|
||||
\item{CO2Input}{Via CO2 parameter, you can tell the modell where are the CO2 data files. As default it reads this from the iniFiles.}
|
||||
|
||||
\item{plantinput}{Via planting parameter, you can tell the modell where are the data files, which contains the planting informations. As default it reads this from the inifiles.}
|
||||
\item{plantInput}{Via planting parameter, you can tell the modell where are the data files, which contains the planting informations. As default it reads this from the iniFiles.}
|
||||
|
||||
\item{thininput}{Via thining parameter, you can tell the modell where are the data files, which contains the thining informations. As default it reads this from the inifiles.}
|
||||
\item{thinInput}{Via thining parameter, you can tell the modell where are the data files, which contains the thining informations. As default it reads this from the iniFiles.}
|
||||
|
||||
\item{mowinput}{Via mowing parameter, you can tell the modell where are the data files, which contains the mowing informations. As default it reads this from the inifiles.}
|
||||
\item{mowInput}{Via mowing parameter, you can tell the modell where are the data files, which contains the mowing informations. As default it reads this from the iniFiles.}
|
||||
|
||||
\item{grazinput}{Via grazing parameter, you can tell the modell where are the data files, which contains the grazing informations. As default it reads this from the inifiles.}
|
||||
\item{grazInput}{Via grazing parameter, you can tell the modell where are the data files, which contains the grazing informations. As default it reads this from the iniFiles.}
|
||||
|
||||
\item{harvinput}{Via harvesting parameter, you can tell the modell where are the data files, which contains the harvesting informations. As default it reads this from the inifiles.}
|
||||
\item{harvInput}{Via harvesting parameter, you can tell the modell where are the data files, which contains the harvesting informations. As default it reads this from the iniFiles.}
|
||||
|
||||
\item{plouginput}{Via ploughing parameter, you can tell the modell where are the data files, which contains the ploughing informations. As default it reads this from the inifiles.}
|
||||
\item{plougInput}{Via ploughing parameter, you can tell the modell where are the data files, which contains the ploughing informations. As default it reads this from the iniFiles.}
|
||||
|
||||
\item{fertinput}{Via fertilizing parameter, you can tell the modell where are the fertilizing data files, which contains the fertilizing informations. As default it reads this from the inifiles.}
|
||||
\item{fertInput}{Via fertilizing parameter, you can tell the modell where are the fertilizing data files, which contains the fertilizing informations. As default it reads this from the iniFiles.}
|
||||
|
||||
\item{irrinput}{Via irrigation parameter, you can tell the modell where are the data files, which contains the irrigation informations. As default it reads this from the inifiles.}
|
||||
\item{irrInput}{Via irrigation parameter, you can tell the modell where are the data files, which contains the irrigation informations. As default it reads this from the iniFiles.}
|
||||
|
||||
\item{nitinput}{Via this parameter, you can tell the modell where are the NO2 data files. As default it reads this from the inifiles.}
|
||||
\item{nitInput}{Via this parameter, you can tell the modell where are the NO2 data files. As default it reads this from the iniFiles.}
|
||||
|
||||
\item{ininput}{Via this parameter, you can tell the modell where are the ini files. As default it reads this from the inifiles.}
|
||||
\item{iniInput}{Via this parameter, you can tell the modell where are the ini files. As default it reads this from the iniFiles.}
|
||||
|
||||
\item{epcinput}{Via this parameter, you can tell the modell where are the epc data files. As default it reads this from the inifiles.}
|
||||
\item{epcInput}{Via this parameter, you can tell the modell where are the epc data files. As default it reads this from the iniFiles.}
|
||||
}
|
||||
\value{
|
||||
The output is a the modell setting list wich contains the following elements:
|
||||
executable, calibrationpar, outputloc, outputname, inputloc, ininput, metinput, epcinput,thininput,CO2input, mowinput, grazinput, harvinput, plouginput, fertinput, irrinput, nitinput, inputfiles, numdata, startyear, numyears, outputvars
|
||||
executable, calibrationPar, outputLoc, outputName, inputLoc, iniInput, metInput, epcInput,thinInput,CO2Input, mowInput, grazInput, harvInput, plougInput, fertInput, irrInput, nitInput, inputFiles, numData, startyear, numYears, outputVars
|
||||
}
|
||||
\description{
|
||||
This funcion is fundamental for the BiomBGC-MuSo modell related functions like spinupMuso, normalMuso, rungetMuso, because it sets the modells environment.
|
||||
|
||||
BIN
RBBGCMuso/src/RBBGCMuso.so
Executable file
BIN
RBBGCMuso/src/RBBGCMuso.so
Executable file
Binary file not shown.
41
RBBGCMuso/src/RcppExports.cpp
Normal file
41
RBBGCMuso/src/RcppExports.cpp
Normal file
@ -0,0 +1,41 @@
|
||||
// Generated by using Rcpp::compileAttributes() -> do not edit by hand
|
||||
// Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
|
||||
|
||||
#include <Rcpp.h>
|
||||
|
||||
using namespace 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
|
||||
}
|
||||
// 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_randTypeOne", (DL_FUNC) &_RBBGCMuso_randTypeOne, 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);
|
||||
}
|
||||
BIN
RBBGCMuso/src/RcppExports.o
Normal file
BIN
RBBGCMuso/src/RcppExports.o
Normal file
Binary file not shown.
142
RBBGCMuso/src/musoRandomizer.cpp
Normal file
142
RBBGCMuso/src/musoRandomizer.cpp
Normal file
@ -0,0 +1,142 @@
|
||||
#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){
|
||||
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){
|
||||
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){
|
||||
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;
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
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;
|
||||
}
|
||||
BIN
RBBGCMuso/src/musoRandomizer.o
Normal file
BIN
RBBGCMuso/src/musoRandomizer.o
Normal file
Binary file not shown.
BIN
RBBGCMuso_0.4.0.0-2_R_x86_64-pc-linux-gnu.tar.gz
Normal file
BIN
RBBGCMuso_0.4.0.0-2_R_x86_64-pc-linux-gnu.tar.gz
Normal file
Binary file not shown.
142
musoRandomizer.cpp
Normal file
142
musoRandomizer.cpp
Normal file
@ -0,0 +1,142 @@
|
||||
#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){
|
||||
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){
|
||||
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){
|
||||
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;
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
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;
|
||||
}
|
||||
Loading…
Reference in New Issue
Block a user