agroMoGridUI <- function(id){
ns <- NS(id)
tags$div(id = ns(id),
tags$div(
id = paste0(ns("ensclim"),"_container"),
checkboxInput(ns("ensclim"), label = "ensemble", value = FALSE)
),
tags$div(
id =paste0(ns("ensalg"),"_container"),
checkboxInput(ns("ensalg"), label = "ensemble", value = FALSE)
),
tags$div(
id =paste0(ns("dailyout"),"_container"),
checkboxInput(ns("dailyout"), label = "daily outputs", value = TRUE)
),
tags$div(
id =paste0(ns("enssoil"),"_container"),
checkboxInput(ns("enssoil"), label = "ensemble", value = FALSE)
),
tags$div(
id =paste0(ns("repcheck"),"_container"),
checkboxInput(ns("repcheck"), label = "show and save", value = TRUE)
),
tags$div(
id =paste0(ns("annual"),"_container"),
checkboxInput(ns("annual"), label = "annual outputs", value = TRUE)
),
tags$div(
id = paste0(ns("gridres"),"_container"),
selectInput(ns("gridres"),"GRID RESOLUTION:",choices = c("10×10 km"))
),
tags$div(
id = paste0(ns("climproj"),"_container"),
selectInput(ns("climproj"),"CLIMATE DATABASE:",NA)
),
tags$div(
id = paste0(ns("soildb"),"_container"),
selectInput(ns("soildb"),"SOIL DATABASE:",NA)
),
tags$div(
id = paste0(ns("algosel"),"_container"),
selectInput(ns("algosel"),"ALGORYTHM SELECTION:",choices=c(
"PHOTOS: Farquhar | PET: Penman-Monteith | WSTRESS: TransDemBased",
"PHOTOS: Farquhar | PET: Penman-Monteith | WSTRESS: WCBased",
"PHOTOS: Farquhar | PET: Priestley-Taylor | WSTRESS: WCBased",
"PHOTOS: Farquhar | PET: Priestley-Taylor | WSTRESS: TransDemBased ",
"PHOTOS: DSSAT | PET: Penman-Monteith | WSTRESS: WCBased",
"PHOTOS: DSSAT | PET: Priestley-Taylor | WSTRESS: WCBased",
"PHOTOS: DSSAT | PET: Penman-Monteith | WSTRESS: TransDemBased",
"PHOTOS: DSSAT | PET: Priestley-Taylor | WSTRESS: TransDemBased"
))
),
tags$div(
id = paste0(ns("story"),"_container"),
selectInput(ns("story"),"STORYLINE:",choices=c(""))
),
tags$div(
id = paste0(ns("outsq"),"_container"),
textInput(ns("outsq"),"OUTPUT DATA TABLE:",NA)
),
tags$div(
id = paste0(ns("alias"),"_container"),
textOutput(ns("alias"))
),
tags$div(
id = paste0(ns("queryalias"),"_container"),
textInput(ns("queryalias"), "QUERY ALIAS:",NA)
),
tags$div(
id = paste0(ns("metadata"),"_container"),
textInput(ns("metadata"), "DESCRIPTION:",NA)
),
tags$div(
id = paste0(ns("climprojquery"),"_container"),
selectInput(ns("climprojquery"),"CLIMATE PROJECTION FOR QUERY:",NA)
),
tags$div(
id = paste0(ns("algselquery"),"_container"),
selectInput(ns("algselquery"),"ALGORYTHM SELECTION FOR QUERY:",NA)
),
tags$div(id = ns("Buttons"),
actionButton(ns("StartSim"),label = "START SIMULATION"),
actionButton(ns("RunQuery"),label = "QUERY"),
actionButton(ns("Report"),label = "REPORT"),
actionButton(ns("Map"),label="MAP")),
tags$div(
id = paste0(ns("time"),"_container"),
selectInput(ns("time"),"[start-end]:",choices=c(""))
),
tags$div(
id = paste0(ns("until"),"_container"),
selectInput(ns("until"),"-",choices=c(""))
),
do.call(tagList,(
lapply(1:9,function(x){
tags$div(
id= ns(sprintf("sqlfunc_%s_container",x)),
selectInput(ns(sprintf("sqlfunc_%s",x)),sprintf("{%s}:",x),choices=c("NA"))
)
})
)),
tags$div(id="query","QUERIES:"),
tags$div(
tableOutput(ns("queryTable"))
)
,
tags$script(HTML( sprintf(
"
$('#%s').on('click','td', function(){
$('#%s td').removeClass();
$(this).toggleClass('griddiv-selected-vars');
let selections = getIndexesForSelection('#%s','.griddiv-selected-vars');
if(selections.length <= 5){
Shiny.onInputChange('%s',selections);
} else {
$(this).toggleClass('griddiv-selected-vars');
}
// console.log(getIndexesForSelection('.showdiv-selected-vars'))
})
",ns("queryTable"),ns("queryTable"),ns("queryTable"),ns("queryList"))
)),
tags$script(HTML("
Shiny.addCustomMessageHandler('refreshSelected',function(message){
$('#griddiv-queryTable tr:nth-child('+Number(message.indexOfQuery)+')').html(message.querySentence);
}
)
"))
)
}
#' agromoGrid
#'
#' This is agromoGrid main function
#' @importFrom jsonlite read_json
#' @importFrom parallel detectCores makeCluster stopCluster
#' @importFrom doSNOW registerDoSNOW
#' @importFrom foreach foreach %dopar%
#' @importFrom DBI dbExecute dbGetQuery dbConnect dbDisconnect
#' @importFrom openxlsx write.xlsx
agroMoGrid <- function(input, output, session, baseDir, language){
ns <- session$ns
dat <- reactiveValues(storyVars=NULL,
storyCSV=NULL,
storyTimeRange=NULL,
jsonList=NULL,
storyFiles=list(),
queryNames=NULL,
jsonOptions=NULL,
jsonNumbers=NULL,
querySelector=NULL,
queries=NULL,
language="en",
weatherOptions=NULL,
soilOptions=NULL)
observe({
if(!is.null(language())){
dat$language <- language()
}
})
vari <- reactiveValues()
toreturn <- reactiveValues(showMap=NULL)
observe({
dat$jsonList <- lapply((list.files(path=file.path(baseDir(),"template/grid"),pattern="*.json", full.names=TRUE)),read_json)
dat$queryNames <- sapply(dat$jsonList,function(x) x$Names[[dat$language]])
dat$queries <- sapply(dat$jsonList,function(x) x$query)
dat$replNumbers <- lapply(dat$queryNames,getReplacementNumbers)
dat$firstOptions <- lapply(dat$jsonList,function(x) {unlist(lapply(x$optionAlias[[dat$language]],function(y){y[1]}))})
dat$querySelector <- as.data.frame(colorReplacements(unlist(lapply(seq_along(dat$replNumbers),function(i){
# if(i==8) browser()
interpolateInto(dat$replNumbers[[i]],dat$firstOptions[[i]],dat$queryNames[i])
}))),stringsAsFactors=FALSE)
})
# observe({
# dat$querySelector <- as.data.frame(colorReplacements(dat$queryNames),stringsAsFactors=FALSE)
# })
#dat[["dataenv"]] <-readRDS("output/outputs.RDS")
# queryNames <- ls(dat$dataenv)
observe({
dat$storyFiles <- grep(".*\\.story",list.files(file.path(baseDir(),"input","storyline"), full.names=TRUE), value=TRUE)
dat$storyOptions <- tools::file_path_sans_ext(basename(dat$storyFiles))
updateSelectInput(session,"story",choices=dat$storyOptions)
})
observe({
projections <- basename(list.dirs(file.path(baseDir(),"input/weather/grid"))[-1])
if(length(projections)!=0){
updateSelectInput(session,"climproj",choices=projections)
dat$weatherOptions <- projections
}
})
observe({
soils <- basename(list.dirs(file.path(baseDir(),"input/soil/grid"))[-1])
if(length(soils)!=0){
updateSelectInput(session,"soildb",choices=soils)
dat$soilOptions <- soils
}
})
observeEvent(input$annual,{
if(input$story!=""){
choosenStoryFile <- dat$storyFiles[match(input$story,dat$storyOptions)]
skip <- ifelse(isolate(input$annual),2,1)
dat$storyVars <- as.character(read.table(choosenStoryFile,skip=1, nrows=1, sep=";",stringsAsFactors=FALSE))
}
})
observeEvent(input$story,{
if(input$story!=""){
# browser()
choosenStoryFile <- dat$storyFiles[match(input$story,dat$storyOptions)]
suppressWarnings(dir.create(file.path(baseDir(),"output/grid/",input$story)))
suppressWarnings(dir.create(file.path(baseDir(),"endpoint/grid/",input$story)))
output$alias <- renderText({readLines(choosenStoryFile,n=1)})
skip <- ifelse(isolate(input$annual),2,1)
dat$storyVars <- as.character(read.table(choosenStoryFile,skip=skip, nrows=1, sep=";",stringsAsFactors=FALSE))
dat$storyCSV <- read.table(choosenStoryFile,skip=3, sep=";",stringsAsFactors=FALSE)
dat$storyTimeRange <- range(dat$storyCSV[,c(3,4)])
storyRow <- as.data.frame((function(x){
list(site=x[,1],
name=apply(x,1,function(y){paste(y[1:2],collapse="_")}),
startYear=x[,3],
endYear=x[,4],
numDays=365*(x[,4]-x[,3]+1))
})(dat$storyCSV),stringsAsFactor=FALSE)
inF <- readLines(file.path(baseDir(),
"input/initialization/grid",
input$story,
paste0(storyRow[1,"name"],".ini")))
weather <- basename(dirname(inF[4]))
soil <- basename(dirname(inF[39]))
if(is.element(weather,dat$weatherOptions)){
updateSelectizeInput(session,"climproj",choices=unique(dat$weatherOptions),selected=weather)
} else {
showNotification("Climate file directory (defined in storyLine) not found",type="error")
}
if(is.element(soil,dat$soilOptions)){
updateSelectizeInput(session,"soildb",choices=unique(dat$soilOptions),selected=soil)
} else {
showNotification("Soil file directory (defined in storyLine) not found",type="error")
}
dat$story <-split(storyRow,storyRow$site)
}
})
observe({
dbDir <- file.path(baseDir(),"output")
dir.create(dbDir, showWarnings=FALSE)
if(dir.exists(dbDir)){
sqlDB <- DBI::dbConnect(RSQLite::SQLite(),file.path(dbDir,"grid.db"))
dat[["modelOutputs"]] <-grep("_error$",dbListTables(sqlDB),invert=TRUE,value=TRUE)
dbDisconnect(sqlDB)
}
})
observeEvent(input$time,{
if(input$time!=""){
maxYear <- dat$jsonList[[input$queryList]]$timeFrame$max
updateSelectInput(session,"until",choices=input$time:maxYear, selected=maxYear)
}
})
observe({
if(!is.null(input$queryList)){
a <- dat$queryNames
sapply(1:9,function(x){
choices <- unlist(dat$jsonList[[input$queryList]]$optionAlias[[dat$language]][[as.character(x)]], use.names=TRUE)
if(is.null(choices)){
choices <- "NA"
}
if(grepl("\\*.*\\*",choices[1])){
starVar <- gsub("\\*(.*)\\*","\\1",choices[1])
choices <- eval(parse(text=sprintf("%s_get(baseDir())",starVar))) # Evaluate starVar void function. These are defined at the bottom of this file.
vari[[starVar]] <- choices # Evaluate starVar void function. These are defined at the bottom of this file.
}
updateSelectInput(session,sprintf("sqlfunc_%s",x),
choices=choices)
})
minYear <- dat$jsonList[[input$queryList]]$timeFrame$min
maxYear <- dat$jsonList[[input$queryList]]$timeFrame$max
updateSelectInput(session,"time",choices=minYear:maxYear, selected=minYear)
updateSelectInput(session,"until",choices=minYear:maxYear, selected=maxYear)
}
})
observe({
inputs <- sapply(1:9,function(x){input[[sprintf("sqlfunc_%s",x)]]})
if(!is.null(isolate(input$queryList))){
indexOfQuery <- isolate(input$queryList)
newQuerySentence <- interpolateInto(seq_along(isolate(dat$replNumbers[[indexOfQuery]])),
inputs[seq_along(isolate(dat$replNumbers[[indexOfQuery]]))]
,isolate(dat$queryNames)[indexOfQuery])
if((input$time!="")&&(input$until!="")){
newQuerySentence <- gsub("\\[T-T\\]",sprintf("[%s-%s]",input$time,input$until),newQuerySentence)
}
newQuerySentence <- sprintf("<td class=\"griddiv-selected-vars\">%s</td>",colorReplacements(newQuerySentence))
session$sendCustomMessage("refreshSelected",list(indexOfQuery=indexOfQuery, querySentence=newQuerySentence))
}
})
observe({
output$queryTable <- renderTable(dat$querySelector,colnames=FALSE,width="100%", sanitize.text.function = function(x) x )
})
observeEvent(input$RunQuery,{
queryIndex <- input$queryList
if(!identical(queryIndex, NULL) && !identical(input$queryalias, "")){
sqlSentence <- dat$queries[input$queryList]
optionList <- sapply(1:9,function(x){input[[sprintf("sqlfunc_%s",x)]]}) # These are just the optionAliaces
possibilities <- lapply(dat$jsonList[[queryIndex]]$optionAlias[[dat$language]],unlist)
optionList <- optionList[optionList!="NA"]
selectedNum <- (sapply(seq_along(optionList),function(i){match(optionList[i],possibilities[[i]])}))
datoptions <- lapply(dat$jsonList[[queryIndex]]$options,unlist)
#BUGGER!!!!!!!!!!!!!!!!!!!!!!!!!!!!
textContent <- sapply(seq_along(selectedNum),function(i){
if(is.na(selectedNum[i])){
input[[sprintf("sqlfunc_%s",i)]]
} else {
datoptions[[i]][selectedNum[i]]
}
})
sentenceToSQL <- interpolateInto(dat$replNumbers[[input$queryList]],textContent,sqlSentence,TRUE)
sentenceToSQL <- gsub("\\[T1\\]",sprintf("%s",input$time),sentenceToSQL)
sentenceToSQL <- gsub("\\[T2\\]",sprintf("%s",input$until),sentenceToSQL)
writeLines(c(sprintf("/*%s*/",input$metadata),"\n\n",sentenceToSQL),file.path(baseDir(),"output/query",sprintf("%s.sql",input$queryalias)))
outputDB <- file.path(baseDir(),"output")
dbDir <- file.path(baseDir(),"database")
sqlDB <- DBI::dbConnect(RSQLite::SQLite(),file.path(outputDB,"grid.db"))
# browser()
showNotification("Attaching Soil database...")
soilDBName <- file.path(normalizePath(dbDir),"soil.db")
observationDBName <- file.path(normalizePath(dbDir),"observation.db")
if(file.exists(soilDBName)){
dbExecute(sqlDB,sprintf("ATTACH DATABASE '%s' AS soil",soilDBName))
} else {
showNotification("Cannot find soil database, queries which contains soil data will not run",type="warning")
}
showNotification("Attaching climate database...")
weatherDBName <- file.path(normalizePath(dbDir),"climate.db")
if(file.exists(weatherDBName)){
dbExecute(sqlDB,sprintf("ATTACH DATABASE '%s' AS climate", weatherDBName))
} else {
showNotification("Cannot find weather database, queries which contains weather data will not run",type="warning")
}
if(file.exists(observationDBName)){
dbExecute(sqlDB,sprintf("ATTACH DATABASE '%s' AS observation",observationDBName))
} else {
showNotification("Cannot find observation database, queries which contains soil data will not run",type="warning")
}
showNotification("Attaching econo database...")
econoDBName <- file.path(normalizePath(dbDir),"economy.db")
if(file.exists(econoDBName)){
dbExecute(sqlDB,sprintf("ATTACH DATABASE '%s' AS economy", econoDBName))
} else {
showNotification("Cannot find economy database, queries which contains economy data will not run",type="warning")
}
showNotification("Running the query, please wait, it can take for a while", id="query", duration=NULL)
queryResults <- tryCatch(dbGetQuery(sqlDB,sentenceToSQL),error=function(e){NULL})
if(is.null(queryResults)){
showNotification("Something went wrong with the query...",type="error")
} else {
errorTables <- unlist(lapply(seq_along(dat$jsonList[[queryIndex]]$options),function(i){
if(length(dat$jsonList[[queryIndex]]$options[[i]])!=0){
if(dat$jsonList[[queryIndex]]$options[[i]][1]=="*tables*"){
paste0(textContent[i],"_error")
}
}}))
errorColumns <- lapply(errorTables,function(tableName){
dbGetQuery(sqlDB,sprintf("SELECT * FROM %s",tableName))
})
#doing a left outer join, the reduce part ads the columns
finalDF <- tryCatch(merge((Reduce(function(x,y){x$error <- x$error+y$error; return(x)},errorColumns)),
queryResults,by.x="site",by.y="cell_id",all.x=TRUE),
error=function(e){cbind.data.frame(queryResults[,1],0,queryResults[,2])})
colnames(finalDF) <- c("cell_id","error","value")
write.csv(finalDF,file.path(baseDir(),"output/map_data",sprintf("%s.csv",input$queryalias)),row.names=FALSE)
}
removeNotification("query")
dbDisconnect(sqlDB)
} else {
showNotification("You should choose one query and provide an alias", duration=NULL)
}
})
observeEvent(input$Report,{
queryIndex <- input$queryList
if(!is.null(queryIndex)){
sqlSentence <- dat$queries[input$queryList]
optionList <- sapply(1:9,function(x){input[[sprintf("sqlfunc_%s",x)]]}) # These are just the optionAliaces
possibilities <- lapply(dat$jsonList[[queryIndex]]$optionAlias[[dat$language]],unlist)
optionList <- optionList[optionList!="NA"]
selectedNum <- (sapply(seq_along(optionList),function(i){match(optionList[i],possibilities[[i]])}))
datoptions <- lapply(dat$jsonList[[queryIndex]]$options,unlist)
textContent <- sapply(seq_along(selectedNum),function(i){
if(is.na(selectedNum[i])){
input[[sprintf("sqlfunc_%s",i)]]
} else {
datoptions[[i]][selectedNum[i]]
}
})
sentenceToSQL <- interpolateInto(dat$replNumbers[[input$queryList]],textContent,sqlSentence,TRUE)
sentenceToSQL <- gsub("\\[T1\\]",sprintf("%s",input$time),sentenceToSQL)
sentenceToSQL <- gsub("\\[T2\\]",sprintf("%s",input$until),sentenceToSQL)
outputDB <- file.path(baseDir(),"output")
dbDir <- file.path(baseDir(),"database")
sqlDB <- DBI::dbConnect(RSQLite::SQLite(),file.path(outputDB,"grid.db"))
# browser()
showNotification("Attaching Soil database...")
soilDBName <- file.path(normalizePath(dbDir),"soil.db")
observationDBName <- file.path(normalizePath(dbDir),"observation.db")
if(file.exists(soilDBName)){
dbExecute(sqlDB,sprintf("ATTACH DATABASE '%s' AS soil",soilDBName))
} else {
showNotification("Cannot find soil database, queries which contains soil data will not run",type="warning")
}
if(file.exists(observationDBName)){
dbExecute(sqlDB,sprintf("ATTACH DATABASE '%s' AS observation",observationDBName))
} else {
showNotification("Cannot find observation database, queries which contains soil data will not run",type="warning")
}
showNotification("Attaching weather database...")
weatherDBName <- file.path(normalizePath(dbDir),"climate.db")
if(file.exists(weatherDBName)){
dbExecute(sqlDB,sprintf("ATTACH DATABASE '%s' AS climate", weatherDBName))
} else {
showNotification("Cannot find weather database, queries which contains weather data will not run",type="warning")
}
showNotification("Attaching econo database...")
econoDBName <- file.path(normalizePath(dbDir),"economy.db")
if(file.exists(econoDBName)){
dbExecute(sqlDB,sprintf("ATTACH DATABASE '%s' AS economy", econoDBName))
} else {
showNotification("Cannot find economy database, queries which contains economy data will not run",type="warning")
}
showNotification("Running the query, please wait, it can take for a while", id="query", duration=NULL)
queryResults <- tryCatch(dbGetQuery(sqlDB,sentenceToSQL),error=function(e){NULL})
if(is.null(queryResults)){
showNotification("Something went wrong with the query...",type="error")
} else {
if(input$repcheck){
showModal(modalDialog(tableOutput(ns("pukli")),title="REPORT", size="l",easyClose=TRUE))
output$pukli <- renderTable({
queryResults
})
}
suppressWarnings(dir.create(file.path(baseDir(),"output/report")))
write.csv(queryResults,file.path(baseDir(),"output/report",sprintf("%s.csv",input$queryalias)),row.names=FALSE)
# write.xlsx(queryResults,file.path(baseDir(),"output/report",sprintf("%s.xlsx",input$queryalias)))
}
removeNotification("query")
dbDisconnect(sqlDB)
} else {
showNotification("You should choose at least one query", duration = TRUE)
}
})
algorithms <- list("PHOTOS: Farquhar | PET: Penman-Monteith | WSTRESS: WCBased" = c(0,0,0),
"PHOTOS: Farquhar | PET: Priestly-Taylor | WSTRESS: WCBased" = c(0,1,0),
"PHOTOS: Farquhar | PET: Penman-Monteith | WSTRESS: TransDemBased" = c(0,0,1),
"PHOTOS: Farquhar | PET: Priestly-Taylor | WSTRESS: TransDemBased " = c(0,1,1),
"PHOTOS: DSSAT | PET: Penman-Monteith | WSTRESS: WCBased" = c(1,0,0),
"PHOTOS: DSSAT | PET: Priestly-Taylor | WSTRESS: WCBased" = c(1,1,0),
"PHOTOS: DSSAT | PET: Penman-Monteith | WSTRESS: TransDemBased" = c(1,0,1),
"PHOTOS: DSSAT | PET: Priestly-Taylor | WSTRESS: TransDemBased" = c(1,1,1)
)
observeEvent(input$StartSim,{
if(!isolate(input$annual)){
gridType <- ".dayout"
outputTypeIni <- c(1,0)
} else {
gridType <- ".annout"
outputTypeIni <- c(0,2)
}
showNotification("Checking file system for errors")
firstIni <- sprintf("input/initialization/grid/%s/%s.ini",input$story,dat$story[[1]]$name)
errorFiles <- checkFileSystem(firstIni)
if(length(errorFiles) == 0) {
climprojs <- input$climproj
if(input$ensclim){
climprojs <- sprintf("grid/%s/",list.files(file.path(baseDir(),"input/weather/grid")))
climprojs <- climprojs[grep('^\\.',basename(climprojs),invert=TRUE)]
}
climdb <- DBI::dbConnect(RSQLite::SQLite(),file.path(baseDir(),"/database/climate.db"))
metaTable <- DBI::dbReadTable(climdb,"meta_data")
DBI::dbDisconnect(climdb)
withProgress(message="Climate Ensemble",value=0,{
for(ci in seq_along(climprojs)){
clim <- climprojs[ci]
source_name <- basename(toupper(clim))
source_name <- gsub("^\\.","",source_name)
climid <- metaTable[toupper(metaTable[,"source_name"]) == toupper(source_name),"source_id"]
showNotification("Starting simulation... Removing previous .dayout files")
suppressWarnings(file.remove(
list.files(file.path(baseDir(),
"output/grid",
input$story),full.names=TRUE)))
showNotification("Setting climate projections and algorithms")
indexOfRows <- c(4,39,58,59,61,107,110)
replacements <- c(sprintf("grid/%s/",basename(clim)),
sprintf("grid/%s/",input$soildb),
algorithms[[input$algosel]],outputTypeIni[1],outputTypeIni[2])
regex <- c("grid/.*?/","grid/.*?/")
changeFilesWithRegex(list.files(file.path(baseDir(),"input/initialization/grid",input$story),full.names=TRUE),
indexOfRows,replacements,regex)
## runChain(baseDir(),input$story,dat$story[[5]])
dbDir <- file.path(baseDir(),"output")
sqlDB <- DBI::dbConnect(RSQLite::SQLite(),file.path(dbDir,"grid.db"))
error <- runGrid(baseDir(),input$story,dat$story) # dat$story is a list containing all running groups
errorDF <- tapply(error,as.numeric(gsub("_.*","",names(error))),sum)
errorDF <- data.frame(site=names(errorDF),error=errorDF)
dbWriteTable(sqlDB,sprintf("%s_error",input$outsq),errorDF,overwrite=TRUE)
if(ci == 1){
dbExecute(sqlDB,sprintf("DROP TABLE IF EXISTS %s",input$outsq))
}
withProgress(message="Writing data to database, it can be slow...",value=0,{
for(i in seq_along(dat$story)){
if(errorDF[i,"error"] == 0){
writeChainToDB(baseDir(),input$story, sqlDB, input$outsq, dat$story[[i]], dat$storyVars,
type=gridType,climid=climid)
}
incProgress(1/length(dat$story),detail=sprintf("Writing site %s into grid database",names(dat$story)[i]))
}
})
incProgress(1/length(climprojs), detail=sprintf("%s [%s/%s]",basename(climprojs[ci]), ci, length(climprojs)))
}
})
indexSQL<- c(
"site" = "CREATE INDEX site_%s ON %s(cell_id)",
"year" = "CREATE INDEX year_%s ON %s(year)"
)
if(is.element(input$outsq,dbListTables(sqlDB))){
withProgress(message="Creating Database Indexes",value=0,{
for(i in seq_along(indexSQL)){
dbExecute(sqlDB,sprintf("DROP INDEX IF EXISTS %s_%s",names(indexSQL[i]),input$outsq))
dbExecute(sqlDB,sprintf(indexSQL[i],input$outsq,input$outsq,input$outsq))
incProgress(1/length(indexSQL), sprintf("Creating index on %s",names(indexSQL)[i]))
}
})
}
dat$modelOutputs <-grep("_error$",dbListTables(sqlDB),invert=TRUE,value=TRUE)
dbDisconnect(sqlDB)
} else {
showNotification(tags$html(paste(sapply(names(errorFiles),function(eFile){
sprintf(" the %s file (%s) is missing", eFile, errorFiles)
} ),collapse="<br>")), type="error", duration = 10)
}
})
observeEvent(input$Map,{
toreturn$showMap <- input$Map
})
observe({
outN <- paste(input$story, match(input$climproj,dat$weatherOptions),match(input$soildb,dat$soilOptions), sep="_")
updateTextInput(session,"outsq", value=outN)
})
return(toreturn)
}
changeFilesWithRegex <- function (iniFiles, indexOfRows, replacements, regex=NULL) {
while(length(regex) < length(replacements)) {
regex <- c(regex,"")
}
for(i in iniFiles){
a <- readLines(i)
if(is.null(regex)){
Map(function(x,y){a[x] <<- y}, indexOfRows, replacements)
writeLines(text=a, con = i)
} else {
Map(function(x,ind){
if(regex[ind]!=""){
a[x] <<- gsub(regex[ind],replacements[ind],a[x], perl = TRUE)
} else {
# browser()
a[x] <<-as.character(replacements[ind])
}
},
indexOfRows, seq_along(replacements))
writeLines(text=a, con = i)
}
}
}
getReplacementNumbers <- function (baseString) {
atomicRes <- suppressWarnings(as.numeric(gsub("(.*)\\{(\\d)\\}(.*)","\\2",baseString,perl=TRUE)))
if(is.na(atomicRes)){
return(numeric(0))
} else {
return(c(getReplacementNumbers(gsub("(.*)\\{(\\d)\\}.*","\\1",baseString,perl=TRUE)),atomicRes))
}
}
interpolateInto <- function(places, strings, jsonstring, plain=FALSE){
for(i in seq_along(places)){
jsonstring <- gsub(sprintf("(\\{%s\\})",places[i]), ifelse(!plain,sprintf("{%s: %s}", i, strings[places[i]]),
sprintf("%s",strings[places[i]])),jsonstring)
}
return(jsonstring)
}
interpolateArray <- function (jsonlist,x) {
jsonIndex<- x$jsonIndex
jsonOptions <- x$jsonOptions
interpolateInto(getReplacementNumbers(jsonlist[[jsonIndex]]$query), jsonOptions, jsonlist[[jsonIndex]]$query)
}
colorReplacements <- function(stringVector){
stringVector <- gsub("(\\{.*?\\})","<span class=\"reddi\">\\1</span>",stringVector)
stringVector <- gsub("(\\[.*?\\-.*?\\])","<span class=\"timeSlice\">\\1</span>",stringVector)
return(stringVector)
}
queryCreator <- function(fileN, description, index, optis, connectionBase, dat){
interpolateInto(dat$replNumbers[[index]],optis,dat$query)
}
runChain <- function (baseDir, storyName, chainMatrix) {
setwd(baseDir)
returnVal <- apply(chainMatrix,1,function(x){
suppressWarnings(system2("./muso",
file.path(baseDir,"input/initialization/grid",storyName,paste0(x[2],".ini")),
stderr=NULL,stdout=NULL))
})
names(returnVal) <- chainMatrix[,2]
returnVal
}
#' runGrid
#'
#' This is the parallel executer
#' @importFrom parallel detectCores makeCluster stopCluster
#' @importFrom doSNOW registerDoSNOW
#' @importFrom foreach foreach %dopar%
runGrid <- function(baseDir,storyName,chainMatrixFull){
showNotification(sprintf("Starting cluster for parallel run with %s cores, please wait for the progress indicator",detectCores()-1))
cl <- makeCluster(detectCores()-1)
registerDoSNOW(cl)
iterations <- length(chainMatrixFull)
progress <- function(i) incProgress(1/iterations, detail = paste("Doing part", i))
opts <- list(progress = progress)
withProgress(message = "simulation", value = 0, {
result <- foreach(i = 1:length(chainMatrixFull), .export="runChain", .combine = c,
.options.snow = opts) %dopar% {
runChain(baseDir,storyName, chainMatrixFull[[i]])
}
})
stopCluster(cl)
print(result)
}
#' writeChainToDB
#'
#' This function reads the model binary and put that into a database
#' @param settings The result of the setupGUI
#' @param dbConnection An SQLite connection
#' @param binaryName The name of the binary output file
#' @param outputName The name of the result table
#' @importFrom DBI dbWriteTable
#' @importFrom lubridate year month yday
writeChainToDB <- function(baseDir, storyName, dbConnection, outputName,
chainMatrix, variables, errorVector, type, climid){
fName <- paste0(file.path(baseDir, "output/grid/",
storyName, chainMatrix[,2]), type)
econofName <- paste0(file.path(baseDir, "output/grid/",
storyName, chainMatrix[,2]), ".econout")
toWrite <- do.call("rbind",
lapply(fName, function(fn){readTable(fn,econofName,
variables,
type,
cell_id=as.character(chainMatrix[,1]),
numDays=as.integer(chainMatrix[,5]),
startYear=as.integer(chainMatrix[,"startYear"]),
endYear=as.integer(chainMatrix[,"endYear"]))}))
toWrite <- cbind.data.frame(toWrite, climate_id =climid)
dbWriteTable(dbConnection, outputName, toWrite, append = TRUE)
}
#' writeChainToDB
#'
#' This function reads the model binary and put that into a database
#' @param fName the name of the file
#' @param variables The variable names
#' @param type .dayout or .annout
#' @importFrom lubridate year month yday
readTable <- function(fName, econofName, variables, type, cell_id, numDays, startYear, endYear){
if(type == ".dayout"){
con <- file(fName,"rb")
dayoutput <- matrix(readBin(con,"double",size=8,n=(numDays*length(variables))),
numDays,byrow=TRUE)
udates <- grep("[0-9]{4}-02-29", as.character(seq(from=as.Date(sprintf("%s-01-01",startYear)),
to=(as.Date(sprintf("%s-01-01", (endYear + 1)))-1),
by=1)),
invert=TRUE, value=TRUE)
year <- year(udates)
month <- month(udates)
yday <- yday(udates)
dayoutput <- cbind.data.frame(udates,year,month,yday, dayoutput,
site=cell_id, stringsAsFactors=FALSE)
colnames(dayoutput) <- as.character(c("udate","year","month","yday", variables, "cell_id"))
close(con)
return(dayoutput)
} else {
if(file.exists(econofName)){
econonames <- c("year","crop_id","prim_prod","sec_prod","irr_amaunt","irr_type")
econoOutput <- read.table(econofName, skip=1, header=FALSE)
econoOutput[,1] <- as.integer(econoOutput[,1])
econoOutput[,5] <- as.integer(econoOutput[,5])
colnames(econoOutput) <- econonames
annual <- read.table(fName, skip=1, header=FALSE)
colnames(annual) <- c("year",variables)
annuOutput <- cbind.data.frame(
merge(x = annual,
y = econoOutput,all=TRUE,by="year",sort = FALSE),
cell_id)
colnames(annuOutput) <- c("year", variables, econonames[-1],"cell_id")
return(annuOutput)
}
annuOutput <- cbind.data.frame(read.table(fName, skip=1, header=FALSE),cell_id)
colnames(annuOutput) <- c("year", variables, "cell_id")
return(annuOutput)
}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.