RBBGCMuso 6 implementation

RBBGCMuso/DESCRIPTION

@@ -1,13 +1,13 @@
 Package: RBBGCMuso
 Title: An R package for BiomeBGC-MuSo ecosystem modelling
-Version: 0.6.3.0
+Version: 0.7.1
 Authors@R: person("Roland", "Hollo's", , "hollorol@gmail.com", role = c("aut", "cre"))
 Description: What the package does (one paragraph).
 Depends: R (>= 3.3.2)
 License: GPL-2
 LazyData: true
 NeedsCompilation: no
-Packaged: 2017-07-19 14:00:04 UTCs; hollorol
+Packaged:  Wed 13 Nov 2019 02:41:52 PM CET hollorol
 Author: Roland Hollo's [aut, cre]
 Imports:
 	grDevices,
@@ -23,7 +23,8 @@ Imports:
 	tibble,
 	tidyr,
 	tcltk,
-	digest
+	digest,
+    jsonlite
 LinkingTo: Rcpp
 SystemRequirements: C++11
 Maintainer: Roland Hollo's <hollorol@gmail.com>

RBBGCMuso/R/atStart.R

@@ -0,0 +1,31 @@
+.onLoad <- function(libname,pkgname){
+    print("This is RBBGCMuso version 0.7")
+    RMuso_version <- 6 
+    RMuso_constMatrix <- list(epc=NULL,soil=NULL) 
+    RMuso_varTable <- list()
+    #___________________________
+    sapply(names(RMuso_constMatrix),function(fType){
+        sapply(list.files(path=system.file("data",package="RBBGCMuso"),
+                          pattern=sprintf("^%sConstMatrix\\d\\.json$",fType), full.names=TRUE),function(fName){
+            constMatrix <- jsonlite::read_json(fName,simplifyVector = TRUE)[,c(1,2,3,4,9,5,6,7,8)]
+            version <- gsub(".*(\\d)\\.json","\\1",fName)
+            RMuso_constMatrix[[fType]][[version]] <<- constMatrix
+        })
+        RMuso_constMatrix
+        # RMuso_constMatrix <<- RMuso_constMatrix 
+    })
+
+
+        sapply(list.files(path=system.file("data",package="RBBGCMuso"),
+                          pattern="^varTable\\d\\.json$", full.names=TRUE),function(fName){
+            varTable <- jsonlite::read_json(fName,simplifyVector = TRUE)
+            version <- gsub(".*(\\d)\\.json","\\1",fName)
+            RMuso_varTable[[version]] <<- varTable
+        })
+
+
+    options(RMuso_version=RMuso_version,
+            RMuso_constMatrix=RMuso_constMatrix,
+            RMuso_varTable=RMuso_varTable)
+    # getOption("RMuso_constMatrix")$soil[[as.character(getOption("RMuso_version"))]]
+}

RBBGCMuso/R/calibMuso.R

