.Rhistory

errMsg<-errMsg[1]
}
badSettings<-testCosmetic(input, output, session, DF = as.data.frame(scenarioRtables$cosmeticScen), "Source Change Scenarios",
scenario.input.list, mapping.input.list)$badSettings
}
goShinyPlot(input, output, session, choices,"batchPlot",badSettings,errMsg,
file.output.list, map_uncertainties,BootUncertainties,
data_names,mapping.input.list,
#predict.list,
subdata,SelParmValues,
#site attr
sitedata,estimate.list,estimate.input.list,#Mdiagnostics.list,
#scenarios
JacobResults,
ConcFactor,DataMatrix.list,dlvdsgn,
reach_decay_specification,reservoir_decay_specification,
scenario.input.list,if_predict,
#scenarios out
add_vars,
#batchError
batch_mode,
RSPARROW_errorOption)
})#end batch plot p3
observe({
p3()
})
session$onSessionEnded(function() {
stopApp()
})
})#end server function
)#end shinyApp function
#setup shiny ui
shinyApp(  ui=shinyUI(
fluidPage(tags$head(
tags$style("h5{color: red}")),
titlePanel(
h1(paste("RShiny Decision Support System : ",run_id,sep=""))),
tabsetPanel(
tabPanel('Sparrow control',
wellPanel(id = "inputs", style = "overflow-y:scroll; max-height: 700px; background-color:#e3fbff",
h4('1. DATA IMPORT SETTINGS'),
p('Set csv read/write options'),
textInput('csv_decimalSeparator', 'csv_decimalSeparator', value = ','),
textInput('csv_columnSeparator', 'csv_columnSeparator', value = ','),
p('Create an initial Data Dictionary file from the data1 column names'),
p('This file will have to be edited prior to executing RSPARROW'),
textInput('create_initial_dataDictionary', 'create_initial_dataDictionary', value = "no"),
p('Create an initial parameter and design_matrix files from names in the Data Dictionary file'),
p('The parameter names must be listed for both the sparrowNames and data1UserNames and the'),
p('varType should be defined as SOURCE, DELIVF, STRM, or RESV to populate parmType in the (run_id)_parameters.CSV'),
p('The initial file will have to be edited prior to executing RSPARROW'),
textInput('create_initial_parameterControlFiles', 'create_initial_parameterControlFiles', value = "no"),
p('Select input data file (accepted file types ".csv" or binary file with no extension created in previous RSPARROW run.'),
p('Binary file will be automatically created if file type is not binaryfor fast import in subsequent runs.'),
textInput('input_data_fileName', 'input_data_fileName', value = 'data1.csv'),
p('Loads previous binary data input file "(input_data_fileName)_priorImport" from results directory. This setting will override run_dataImport.'),
p('NOTE: The OPTIONS FOR NETWORK ATTRIBUTES AND AREA VERIFICATION (section 2) will ONLY be executed if load_previousDataImport<-"no"'),
textInput('load_previousDataImport', 'load_previousDataImport', value = 'no'),
p('Indicate whether or not to run _userModifyData.R script'),
textInput('if_userModifyData', 'if_userModifyData', value = 'yes'),
h4('2. STREAM NETWORK ATTRIBUTES AND VERIFICATION'),
h4('3. MONITORING SITE FILTERING OPTIONS'),
h4('4. MODEL ESTIMATION'),
h4('5. MODEL SPATIAL DIAGNOSTICS '),
h4('6. SELECTION OF VALIDATION SITES'),
h4('7. MODEL PREDICTIONS'),
h4('8. DIAGNOSTIC PLOTS AND MAPS'),
h4('9. RShiny interactive Decision Support System (DSS) mapper'),
h4('10. MODEL PREDICTION UNCERTAINTIES'),
h4('11. DIRECTORY AND MODEL IDENTIFICATION AND CONTROL SCRIPT OPERATIONS'),
h4('12. INSTALLATION AND UPDATING OF R LIBRARIES'),
h4('Run Model')
)
),
tabPanel('Plots',
sidebarLayout(
sidebarPanel(width=6,
h4("SPARROW Interactive Mapping                     "),
br(),
#top level user input
selectInput("batch","Output Mode",c("Interactive","Batch")),
selectInput("enablePlotly","Output Map Format",c("static","plotly","leaflet"),selected = ifelse(mapping.input.list$enable_plotlyMaps=="yes","plotly","static")),
textOutput("plotlyExplanation"),
br(),
selectInput("mapType","Map Type",mapTypeChoices),
#Stream and Catchment arguments
streamCatch("nsStreamCatch", input, choices, map_uncertainties,sitedata,add_plotlyVars),
#site Attribute arguments
shinySiteAttr("nsSiteAttr",input,choices,sitedata,add_plotlyVars),
#scenarios arguments
shinyScenarios("nsScenarios",input,choices,sitedata,add_plotlyVars, scenario.input.list),
#output shape file ifBatch
shapeFunc("nsBatch",input),
# actionButton("showInput","Show Input"),
conditionalPanel(
condition = "input.batch=='Interactive'",
fluidRow(
actionButton("goPlot","Generate Map"),
actionButton("savePDF", "Save Map"))
),
conditionalPanel(
condition = "input.batch=='Batch'",
actionButton("batchPlot","Save Map(s)")
)
),
mainPanel(width = 6,
uiOutput("plot")
)
)
)
)))#end ui function
,
################################################################
###############################################################
###############################################################
server=shinyServer(function(input, output,session) {
#update red labels
observe({
if (input$mapType!=""){
updateSelectInput(session, "mapType",
label = "Map Type"
)
}
#no plotly catchment maps in interactive mode
currentSelect<-isolate(input$enablePlotly)
if (input$mapType=="Catchment" & input$batch=="Interactive"){
updateSelectInput(session,"enablePlotly","Output Map Format",c("static","leaflet"),selected = "static")
output$plotlyExplanation<-renderText({"Plotly not available for catchment maps in Interactive mode due to long processing time\n to get interactive catchment maps select Batch mode and enable plotly"
})
}else if (input$mapType=="Source Change Scenarios"){
if (length(input$`nsScenarios-outType`)==0){
updateSelectInput(session,"enablePlotly","Output Map Format",c("static","plotly","leaflet"),selected = currentSelect)
output$plotlyExplanation<-renderText({"Plotly Maps will take longer to render in Interactive mode"})
}else{
if (input$`nsScenarios-outType`=="Catchment" & input$batch=="Interactive"){
updateSelectInput(session,"enablePlotly","Output Map Format",c("static","leaflet"),selected = "static")
output$plotlyExplanation<-renderText({"Plotly not available for catchment maps in Interactive mode due to long processing time\n to get interactive catchment maps select Batch mode and enable plotly"})
}else{
updateSelectInput(session,"enablePlotly","Output Map Format",c("static","plotly","leaflet"),selected = currentSelect)
output$plotlyExplanation<-renderText({"Plotly Maps will take longer to render in Interactive mode"})
}
}
}else{
updateSelectInput(session,"enablePlotly","Output Map Format",c("static","plotly","leaflet"),selected = currentSelect)
output$plotlyExplanation<-renderText({"Plotly Maps will take longer to render in Interactive mode"})
}
})
#select all and clear all buttons in drop downs
observe({
if (input$batch=="Batch"){
if (input$mapType %in% c("Stream","Catchment")){
lapply(1:length(as.character(unique(choices$category))), function(c) {
category<-as.character(unique(choices$category))[c]
if (category!="Prediction Uncertainties"){
nsName<-paste0("ns",tolower(str_split(category," ")[[1]][1]),"Drop")
}else{
nsName<-"nsuncertaintyDrop"
}
callModule(selectAll,nsName, category = category, choices = choices)
})
}else{
choicesScen<-choices[which(!choices$category %in% c("Data Dictionary Variable","Prediction Uncertainties") & regexpr("Monitoring-adjusted",choices$definition)<0),]
ratioChoices<-data.frame(category = c("Relative Change in Load","Relative Change in Load"),
variable = c("ratio_total","ratio_inc","percent_total","percent_inc"),
definition = c("Ratio of the changed total load to the baseline (unchanged) total load",
"Ratio of the changed incremental load to the baseline (unchanged) incremental load"))
choices$category<-ifelse(choices$category=="Load Predictions","Load Predictions for Changed Sources",
ifelse(choices$category=="Yield Predictions","Yield Predictions for Changed Sources",choices$category))
choicesScen<-rbind(choicesScen,ratioChoices)
lapply(1:length(as.character(unique(choicesScen$category))), function(c) {
category<-as.character(unique(choicesScen$category))[c]
nsName<-paste0("nsScen",tolower(str_split(category," ")[[1]][1]),"Drop")
callModule(selectAll,nsName, category = category, choices = choicesScen)
})
}
if (input$mapType %in% c("Stream","Catchment","Site Attributes")){
callModule(selectAll,"nsattrDrop", category = "Data Dictionary Variable", choices = choices)
}
}
})
#update variable lists according to variable type selection in interactive mode
observe({
if (input$batch=="Interactive" & input$mapType %in% c("Stream","Catchment")){
callModule(updateVariable,"nsStreamCatch", choices= choices, mapType = input$mapType)
}else if (input$batch=="Interactive" & input$mapType == "Site Attributes"){
callModule(updateVariable,"nsSiteAttr", choices= choices, mapType = input$mapType)
}else{
choicesScen<-choices[which(!choices$category %in% c("Data Dictionary Variable","Prediction Uncertainties") & regexpr("Monitoring-adjusted",choices$definition)<0),]
ratioChoices<-data.frame(category = c("Relative Change in Load","Relative Change in Load"),
variable = c("ratio_total","ratio_inc","percent_total","percent_inc"),
definition = c("Ratio of the changed total load to the baseline (unchanged) total load",
"Ratio of the changed incremental load to the baseline (unchanged) incremental load"))
choices$category<-ifelse(choices$category=="Load Predictions","Load Predictions for Changed Sources",
ifelse(choices$category=="Yield Predictions","Yield Predictions for Changed Sources",choices$category))
choicesScen<-rbind(choicesScen,ratioChoices)
callModule(updateVariable,"nsScenarios", choices= choicesScen, mapType = input$mapType)
}
})
#rTables
observe({
if (input$mapType %in% c("Source Change Scenarios")){
callModule(shinyScenariosMod,"nsScenarios",scenarioRtables,path_results,scenario.input.list, mapping.input.list)
}else if (input$mapType %in% c("Stream","Catchment")){
testRow<-testCosmetic(input, output, session,
DF = as.data.frame(scenarioRtables$cosmeticPred),mapType = input$mapType,
scenario.input.list, mapping.input.list)$rowNums
callModule(validCosmetic,"nsStreamCatch-nsCosmetic",
DF = as.data.frame(scenarioRtables$cosmeticPred),rowNum = testRow)
}else if (input$mapType == "Site Attributes"){
testRow<-testCosmetic(input, output, session,
DF = as.data.frame(scenarioRtables$cosmeticSite),mapType = input$mapType,
scenario.input.list, mapping.input.list)$rowNums
callModule(validCosmetic,"nsSiteAttr-nsCosmetic",
DF = as.data.frame(scenarioRtables$cosmeticSite),rowNum = testRow)
}
})
#interactive plot
p1<-eventReactive(input$goPlot, {
gc()
output$plotOne<-NULL
output$plotlyPlot<-NULL
output$leafPlot<-NULL
gc()
suppressWarnings(remove(p,envir = .GlobalEnv))
suppressWarnings(remove(currentP))
#test bad Settings
badSettings<-as.data.frame(matrix(0,ncol=4,nrow=0))
names(badSettings)<-c("Setting","CurrentValue","Type","Test")
errMsg<-NA
if (input$mapType %in% c("Stream","Catchment")){
badSettings<-testCosmetic(input, output, session, DF = as.data.frame(scenarioRtables$cosmeticPred),mapType =input$mapType,
scenario.input.list, mapping.input.list)$badSettings
}else if (input$mapType == "Site Attributes"){
badSettings<-testCosmetic(input, output, session, DF = as.data.frame(scenarioRtables$cosmeticSite),mapType =input$mapType,
scenario.input.list, mapping.input.list)$badSettings
}else{
errMsg1<-testRedTbl(input, output, session, DF = as.data.frame(scenarioRtables$sourceRed))$errMsg
errMsg2<-testRedTbl(input, output, session, DF = as.data.frame(scenarioRtables$allSourcesDF))$errMsg
errMsg3<-testRedTbl(input, output, session, DF = as.data.frame(scenarioRtables$allSourcesDFno))$errMsg
errMsg<-na.omit(c(errMsg1,errMsg2, errMsg3))
if (length(errMsg)==0){
errMsg<-NA
}else{
errMsg<-errMsg[1]
}
badSettings<-testCosmetic(input, output, session, DF = as.data.frame(scenarioRtables$cosmeticScen), "Source Change Scenarios",
scenario.input.list, mapping.input.list)$badSettings
}
currentP<-goShinyPlot(input, output, session, choices,"goPlot", badSettings,errMsg,
file.output.list,map_uncertainties,BootUncertainties,
data_names,mapping.input.list,
#predict.list,
subdata,SelParmValues,
#site attr
sitedata,estimate.list,estimate.input.list,#Mdiagnostics.list,
#scenarios
JacobResults,
ConcFactor,DataMatrix.list,dlvdsgn,
reach_decay_specification,reservoir_decay_specification,
scenario.input.list,if_predict,
#scenarios out
add_vars,
#batchError
batch_mode,
RSPARROW_errorOption)
#print plot size
env <- environment()
objs<-data.frame(
object = ls(env),
size = unlist(lapply(ls(env), function(x) {
object.size(get(x, envir = env, inherits = FALSE))})))
print(paste0("Plot size : ",objs[which(objs$object=="currentP"),]$size))
if (input$enablePlotly=="static"){
output$plot<-renderUI({
plotOutput("plotOne", width=900,height=900) %>% withSpinner(color="#0dc5c1")
})
#time plot render
output$plotOne  <- renderPlot({
isolate(currentP)
})
}else if (input$enablePlotly=="plotly"){
output$plot<-renderUI({
plotlyOutput("plotlyPlot", width=900,height=900) %>% withSpinner(color="#0dc5c1")
})
output$plotlyPlot <- renderPlotly({
isolate(currentP)
})
}else if (input$enablePlotly=="leaflet"){
output$plot<-renderUI({
leafletOutput("leafPlot", width=900,height=900) %>% withSpinner(color="#0dc5c1")
})
output$leafPlot<-renderLeaflet({
isolate(currentP)
})
}
})
observe({
p1()
})
#pdf output
#observeEvent(input$savePDF, {
p2<-eventReactive(input$savePDF, {
#test bad Settings
badSettings<-as.data.frame(matrix(0,ncol=4,nrow=0))
names(badSettings)<-c("Setting","CurrentValue","Type","Test")
errMsg<-NA
if (input$mapType %in% c("Stream","Catchment")){
badSettings<-testCosmetic(input, output, session, DF = as.data.frame(scenarioRtables$cosmeticPred),mapType =input$mapType,
scenario.input.list, mapping.input.list)$badSettings
}else if (input$mapType == "Site Attributes"){
badSettings<-testCosmetic(input, output, session, DF = as.data.frame(scenarioRtables$cosmeticSite),mapType =input$mapType,
scenario.input.list, mapping.input.list)$badSettings
}else{
errMsg1<-testRedTbl(input, output, session, DF = as.data.frame(scenarioRtables$sourceRed))$errMsg
errMsg2<-testRedTbl(input, output, session, DF = as.data.frame(scenarioRtables$allSourcesDF))$errMsg
errMsg3<-testRedTbl(input, output, session, DF = as.data.frame(scenarioRtables$allSourcesDFno))$errMsg
errMsg<-na.omit(c(errMsg1,errMsg2, errMsg3))
if (length(errMsg)==0){
errMsg<-NA
}else{
errMsg<-errMsg[1]
}
badSettings<-testCosmetic(input, output, session, DF = as.data.frame(scenarioRtables$cosmeticScen), "Source Change Scenarios",
scenario.input.list, mapping.input.list)$badSettings
}
goShinyPlot(input, output, session, choices,"savePDF",badSettings, errMsg,
file.output.list, map_uncertainties,BootUncertainties,
data_names,mapping.input.list,
#predict.list,
subdata,SelParmValues,
#site attr
sitedata,estimate.list,estimate.input.list,#Mdiagnostics.list,
#scenarios
JacobResults,
ConcFactor,DataMatrix.list,dlvdsgn,
reach_decay_specification,reservoir_decay_specification,
scenario.input.list,if_predict,
#scenarios out
add_vars,
#batchError
batch_mode,
RSPARROW_errorOption)
})#end save plot p2
observe({
p2()
#try(dev.off(), silent = TRUE)
})
#batchplot
p3<-eventReactive(input$batchPlot, {
# observeEvent(input$batchPlot, {
#test bad Settings
badSettings<-as.data.frame(matrix(0,ncol=4,nrow=0))
names(badSettings)<-c("Setting","CurrentValue","Type","Test")
errMsg<-NA
if (input$mapType %in% c("Stream","Catchment")){
badSettings<-testCosmetic(input, output, session, DF = as.data.frame(scenarioRtables$cosmeticPred),mapType =input$mapType,
scenario.input.list, mapping.input.list)$badSettings
}else if (input$mapType == "Site Attributes"){
badSettings<-testCosmetic(input, output, session, DF = as.data.frame(scenarioRtables$cosmeticSite),mapType =input$mapType,
scenario.input.list, mapping.input.list)$badSettings
}else{
errMsg1<-testRedTbl(input, output, session, DF = as.data.frame(scenarioRtables$sourceRed))$errMsg
errMsg2<-testRedTbl(input, output, session, DF = as.data.frame(scenarioRtables$allSourcesDF))$errMsg
errMsg3<-testRedTbl(input, output, session, DF = as.data.frame(scenarioRtables$allSourcesDFno))$errMsg
errMsg<-na.omit(c(errMsg1,errMsg2, errMsg3))
if (length(errMsg)==0){
errMsg<-NA
}else{
errMsg<-errMsg[1]
}
badSettings<-testCosmetic(input, output, session, DF = as.data.frame(scenarioRtables$cosmeticScen), "Source Change Scenarios",
scenario.input.list, mapping.input.list)$badSettings
}
goShinyPlot(input, output, session, choices,"batchPlot",badSettings,errMsg,
file.output.list, map_uncertainties,BootUncertainties,
data_names,mapping.input.list,
#predict.list,
subdata,SelParmValues,
#site attr
sitedata,estimate.list,estimate.input.list,#Mdiagnostics.list,
#scenarios
JacobResults,
ConcFactor,DataMatrix.list,dlvdsgn,
reach_decay_specification,reservoir_decay_specification,
scenario.input.list,if_predict,
#scenarios out
add_vars,
#batchError
batch_mode,
RSPARROW_errorOption)
})#end batch plot p3
observe({
p3()
})
session$onSessionEnded(function() {
stopApp()
})
})#end server function
)#end shinyApp function
selectInput
?selectInput
return(out)
output$entry <- renderUI({
# input
upload <- as.logical(input$upload)
if(upload)
out <- wellPanel(style = "overflow-x:scroll; background-color:#e3fbff",
fileInput('controlupload', NULL, accept = '.R')
)
if(!upload)
out <- wellPanel(id = "inputs", style = "overflow-y:scroll; max-height: 700px; background-color:#e3fbff",
h4('1. DATA IMPORT SETTINGS'),
p('Set csv read/write options'),
textInput('csv_decimalSeparator', 'csv_decimalSeparator', value = ','),
textInput('csv_columnSeparator', 'csv_columnSeparator', value = ','),
p('Create an initial Data Dictionary file from the data1 column names'),
p('This file will have to be edited prior to executing RSPARROW'),
textInput('create_initial_dataDictionary', 'create_initial_dataDictionary', value = "no"),
p('Create an initial parameter and design_matrix files from names in the Data Dictionary file'),
p('The parameter names must be listed for both the sparrowNames and data1UserNames and the'),
p('varType should be defined as SOURCE, DELIVF, STRM, or RESV to populate parmType in the (run_id)_parameters.CSV'),
p('The initial file will have to be edited prior to executing RSPARROW'),
textInput('create_initial_parameterControlFiles', 'create_initial_parameterControlFiles', value = "no"),
p('Select input data file (accepted file types ".csv" or binary file with no extension created in previous RSPARROW run.'),
p('Binary file will be automatically created if file type is not binaryfor fast import in subsequent runs.'),
textInput('input_data_fileName', 'input_data_fileName', value = 'data1.csv'),
p('Loads previous binary data input file "(input_data_fileName)_priorImport" from results directory. This setting will override run_dataImport.'),
p('NOTE: The OPTIONS FOR NETWORK ATTRIBUTES AND AREA VERIFICATION (section 2) will ONLY be executed if load_previousDataImport<-"no"'),
textInput('load_previousDataImport', 'load_previousDataImport', value = 'no'),
p('Indicate whether or not to run _userModifyData.R script'),
textInput('if_userModifyData', 'if_userModifyData', value = 'yes'),
h4('2. STREAM NETWORK ATTRIBUTES AND VERIFICATION'),
p('NOTE: This section is only executed if data import of the csv file is run. To run data import, set load_previousDataImport<-"no"'),
p('Verify drainage area accumulation in the network'),
p('NOTE: This requires that precalculated values of "demtarea" are present in DATA1 Area totals will be affected by "frac"'),
textInput('if_verify_demtarea', 'if_verify_demtarea', value = 'no'),
p('Indicate whether maps are to be generated for if_verify_demtarea<-"yes"'),
p('NOTE: Generating maps can significantly slow processing time for larger models'),
textInput('if_verify_demtarea_maps', 'if_verify_demtarea_maps', value = "no"),
p('Request the calculation of selected reach attributes:'),
p('Identify the attributes for calculation and placement in DATA1'),
p('Select from following: "hydseq", "headflag", and/or "demtarea"'),
selectInput('calculate_reach_attribute_list', 'calculate_reach_attribute_list', selected = NULL, multiple = T, selectize = T,
choices = c('hydseq', 'headflag', 'demtarea')),
p('Specify any additional DATA1 variables (and conditions) to be used to filter reaches:'),
p('Default conditions are FNODE > 0 and TNODE > 0'),
p('The filter is used to create "subdata" object from "data1"'),
p('Example: c("data1$drainden > 0 & !is.na(data1$drainden)"'),
textInput('filter_data1_conditions', 'filter_data1_conditions', value = NA),
p('Indicate whether hydseq in the DATA1 file needs to be reversed'),
textInput('if_reverse_hydseq', 'if_reverse_hydseq', value = "no"),
h4('3. MONITORING SITE FILTERING OPTIONS'),
h4('4. MODEL ESTIMATION'),
h4('5. MODEL SPATIAL DIAGNOSTICS '),
h4('6. SELECTION OF VALIDATION SITES'),
h4('7. MODEL PREDICTIONS'),
h4('8. DIAGNOSTIC PLOTS AND MAPS'),
h4('9. RShiny interactive Decision Support System (DSS) mapper'),
h4('10. MODEL PREDICTION UNCERTAINTIES'),
h4('11. DIRECTORY AND MODEL IDENTIFICATION AND CONTROL SCRIPT OPERATIONS'),
h4('12. INSTALLATION AND UPDATING OF R LIBRARIES'),
h4('Run Model')
)
return(out)
})
?withProgress
?gc
gc()
devtools::load_all(".")
load(file = 'batch/shinyBatch.RData')
shinyArgs
names(shinyArgs)
load(file = 'batch/batch.RData')
names(batch) %>% sort
file_sum
load(file = 'batch/interactiveBatch.RData')
?normalizePath
cat(normalizePath(c(R.home(), tempdir())), sep = "\n")
remotes::install_gitub('USEPA/micromap')
remotes::install_github('USEPA/micromap')
library(micromap)
?micromap
?mmplot
vignette(package = 'micromap')
vignette('Introduction_Guid'e, package = 'micromap')
vignette('Introduction_Guide', package = 'micromap')
mmplot(stat.data=edPov,map.data=statePolys,
panel.types=c("labels", "dot","dot", "map"),
panel.data=list("state","pov","ed", NA),
ord.by="pov", grouping=5,
median.row=T,
map.link=c("StateAb","ID")
)
statePolys <- create_map_table(USstates, IDcolumn="ST")
data("USstates")
statePolys <- create_map_table(USstates, IDcolumn="ST")
mmplot(stat.data=edPov,map.data=statePolys,
panel.types=c("labels", "dot","dot", "map"),
panel.data=list("state","pov","ed", NA),
ord.by="pov", grouping=5,
median.row=T,
map.link=c("StateAb","ID")
)
data(edPOV)
data(edPov)
mmplot(stat.data=edPov,map.data=statePolys,
panel.types=c("labels", "dot","dot", "map"),
panel.data=list("state","pov","ed", NA),
ord.by="pov", grouping=5,
median.row=T,
map.link=c("StateAb","ID")
)