@@ -103,11 +103,11 @@ calibMuso <- function(settings=NULL, calibrationPar=NULL,
 
     if(!modifyOriginal & (!is.null(parameters) | !is.null(outVars)))
     {
-        
+       # browser() 
         toModif <- sapply(toModif, function (x){
             paste0(tools::file_path_sans_ext(basename(x)),"-tmp.",tools::file_ext(x))
         })
-        
+       toModif[[1]] <- file.path(dirname(epc[2]),toModif[[1]])
     }
     
     ##change the epc file if and only if there are given parameters
@@ -119,15 +119,18 @@ calibMuso <- function(settings=NULL, calibrationPar=NULL,
 
     ##We change the working directory becase of the model, but we want to avoid sideeffects, so we save the current location and after that we will change everything to it.
     if(!modifyOriginal & (!is.null(parameters) | !is.null(outVars))){
+        # browser()
     epc[2]<-file.path(dirname(epc[2]),toModif[1]) # Writing back the lost path
     toModif[2]<-file.path(dirname(iniInput[2]),toModif[2]) #for the Initmp, also
     if((!is.null(outVars) | !file.exists(toModif[2])) & !modifyOriginal){
+        # browser()
         file.copy(iniInput[2],toModif[2],overwrite = TRUE)
     }
 
     iniInput[2] <- toModif[2]}
 
     if(!is.null(parameters) & ((fileToChange == "epc") | (fileToChange == "both")) & !modifyOriginal){
+        # browser()
         tmp<-readLines(iniInput[2])
         tmpInd<-grep("EPC_FILE",tmp)+1
         tmp[tmpInd]<-file.path(dirname(tmp[tmpInd]),basename(epc[2]))

RBBGCMuso/R/changeMuso.R

@@ -27,7 +27,7 @@ changemulline <- function(filePaths, calibrationPar, contents, fileOut, fileToCh
 
     if(fileToChange == "epc" | fileToChange == "ini"){
         parMat<-cbind(calibrationPar, contents)
-        parMat[order(parMat[,1]),]
+        parMat <- parMat[order(parMat[,1]),]
         changeMusoC(inFile = filePaths[selectFileToWrite(filePaths, fileToChange)],
                     outFile = fileOut[selectFileToWrite(filePaths, fileToChange)],
                     parMat)
@@ -36,9 +36,9 @@ changemulline <- function(filePaths, calibrationPar, contents, fileOut, fileToCh
     if(fileToChange == "both"){
         parMat<-list()
         parMat[[1]]<-cbind(calibrationPar[[1]], contents[[1]])
-        parMat[[1]][order(parMat[[1]][,1]),]
+        parMat[[1]]<- parMat[[1]][order(parMat[[1]][,1]),]
         parMat[[2]]<-cbind(calibrationPar[[2]], contents[[2]])
-        parMat[[2]][order(parMat[[2]][,1]),]
+        parmat[[2]]<- parMat[[2]][order(parMat[[2]][,1]),]
         
         changeMusoC(filePaths[1],fileOut[1],parMat[[1]] )
         changeMusoC(filePaths[2],fileOut[2],parMat[[2]] )

RBBGCMuso/R/musoMonte.R

@@ -93,10 +93,10 @@ musoMonte <- function(settings=NULL,
     ##reading the original epc file at the specified
     ## row numbers
     if(iterations < 3000){
-        randVals <- musoRand(parameters = parameters,constrains = constrains, iterations = 3000)
+        randVals <- musoRand(parameters = parameters,fileType="epc", iterations = 3000)
         randVals[[2]]<- randVals[[2]][sample(1:3000,iterations),]
     } else {
-        randVals <- musoRand(parameters = parameters,constrains = constrains, iterations = iterations)
+        randVals <- musoRand(parameters = parameters,fileType="epc", iterations = iterations)
     }
     
     origEpc <- readValuesFromEpc(settings$epc[2],parameters[,2])
@@ -129,7 +129,7 @@ musoMonte <- function(settings=NULL,
         }
             
         tmp2 <- numeric(numVars)
-
+# browser()
         for(j in 1:numVars){
             tmp2[j]<-funct[[j]](origModellOut[,j])
         }
@@ -138,19 +138,19 @@ musoMonte <- function(settings=NULL,
         for(i in 2:(iterations+1)){
             tmp <- tryCatch(calibMuso(settings = settings,
                              parameters = randValues[(i-1),],
-                             silent= TRUE,
+                             silent= FALSE,
                              skipSpinup = skipSpinup,
                              keepEpc = keepEpc,
                              debugging = debugging,
                              outVars = outVars), error = function (e) NA)
             
-            if(!is.na(tmp)){
+            if(length(dim(tmp))>=1){
                 for(j in 1:numVars){
                     tmp2[j]<-funct[[j]](tmp[,j])
                 }
             } else {
                 for(j in 1:numVars){
-                    tmp2[j]<-rep(NA,length(settings$outputVars[[1]]))
+                    tmp2[j]<-NA
                 }
             }
 

RBBGCMuso/R/musoRand.R

@@ -8,9 +8,11 @@
 #' @importFrom limSolve xsample
 #' @export
 
-musoRand <- function(parameters, constrains = NULL, iterations=3000){
-
-    if(!is.null(constrains)){
+musoRand <- function(parameters, iterations=3000, fileType="epc", constrains = NULL){
+    if(is.null(constrains)){
+        constMatrix <- constrains
+        constMatrix <- getOption("RMuso_constMatrix")[[fileType]][[as.character(getOption("RMuso_version"))]]
+    } else {
         constMatrix <- constrains
     }
     
@@ -28,7 +30,7 @@ musoRand <- function(parameters, constrains = NULL, iterations=3000){
 	constMatrix <- constMatrix[order(apply(constMatrix[,7:8],1,function(x){x[1]/10+abs(x[2])})),]
 	constMatrix
     }
-
+    # browser()
     genMat0 <- function(dep){
 	numberOfVariable <- nrow(dep)
 	G <- rbind(diag(numberOfVariable), -1*diag(numberOfVariable))
@@ -54,7 +56,7 @@ musoRand <- function(parameters, constrains = NULL, iterations=3000){
 	    }
 
 	}
-
+# browser()
 	G<-G[dep[,4]!=0,]
         
         if(is.null(nrow(G))){
@@ -148,6 +150,7 @@ musoRand <- function(parameters, constrains = NULL, iterations=3000){
     dependences <- depTableMaker(constMatrix, parameters)
     dependences <- cbind(dependences,1:nrow(dependences))
     colnames(dependences)[ncol(dependences)] <- "rowIndex"
+    # browser()
     numberOfVariable <- nrow(dependences)
     nonZeroDeps<-dependences[dependences[,"TYPE"]!=0,]
     if(nrow(nonZeroDeps)!=0){
@@ -171,6 +174,7 @@ musoRand <- function(parameters, constrains = NULL, iterations=3000){
         h <- c(Gh0$h,h)
         E <- do.call(rbind,lapply(Ef,function(x){x$E}))
         f <- do.call(c,lapply(Ef,function(x){x$f}))
+        # browser()
         randVal <- suppressWarnings(limSolve::xsample(G=G,H=h,E=E,F=f,iter = iterations))$X
     } else{
         Gh0<-genMat0(dependences)

RBBGCMuso/R/outputMapping.R

@@ -29,7 +29,8 @@ updateMusoMapping<-function(output_map_init="output_map_init.c"){
 #' @usage musoMapping(code, mapData=NULL)
 
 
-musoMapping <- function(code, mapData=NULL){
+musoMapping <- function(code,
+                        mapData=getOption("RMuso_varTable")[[as.character(getOption("RMuso_version"))]]){
     if(is.null(mapData)){
         return(unlist(mMapping[which(mMapping[,1]==code),2])) #mMapping is package-scoped system variable generated by udateMusoMapping
     } else {
@@ -48,7 +49,8 @@ musoMapping <- function(code, mapData=NULL){
 #' @usage musoMapping(code, mapData=NULL)
 
 
-musoMappingFind <- function(variable=NULL){
+musoMappingFind <- function(variable=NULL,
+                            mMapping=getOption("RMuso_varTable")[[as.character(getOption("RMuso_version"))]]){
     if(is.null(variable)){
         return(mMapping)
     } else {

RBBGCMuso/R/setupMuso.R

@@ -55,44 +55,45 @@ setupMuso <- function(executable=NULL,
                       epcInput=NULL,
                       mapData=NULL,
                       leapYear=FALSE,
-                      version=5,
+                      version=6,
                       doCopy=TRUE
                       ){
 
     Linuxp <-(Sys.info()[1]=="Linux")
     writep <- 0
 
-    if(is.null(mapData)&version==4){
-        mData <- mMapping4
-    }
+    # 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"] <- file.path(inputLoc,inputParser(string=grepString,fileName=iniFiles$spinup,counter=1,value=TRUE))
-                tempVar["normal"] <- file.path(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)
-    }
+    # outMaker <- function(inputVar,grepString,filep){
+    #     tempVar <- eval(parse(text=inputVar))
+    #     if(is.null(tempVar)){
+    #         writep <<- writep+1
+    #         if(filep)
+    #         {
+    #             tempVar["spinup"] <- file.path(inputLoc,inputParser(string=grepString,fileName=iniFiles$spinup,counter=1,value=TRUE))
+    #             tempVar["normal"] <- file.path(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<- normalizePath("./")
@@ -126,12 +127,12 @@ setupMuso <- function(executable=NULL,
 
 
     
-    inputs <- lapply(1:nrow(grepHelper), function (x) {
-
-        outMaker(grepHelper[x,1],grepHelper[x,2],grepHelper[x,3])
-        
-    })   
-    names(inputs) <- grepHelper$inputVar   
+    # 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  
@@ -150,36 +151,38 @@ setupMuso <- function(executable=NULL,
    # return(inputs) debug element 
 
     
-    if(is.null(mapData)){
-        
+    # if(is.null(mapData)){
+    #     
         outIndex<-grep("DAILY_OUTPUT",iniFiles[[2]])+1
         numVar<-as.numeric(unlist(strsplit(iniFiles[[2]][outIndex],"[\ \t]"))[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\"")    
         })
-        dailyVarnames<-lapply(dailyVarCodes, function(x) musoMapping(unlist(strsplit(x,"[\ \t]"))[1]))
+        dailyVarnames<-unlist(lapply(dailyVarCodes, function(x) musoMapping(unlist(strsplit(x,"[\ \t]"))[1])))
 
         outIndex<-grep("ANNUAL_OUTPUT",iniFiles[[2]])+1
         numVar<-as.numeric(unlist(strsplit(iniFiles[[2]][outIndex],"[\ \t]"))[1])
         annualVarCodes<-iniFiles[[2]][(outIndex+1):(outIndex+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))
+        annualVarnames<-unlist(lapply(annualVarCodes, function(x) musoMapping(unlist(strsplit(x,"[\ \t]"))[1])))
         outputVars<-list(dailyVarnames,annualVarnames)
-
-
-                                                          
-                                                      }
+        # browser()
+# } 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)
+#
+#
+#                                                           
+#                                                       }
     
     
     
@@ -223,12 +226,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]])+2],"[\ \t]"))[1])
+    numYears <-  as.numeric(unlist(strsplit(iniFiles[[2]][grep("TIME_DEFINE",iniFiles[[2]])+1],"[\ \t]"))[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 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]])+3],"[\ \t]"))[1])
+    startYear <- as.numeric(unlist(strsplit(iniFiles[[2]][grep("TIME_DEFINE",iniFiles[[2]])+2],"[\ \t]"))[1])
     numData[1] <- numValues * sumDaysOfPeriod(startYear,numYears,corrigated=leapYear)
 
     numData[2] <- numYears * numValues*12
@@ -250,38 +253,53 @@ setupMuso <- function(executable=NULL,
     ## I use file.path additionally because We do not know if outputLoc ends or not to "/"
     suppressWarnings(file.remove(paste0(file.path(outputLoc,outputName[2]),".log")))
  
+    searchBellow <- function(inFile, key, stringP = TRUE,  n=1, management = FALSE){
+        
+            if(stringP){
+                unlist(strsplit(inFile[grep(key,inFile,perl=TRUE)+n],split = "\\s+"))[1]
+            } else {
+                as.numeric(unlist(strsplit(inFile[grep(key,inFile,perl=TRUE)+n],split = "\\s+"))[1])
+            }
+    }
+    soilFile <- NULL
+    if(version >=6){
+        soilFiles <- tryCatch(sapply(iniFiles,function(x){(searchBellow(x,"SOIL_FILE"))}),error = function(e){""})
+    }
+    epcFiles <- tryCatch(sapply(iniFiles,function(x){(searchBellow(x,"EPC_FILE"))}),error = function(e){""}) 
+    
     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,
+                    # metInput=inputs$metInput,
+                    epcInput=epcFiles,
+                    # 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,
+                    soilFile=soilFiles,
                     dailyVarCodes= gsub("\\s.*","",dailyVarCodes),
                     annualVarCodes = gsub("\\s.*","",annualVarCodes)
                     )
     
-    if(writep!=nrow(grepHelper)){
-        writeLines(iniFiles[[1]],iniInput[[1]])
-        if(inputs$epcInput[1]!=inputs$epc$Input[2]){ #Change need here
-            writeLines(iniFiles[[2]],iniInput[[2]])      
-        }
-    }
+    # if(writep!=nrow(grepHelper)){
+    #     writeLines(iniFiles[[1]],iniInput[[1]])
+    #     if(inputs$epcInput[1]!=inputs$epc$Input[2]){ #Change need here
+    #         writeLines(iniFiles[[2]],iniInput[[2]])      
+    #     }
+    # }
     return(settings)
 
 }