Updates to downloads and colour graphics
This commit is contained in:
42
Parses.R
42
Parses.R
@@ -14,7 +14,7 @@ FIRST_NODE_COL <- 3
|
||||
|
||||
mappings <- c('TestScenario', 'Map_P_BA', 'Map_BA_OP', 'Map_OP_ES')
|
||||
nodeTypes <- c('Input.Nodes', 'Internal.Nodes', 'Published.Nodes')
|
||||
states <- c('impact', 'confidence', 'growth', 'recovery')
|
||||
states <- c('impact', 'confidence', 'growth', 'recovery', 'layer')
|
||||
refs <-c(1:length(mappings))
|
||||
|
||||
setEmpties <- function(val) {
|
||||
@@ -46,9 +46,9 @@ buildExpr <- function(pressStatus) {
|
||||
|
||||
parseScenario <- function(press, prefix = 'p') {
|
||||
pressNames <- colnames(press)[2:length(colnames(press))]
|
||||
coefs <- matrix(data=NA, nrow=length(pressNames), ncol=2, dimnames=list(NULL, c('growth', 'confidence')))
|
||||
coefs <- matrix(data=NA, nrow=length(pressNames), ncol=3, dimnames=list(NULL, c('growth', 'confidence', 'layer')))
|
||||
for (col in 2:ncol(press)) {
|
||||
coefs[col-1,] <- as.numeric(split(press[1, col]))[match(c('growth', 'confidence'), states)]
|
||||
coefs[col-1,] <- as.numeric(split(press[1, col]))[match(c('growth', 'confidence', 'layer'), states)]
|
||||
}
|
||||
press[is.na(press)] <- 0
|
||||
if (sum(duplicated(pressNames))>0) {
|
||||
@@ -62,6 +62,7 @@ parseScenario <- function(press, prefix = 'p') {
|
||||
code=paste0(prefix, seq(1:length(pressNames))),
|
||||
growth = coefs[,'growth'],
|
||||
confidence=coefs[,'confidence'],
|
||||
layer=coefs[,'layer'],
|
||||
stringsAsFactors = FALSE),
|
||||
edges=data.frame(input=NULL, output=NULL, impact=NULL)
|
||||
))
|
||||
@@ -127,7 +128,7 @@ buildGraph <- function(model, desc) {
|
||||
edges <- paste0(edges, paste0("[", outNodes[idx], "|", substr(inputsStr, start=1, stop=(nchar(inputsStr)-1)), "]"))
|
||||
|
||||
#Make the coefficient of the distribution
|
||||
coefVal <- setNames(c(model$nodes$growth[nodeRef], model$edges$impact[rows]),
|
||||
coefVal <- setNames(c(model$nodes$growth[nodeRef], model$edges$values[rows]),
|
||||
c("(Intercept)", model$edges$input[rows])
|
||||
)
|
||||
#str(coefVal)
|
||||
@@ -136,8 +137,9 @@ buildGraph <- function(model, desc) {
|
||||
}
|
||||
|
||||
print('about to build network')
|
||||
print(paste0(inputText, edges))
|
||||
|
||||
net <- model2network(paste0(inputText, edges))
|
||||
net <- model2network(paste0(inputText, edges), debug=TRUE)
|
||||
|
||||
print('network build successful')
|
||||
|
||||
@@ -220,17 +222,20 @@ getValidNodes <- function(mapping, prevOutputs, prefix) {
|
||||
}
|
||||
}
|
||||
|
||||
coefs <- matrix(data=NA, nrow=length(outNodes), ncol=2, dimnames=list(NULL, c('growth', 'confidence')))
|
||||
coefs <- matrix(data=NA, nrow=length(outNodes), ncol=3, dimnames=list(NULL, c('growth', 'confidence', 'layer')))
|
||||
for (idx in 1:length(outNodes)) {
|
||||
col <- match(outNodes[idx], colnames(mapping))
|
||||
coefs[idx,] <- as.numeric(split(mapping[1, col]))[match(c('growth', 'confidence'), states)]
|
||||
coefs[idx,] <- as.numeric(split(mapping[1, col]))[match(c('growth', 'confidence', 'layer'), states)]
|
||||
}
|
||||
|
||||
print(coefs)
|
||||
|
||||
return(data.frame(
|
||||
code=c(prevOutputs$code, paste0(prefix, seq(1:length(outNodes)))),
|
||||
name=c(prevOutputs$name, outNodes),
|
||||
growth=c(prevOutputs$growth, coefs[,"growth"]),
|
||||
confidence=c(prevOutputs$confidence, coefs[,"confidence"]),
|
||||
layer=c(prevOutputs$layer, coefs[,"layer"]),
|
||||
stringsAsFactors=FALSE
|
||||
))
|
||||
}
|
||||
@@ -266,14 +271,14 @@ getValidEdges <- function(mapping, nodeDF, prevEdge=NULL, prefix) {
|
||||
data.frame(
|
||||
input = edgeM[,"inputNode"],
|
||||
output = edgeM[,"outputNode"],
|
||||
impact = as.numeric(edgeM[,"impact"]),
|
||||
impact = edgeM[,"impact"],
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
) else return (
|
||||
data.frame(
|
||||
input = c(prevEdge$input, edgeM[,"inputNode"]),
|
||||
output = c(prevEdge$output, edgeM[,"outputNode"]),
|
||||
impact = c(prevEdge$impact, as.numeric(edgeM[,"impact"])),
|
||||
impact = c(prevEdge$impact, edgeM[,"impact"]),
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
)
|
||||
@@ -317,19 +322,20 @@ parseSheet <- function(fName) {
|
||||
p_op <- parseMapping(readXL(fName,mappings[3], startRow=1), p_ba, prefix='op')
|
||||
p_es <- parseMapping(readXL(fName,mappings[4], startRow=1), p_op, prefix='es')
|
||||
|
||||
print('building graphs')
|
||||
#print('building graphs')
|
||||
|
||||
p_baNet <- buildGraph(p_ba, desc=list(inputCode='p', outputCodes='ba'))
|
||||
p_opNet <- buildGraph(p_op, desc=list(inputCode='p', outputCodes=c('ba', 'op')))
|
||||
p_esNet <- buildGraph(p_es, desc=list(inputCode='p', outputCodes=c('ba', 'op', 'es')))
|
||||
#p_baNet <- buildGraph(p_ba, desc=list(inputCode='p', outputCodes='ba'))
|
||||
#p_opNet <- buildGraph(p_op, desc=list(inputCode='p', outputCodes=c('ba', 'op')))
|
||||
#p_esNet <- buildGraph(p_es, desc=list(inputCode='p', outputCodes=c('ba', 'op', 'es')))
|
||||
|
||||
print('sheet load completed')
|
||||
return(
|
||||
list(
|
||||
pressBioAss = p_baNet,
|
||||
pressOpProc = p_opNet,
|
||||
pressEcoServ = p_esNet
|
||||
)
|
||||
#list(
|
||||
#pressBioAss = p_baNet,
|
||||
#pressOpProc = p_opNet,
|
||||
#pressEcoServ = p_esNet,
|
||||
p_esMap = p_es
|
||||
#)
|
||||
)
|
||||
|
||||
} else {
|
||||
|
||||
489
app.R
489
app.R
@@ -15,20 +15,34 @@ modules::import(shinycssloaders)
|
||||
modules::import(googleway)
|
||||
modules::import(bnlearn)
|
||||
modules::import(visNetwork)
|
||||
modules::import(RColorBrewer)
|
||||
modules::import(zip)
|
||||
modules::import(processx)
|
||||
modules::import(openxlsx)
|
||||
|
||||
|
||||
parser <- modules::use('Parses.R')
|
||||
|
||||
layers <- c("Pressures to Bio-Assemblages", "Bio-Assemblages to Output Processes", "Output Processes to Ecosystem services")
|
||||
transitions <- c("Pressures to Bio-Assemblages", "Pressures to Output Processes", "Pressures to Ecosystem services")
|
||||
impacts <- c('Very High', '>=High', '>=Medium', '>=Low', 'All')
|
||||
thresholds <- c(0.97, 0.9, 0.7, 0.17, 0)
|
||||
thresholds <- c(0.97, 0.9, 0.45, 0.17, 0)
|
||||
impLabels <- c('Very High', 'High', 'Medium', 'Low', 'Very Low')
|
||||
|
||||
legends <- c('Pressures',
|
||||
'Suspension feeders',
|
||||
'Mobile and burrow dwellers',
|
||||
'Predators',
|
||||
'Epifauna and algae',
|
||||
'Functional groups',
|
||||
'Output processes',
|
||||
'Output enablers',
|
||||
'Ecosystem services')
|
||||
|
||||
addResourcePath("js", "./www/js")
|
||||
|
||||
ui<-dashboardPage(
|
||||
dashboardHeader(title = "JNCC MESO online",
|
||||
|
||||
tags$li(
|
||||
id = "dropdownHelp",
|
||||
class = "dropdown",
|
||||
@@ -58,16 +72,17 @@ ui<-dashboardPage(
|
||||
tags$a(
|
||||
href = "Manual.pdf",
|
||||
target = "_BLANK",
|
||||
"Open user guide in a new tab"
|
||||
"Open user guide in tab"
|
||||
)
|
||||
)
|
||||
),
|
||||
tags$li(
|
||||
tags$div(
|
||||
style = "margin-left: auto; margin-right: auto; width: 90%;",
|
||||
downloadLink(
|
||||
"linkBackgroundData",
|
||||
"Download excel sheets"
|
||||
tags$a(
|
||||
href = "Report.pdf",
|
||||
target = "_BLANK",
|
||||
"Open Final Report in tab"
|
||||
)
|
||||
)
|
||||
)
|
||||
@@ -81,6 +96,7 @@ ui<-dashboardPage(
|
||||
#menuItem("Habitats", tabName = "3", icon = icon("atlas")),
|
||||
#menuItem("Ingestion", tabName = "3", icon = icon("utensils")),
|
||||
selectInput("modelSelect", "Select MESO model", choices=c(""), selected=NULL, multiple=FALSE),
|
||||
downloadButton("download", "", icon=icon("download")),
|
||||
uiOutput("pressureList")
|
||||
#selectInput("layerSelect", "Select Transition",
|
||||
# choices=transitions,
|
||||
@@ -96,8 +112,12 @@ ui<-dashboardPage(
|
||||
h4('Effect on bio-assemblage')
|
||||
),
|
||||
column(
|
||||
width=6,
|
||||
width=1,
|
||||
actionButton("layer1Slider", "1", icon=icon("sliders-h"))
|
||||
),
|
||||
column(
|
||||
width=5,
|
||||
strong("Customise sensitivity weightings")
|
||||
)
|
||||
),
|
||||
plotlyOutput("layer1", height="270px") %>% withSpinner(),
|
||||
@@ -108,31 +128,35 @@ ui<-dashboardPage(
|
||||
),
|
||||
tabItem(tabName = "2",h2("Bayesian Network"),
|
||||
fluidPage(
|
||||
p('Graphical output of the Bayesian Network. Note: large networks may never stabilise!'),
|
||||
p('Graphical output of the Bayesian Network. Note: The graph will only draw if pressures are applied!'),
|
||||
fluidRow(
|
||||
column(
|
||||
width=4,
|
||||
checkboxInput("bbnDisplayNames", "Display Node names", value=FALSE)
|
||||
),
|
||||
column(
|
||||
width=4,
|
||||
checkboxInput("bbnDisplayEdges", "Display edge status", value=FALSE)
|
||||
),
|
||||
column(
|
||||
width=4,
|
||||
selectInput("bbnImpactSelect", "Impact Threshold", choices=impacts, selected='All')
|
||||
)
|
||||
),
|
||||
fluidRow(
|
||||
visNetworkOutput("bbnGraphPlot")
|
||||
visNetworkOutput("bbnGraphPlot", width = "100%", height = "1000px")
|
||||
),
|
||||
fluidRow(
|
||||
column(
|
||||
width=6,
|
||||
h4('Ecoservice nodes'),
|
||||
DT::dataTableOutput('nodeTable')
|
||||
),
|
||||
column(
|
||||
width=6,
|
||||
h4('Ecoservice influences'),
|
||||
DT::dataTableOutput('edgeTable')
|
||||
)
|
||||
column(
|
||||
width=6,
|
||||
h4('Ecoservice nodes'),
|
||||
DT::dataTableOutput('nodeTable')
|
||||
),
|
||||
column(
|
||||
width=6,
|
||||
h4('Ecoservice influences'),
|
||||
DT::dataTableOutput('edgeTable')
|
||||
)
|
||||
)
|
||||
)
|
||||
),
|
||||
@@ -164,9 +188,6 @@ server <- function(input, output, session) {
|
||||
models<-NULL
|
||||
pressures <- NULL
|
||||
|
||||
|
||||
#disable(input$loadAb)
|
||||
|
||||
.loadStatus <- reactiveValues(
|
||||
valid = c(p=FALSE, ba=FALSE, op=FALSE, es=FALSE),
|
||||
msgs = NULL
|
||||
@@ -175,68 +196,94 @@ server <- function(input, output, session) {
|
||||
.likelihoods <-reactiveValues(
|
||||
p_ba = NULL,
|
||||
ba_os = NULL,
|
||||
os_es = NULL
|
||||
os_es = NULL,
|
||||
p_es = NULL
|
||||
)
|
||||
|
||||
setPressures <- function(newPressures) {
|
||||
pressures <<- newPressures
|
||||
}
|
||||
|
||||
|
||||
.resistanceScores <- c(
|
||||
ins= -0.01,
|
||||
hr = -0.2,
|
||||
mr = -0.75,
|
||||
lr = -0.95,
|
||||
nr = -0.99,
|
||||
ssgr = 0,
|
||||
pressSD = 0.5
|
||||
)
|
||||
|
||||
validateSheets <- function() {
|
||||
req(inputs$selectFile)
|
||||
|
||||
##TO DO - run parser on it and output the errors to
|
||||
.selections <- reactiveValues(
|
||||
model=1,
|
||||
bbnImpact=1,
|
||||
bbnNames=FALSE,
|
||||
bbnEdges=FALSE,
|
||||
pressStatus=NULL
|
||||
)
|
||||
|
||||
getImpact <- function(v) {
|
||||
print(v)
|
||||
if ((v == "INS") || (v == "IV")) return(.resistanceScores[1])
|
||||
if ((v == "HR") || (v == "III")) return(.resistanceScores[2])
|
||||
if ((v == "MR") || (v == "II")) return(.resistanceScores[3])
|
||||
if ((v == "LR") || (v == "I")) return(.resistanceScores[4])
|
||||
if (v == "NR") return(.resistanceScores[5])
|
||||
as.numeric(v)
|
||||
}
|
||||
|
||||
getAvailableModels <- function() {
|
||||
fileList <- list.files(dataStorage, pattern='.xlsx')
|
||||
|
||||
print(fileList)
|
||||
modelList <- list()
|
||||
cnt<-1
|
||||
|
||||
for (idx in 1:length(fileList)) {
|
||||
print(paste('attempting to load', paste0(dataStorage, fileList[idx])))
|
||||
|
||||
|
||||
tmp <- parser$parseSheet(paste0(dataStorage, fileList[idx]))
|
||||
|
||||
print(tmp)
|
||||
tmp$edges$values <- sapply(tmp$edges$impact, getImpact)
|
||||
|
||||
if (!is.null(tmp)) {
|
||||
modelList[[cnt]] <- tmp
|
||||
models <<- c(models, substr(fileList[idx], 1, (nchar(fileList[idx])-5)))
|
||||
print(paste('Model file successfully loaded', fileList[idx]))
|
||||
save(tmp, file='tmp.RData')
|
||||
cnt=cnt+1
|
||||
|
||||
}
|
||||
}
|
||||
|
||||
updateSelectInput(session, "modelSelect", choices=models)
|
||||
|
||||
return(modelList)
|
||||
}
|
||||
|
||||
|
||||
.selections <- reactiveValues(
|
||||
model=1,
|
||||
layer=1,
|
||||
bbnImpact=1,
|
||||
bbnNames=FALSE,
|
||||
pressStatus=NULL
|
||||
)
|
||||
|
||||
#parse on load sheets in the input sheet folder - replace with R Data
|
||||
modelList <- getAvailableModels()
|
||||
|
||||
calcLikelihood <- function(layer, pressStatus, confLevels) {
|
||||
|
||||
calcLikelihood <- function(layer, pressStatus) {
|
||||
|
||||
isolate({
|
||||
|
||||
if (layer==1) layerStr='ba' else if (layer==2) layerStr='op' else if (layer==3) layerStr='es'
|
||||
#if (layer==1) layerStr='ba' else if (layer==2) layerStr='op' else if (layer==3) layerStr='es'
|
||||
|
||||
layerRange <- which(startsWith(modelList[[.selections$model]][[3]]$nodes$code, layerStr))
|
||||
|
||||
nodeCodes <- modelList[[.selections$model]][[layer]]$nodes$code[layerRange]
|
||||
nodeNames <- modelList[[.selections$model]][[layer]]$nodes$name[layerRange]
|
||||
|
||||
|
||||
#layerRange <- which(startsWith(thisModel$nodes$code, layerStr))
|
||||
|
||||
#nodeCodes <-thisModel$nodes$code[layerRange]
|
||||
#nodeNames <- thisModel$nodes$name[layerRange]
|
||||
|
||||
thisModel <- modelList[[.selections$model]]
|
||||
|
||||
modelList[[.selections$model]]$edges$values <<- sapply(thisModel$edges$impact, getImpact)
|
||||
modelList[[.selections$model]]$nodes$growth <<- .resistanceScores['ssgr']
|
||||
modelList[[.selections$model]]$nodes$confidence <<- .resistanceScores['pressSD']
|
||||
|
||||
thisModel <- modelList[[.selections$model]]
|
||||
|
||||
|
||||
MEANPOS=1
|
||||
MEANNEG=0
|
||||
|
||||
@@ -253,13 +300,11 @@ server <- function(input, output, session) {
|
||||
expr <-substr(expr, 1, nchar(expr)-2)
|
||||
expr<-paste0(expr, ')')
|
||||
|
||||
|
||||
#build the graph
|
||||
#parser$buildGraph(p_es, desc=list(inputCode='p', outputCodes=c('ba', 'op', 'es')))
|
||||
thisNet <- parser$buildGraph(thisModel, desc=list(inputCode='p', outputCodes=c('ba', 'op', 'es')))
|
||||
|
||||
sampleDists <- cpdist(
|
||||
fitted = modelList[[.selections$model]][[layer]]$cfit,
|
||||
nodes = bnlearn::nodes(modelList[[.selections$model]][[layer]]$cfit),
|
||||
fitted = thisNet$cfit,
|
||||
nodes = bnlearn::nodes(thisNet$cfit),
|
||||
evidence = eval(parse(text = expr)),
|
||||
method = "lw",
|
||||
n = 10000,
|
||||
@@ -267,13 +312,19 @@ server <- function(input, output, session) {
|
||||
)
|
||||
})
|
||||
|
||||
displayCols <- match(nodeCodes, colnames(sampleDists))
|
||||
sampleDists <- sampleDists[,displayCols]
|
||||
print(sampleDists)
|
||||
|
||||
#displayCols <- match(nodeCodes, colnames(sampleDists))
|
||||
sampleDists <- sampleDists[,match(thisModel$nodes$code, colnames(sampleDists))]
|
||||
means <- apply(sampleDists, 2, mean)
|
||||
stdDev <- apply(sampleDists, 2, sd)
|
||||
|
||||
print(paste('Building likelihoods from model, sample dists', length(thisModel$nodes$name), length(sampleDists)))
|
||||
|
||||
return(data.frame(
|
||||
nodeNames = nodeNames,
|
||||
name = thisModel$nodes$name,
|
||||
code = thisModel$nodes$code,
|
||||
layer = thisModel$nodes$layer,
|
||||
range = c(
|
||||
apply(sampleDists, 2, min),
|
||||
means - 2*stdDev,
|
||||
@@ -286,40 +337,12 @@ server <- function(input, output, session) {
|
||||
stringsAsFactors=FALSE
|
||||
))
|
||||
}
|
||||
|
||||
renderStatus <- function(layer) {
|
||||
isolate({
|
||||
if (.loadStatus$valid[layer]) return('check-square') else return('times-circle')
|
||||
})
|
||||
}
|
||||
|
||||
output$status <- renderUI({
|
||||
|
||||
tagList(
|
||||
fluidRow(
|
||||
column(width=3, h4('Pressures')),
|
||||
column(width=3, h4('Bio-assemblages')),
|
||||
column(width=3, h4('Output processes')),
|
||||
column(width=3, h4('Ecosystem services'))
|
||||
),
|
||||
fluidRow(
|
||||
column(width=3, icon(renderStatus(1))),
|
||||
column(width=3, icon(renderStatus(2))),
|
||||
column(width=3, icon(renderStatus(3))),
|
||||
column(width=3, icon(renderStatus(4)))
|
||||
)
|
||||
)
|
||||
})
|
||||
|
||||
|
||||
observeEvent(input$modelSelect, {
|
||||
.selections$model <<- match(input$modelSelect, models)
|
||||
})
|
||||
|
||||
#observeEvent(input$layerSelect, {
|
||||
# .selections$layer <<- match(input$layerSelect, transitions)
|
||||
#})
|
||||
|
||||
observeEvent(reactiveValuesToList(input), {
|
||||
isolate(myList <- reactiveValuesToList(input))
|
||||
matches <- match(pressures$code, names(myList))
|
||||
@@ -332,44 +355,27 @@ server <- function(input, output, session) {
|
||||
|
||||
if (!identical(newStatus, .selections$pressStatus)) {
|
||||
print('Running calc')
|
||||
.likelihoods$p_ba <<- calcLikelihood(1, newStatus)
|
||||
.likelihoods$ba_os <<- calcLikelihood(2, newStatus)
|
||||
.likelihoods$os_es <<- calcLikelihood(3, newStatus)
|
||||
|
||||
#.likelihoods$p_ba <<- calcLikelihood(1, newStatus)
|
||||
#.likelihoods$ba_os <<- calcLikelihood(2, newStatus)
|
||||
#.likelihoods$os_es <<- calcLikelihood(3, newStatus)
|
||||
.likelihoods$p_es <<- calcLikelihood(0, newStatus)
|
||||
write.xlsx(.likelihoods$p_es, 'tmp.xlsx')
|
||||
.selections$pressStatus <<- newStatus
|
||||
}
|
||||
|
||||
}
|
||||
sliderControls <- c("l1VH", "l1H", "l1M", "l1L", "l1VL", "l1Conf")
|
||||
matches <- match(sliderControls, names(myList))
|
||||
if (length(matches)>0) {
|
||||
print(matches)
|
||||
}
|
||||
})
|
||||
|
||||
#output$map <- renderGoogle_map({
|
||||
# google_map(location = c(55, 0), zoom = 7)
|
||||
#})
|
||||
|
||||
makeRadioButtons <- function(row) {
|
||||
radioButtons(row['code'], row['name'], choices=c('Off', 'On'), selected='Off', inline=TRUE)
|
||||
}
|
||||
|
||||
output$linkBackgroundData <- downloadHandler(
|
||||
filename = "JNCC MESO.xlsx",
|
||||
content = function(file) {
|
||||
file.copy("JNCC MESO.xlsx", file)
|
||||
},
|
||||
contentType = "application/xlsx"
|
||||
)
|
||||
|
||||
|
||||
output$pressureList <- renderUI({
|
||||
#isolate({
|
||||
if (!is.null(modelList[[.selections$model]][[1]]$nodes)) {
|
||||
pressCodes <- which(startsWith(modelList[[.selections$model]][[1]]$nodes$code, 'p'))
|
||||
pressures <- data.frame(code = modelList[[.selections$model]][[1]]$nodes$code[pressCodes],
|
||||
name = modelList[[.selections$model]][[1]]$nodes$name[pressCodes], stringsAsFactors=FALSE)
|
||||
if (!is.null(modelList[[.selections$model]]$nodes)) {
|
||||
pressCodes <- which(startsWith(modelList[[.selections$model]]$nodes$code, 'p'))
|
||||
pressures <- data.frame(code = modelList[[.selections$model]]$nodes$code[pressCodes],
|
||||
name = modelList[[.selections$model]]$nodes$name[pressCodes], stringsAsFactors=FALSE)
|
||||
setPressures(pressures)
|
||||
btnList <- apply(pressures, 1, makeRadioButtons)
|
||||
}
|
||||
@@ -386,90 +392,110 @@ server <- function(input, output, session) {
|
||||
print(.selections$bbnNames)
|
||||
})
|
||||
|
||||
observeEvent(input$bbnDisplayEdges, {
|
||||
.selections$bbnEdges <- input$bbnDisplayEdges
|
||||
|
||||
})
|
||||
|
||||
|
||||
observeEvent(input$layer1Slider, {
|
||||
showModal(
|
||||
modalDialog({
|
||||
tagList(
|
||||
sliderInput("l1VH", "Very High Sensitivity", 0.9, 1.0, 0.99, step=0.01),
|
||||
sliderInput("l1H", "High Sensitivity", 0.75, 1.0, 0.95, step=0.01),
|
||||
sliderInput("l1M", "Medium Sensitivity", 0.5, 0.75, 0.95, step=0.01),
|
||||
sliderInput("l1L", "Low Sensitivity", 0.15, 0.5, 0.2, step=0.01),
|
||||
sliderInput("l1VL", "Very Low Sensitivity", 0.01, 0.2, 0.15, step=0.01),
|
||||
sliderInput("pressStdDev", "Pressure SD", 0.1, 1, 0.5, step=0.1),
|
||||
sliderInput("baStdDev", "Bio-Assemblage SD", 0.1, 1, 0.5, step=0.1)
|
||||
sliderInput("l1VL", "Insensitive", 0.01, 0.2, abs(.resistanceScores[1]), step=0.01),
|
||||
sliderInput("l1L", "Low Sensitivity/High resistance", 0.15, 0.5, abs(.resistanceScores[2]), step=0.01),
|
||||
sliderInput("l1M", "Medium Sensitivity/Med resistance", 0.5, 0.75, abs(.resistanceScores[3]), step=0.01),
|
||||
sliderInput("l1H", "High Sensitivity/Low resistance", 0.75, 1.0, abs(.resistanceScores[4]), step=0.01),
|
||||
sliderInput("l1VH", "Very High Sensitivity/No resistance", 0.9, 1.0, abs(.resistanceScores[5]), step=0.01),
|
||||
sliderInput("ssgr", "Steady state growth rate", -0.1, 0.1,.resistanceScores[6], step=0.01),
|
||||
sliderInput("l1PressSD", "Pressure Std Dev", 0.1, 1.0, .resistanceScores[7], step=0.01)
|
||||
)
|
||||
}, title='Layer 1 controls', size='s')
|
||||
},
|
||||
title='Layer 1 controls',
|
||||
footer=tagList(
|
||||
modalButton("Cancel"),
|
||||
actionButton("modalOK", "OK")
|
||||
),
|
||||
size='s')
|
||||
)
|
||||
})
|
||||
|
||||
|
||||
|
||||
observeEvent(input$modalOK, {
|
||||
print('Modal ok pressed')
|
||||
|
||||
.resistanceScores['nr'] <<- -input$l1VH
|
||||
.resistanceScores['lr'] <<- -input$l1H
|
||||
.resistanceScores['mr'] <<- -input$l1M
|
||||
.resistanceScores['hr'] <<- -input$l1L
|
||||
.resistanceScores['ins'] <<- -input$l1VL
|
||||
.resistanceScores['ssgr'] <<- input$ssgr
|
||||
.resistanceScores['pressSD'] <<- input$l1PressSD
|
||||
|
||||
print('Running calc')
|
||||
#.likelihoods$p_ba <<- calcLikelihood(1, .selections$pressStatus)
|
||||
#.likelihoods$ba_os <<- calcLikelihood(2, .selections$pressStatus)
|
||||
#.likelihoods$os_es <<- calcLikelihood(3, .selections$pressStatus)
|
||||
.likelihoods$p_es <<- calcLikelihood(0, .selections$pressStatus)
|
||||
removeModal()
|
||||
|
||||
})
|
||||
|
||||
|
||||
output$nodeTable <- DT::renderDataTable(
|
||||
|
||||
modelList[[.selections$model]][[.selections$layer]]$nodes,
|
||||
modelList[[.selections$model]]$nodes,
|
||||
selection = 'single',options = list(searching = TRUE, pageLength = 10, editable=TRUE),server = TRUE, escape = FALSE,rownames= TRUE
|
||||
)
|
||||
|
||||
output$edgeTable <- DT::renderDataTable(
|
||||
|
||||
modelList[[.selections$model]][[.selections$layer]]$edges,
|
||||
modelList[[.selections$model]]$edges,
|
||||
selection = 'single',options = list(searching = TRUE, pageLength = 10, editable=TRUE),server = TRUE, escape = FALSE,rownames= TRUE
|
||||
)
|
||||
|
||||
getLabel <- function(impact) {
|
||||
sign <- ifelse(impact<0, "-", "+")
|
||||
idx <- min(which((abs(impact)>=thresholds)==TRUE))
|
||||
getLabel <- function(value) {
|
||||
sign <- ifelse(value<0, "-", "+")
|
||||
idx <- min(which((abs(value)>=thresholds)==TRUE))
|
||||
return(paste0(sign, impLabels[idx]))
|
||||
}
|
||||
|
||||
getLevels <- function(code) {
|
||||
if (startsWith(code, 'p')) return(1)
|
||||
else if (startsWith(code, 'ba')) return(2)
|
||||
else if (startsWith(code, 'op')) return(3)
|
||||
else if (startsWith(code, 'es')) return(4)
|
||||
else return(5)
|
||||
}
|
||||
|
||||
|
||||
output$bbnGraphPlot <- renderVisNetwork({
|
||||
#graphviz.plot(modelList[[.selections$model]][[.selections$layer]]$net)
|
||||
|
||||
nodes <- modelList[[.selections$model]][[.selections$layer]]$nodes
|
||||
|
||||
makeBbnGraph <- function(model) {
|
||||
nodes <- model$nodes
|
||||
|
||||
if (.selections$bbnEdges) {labels <- sapply(model$edges$values, getLabel)} else {labels <- rep("", nrow(model$edges))}
|
||||
|
||||
edges <- data.frame(
|
||||
id = rownames(modelList[[.selections$model]][[.selections$layer]]$edges),
|
||||
from=match(modelList[[.selections$model]][[.selections$layer]]$edges$input, nodes$name),
|
||||
to=match(modelList[[.selections$model]][[.selections$layer]]$edges$output, nodes$name),
|
||||
impact=modelList[[.selections$model]][[.selections$layer]]$edges$impact,
|
||||
label=sapply(modelList[[.selections$model]][[.selections$layer]]$edges$impact, getLabel),
|
||||
id = rownames(model$edges),
|
||||
from=match(model$edges$input, nodes$code),
|
||||
to=match(model$edges$output, nodes$code),
|
||||
values=model$edges$values,
|
||||
label=labels,
|
||||
arrows="to",
|
||||
stringsAsFactors=FALSE
|
||||
)
|
||||
if (.selections$bbnNames) {labels <- nodes$name} else {labels <- nodes$code}
|
||||
|
||||
|
||||
nodeSpacing <- ifelse(.selections$bbnNames, 600, 150)
|
||||
|
||||
palette <- brewer.pal(length(legends), "RdYlGn")
|
||||
|
||||
nodes <- data.frame(
|
||||
id = rownames(nodes),
|
||||
label = labels,
|
||||
level = sapply(nodes$code, getLevels),
|
||||
level = nodes$layer,
|
||||
group = nodes$layer,
|
||||
color = palette[as.integer(nodes$layer)],
|
||||
code = nodes$code,
|
||||
stringsAsFactors=FALSE
|
||||
)
|
||||
|
||||
|
||||
|
||||
edges <- edges[(abs(edges$impact)>=.selections$bbnImpact),]
|
||||
edges <- edges[(abs(edges$values)>=.selections$bbnImpact),]
|
||||
|
||||
nodeNet <- nodes[(nodes$code %in% .selections$pressStatus$code[.selections$pressStatus$status %in% c('On')]),]
|
||||
|
||||
save(nodes, edges, nodeNet, file = 'tmp.RData')
|
||||
|
||||
|
||||
if (nrow(nodeNet)>0) {
|
||||
|
||||
#do pressures
|
||||
edgeNet <- edges[edges$from %in% nodeNet$id, ]
|
||||
idx = 1
|
||||
@@ -484,70 +510,129 @@ server <- function(input, output, session) {
|
||||
if ((idx>20) || ((nrow(nodesToAdd)==0) && (nrow(edgesToAdd)==0))) break
|
||||
nodeNet <- rbind(nodeNet, nodesToAdd)
|
||||
edgeNet <- rbind(edgeNet, edgesToAdd)
|
||||
|
||||
|
||||
} #until finished
|
||||
} else edgeNet <- edges
|
||||
|
||||
visNetwork(nodeNet, edgeNet, width = "100%") %>%
|
||||
visHierarchicalLayout(nodeSpacing=nodeSpacing) %>%
|
||||
visOptions(highlightNearest = TRUE) %>%
|
||||
#visPhysics(hierarchicalRepulsion = nodeSpacing) %>%
|
||||
visInteraction(navigationButtons = TRUE, dragNodes = TRUE, dragView = TRUE, zoomView = TRUE)
|
||||
legendDF <- data.frame(
|
||||
id = 1:length(legends),
|
||||
label = legends,
|
||||
color = palette,
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
|
||||
visNetwork(nodeNet, edgeNet, width = "100%", main='Bayesian Belief Network', submain=input$modelSelect) %>%
|
||||
visExport() %>%
|
||||
visLegend(useGroups=FALSE, addNodes=legendDF) %>%
|
||||
visHierarchicalLayout(nodeSpacing=nodeSpacing, direction='LR') %>%
|
||||
visOptions(highlightNearest = TRUE) #%>%
|
||||
#visInteraction(navigationButtons = TRUE, dragNodes = TRUE, dragView = TRUE, zoomView = TRUE)
|
||||
}
|
||||
|
||||
output$bbnGraphPlot <- renderVisNetwork({
|
||||
makeBbnGraph(modelList[[.selections$model]])
|
||||
})
|
||||
|
||||
observe({
|
||||
visNetworkProxy("bbnGraphPlot") %>%
|
||||
visStabilize(iterations=10)
|
||||
})
|
||||
#observe({
|
||||
# visNetworkProxy("bbnGraphPlot") %>%
|
||||
# visStabilize(iterations=10)
|
||||
#})
|
||||
|
||||
getModelName <- function() {
|
||||
paste0('data/', input$modelSelect, '.xlsx')
|
||||
}
|
||||
|
||||
genPlot <- function(boxPlot, title) {
|
||||
if (nrow(boxPlot)>0) {
|
||||
|
||||
palette <- brewer.pal(length(legends), "RdYlGn")
|
||||
#print(palette)
|
||||
|
||||
colours <- palette[as.integer(boxPlot$Group)]
|
||||
|
||||
#print(paste('Box plot, colours', nrow(boxPlot), length(colours)))
|
||||
#cat(colours)
|
||||
xform <- list(categoryorder = "array",
|
||||
categoryarray = boxPlot[,1],
|
||||
zerolinewidth=10)
|
||||
#
|
||||
plot_ly(boxPlot, x = boxPlot[,1], y = ~Range, color = colours, colors = palette, type = "box") %>%
|
||||
layout(xaxis = xform, showlegend=FALSE, title=title)
|
||||
|
||||
}
|
||||
}
|
||||
|
||||
prepPlot <- function(code="ba", name="Bio-Assemblage") {
|
||||
if (!is.null(.likelihoods$p_es)) {
|
||||
inScope <- startsWith(.likelihoods$p_es$code, code)
|
||||
thisPlot <- .likelihoods$p_es[inScope, c(1,3,4)]
|
||||
colnames(thisPlot) <- c(name, "Group", "Range")
|
||||
title <- paste(input$modelSelect, name, 'Box Plot')
|
||||
genPlot(thisPlot, title)
|
||||
}
|
||||
}
|
||||
|
||||
output$layer1 <- renderPlotly({
|
||||
if (length(.likelihoods$p_ba)>0) {
|
||||
|
||||
.likelihoods$p_ba$nodeNames <- factor(.likelihoods$p_ba$nodeNames, levels = unique(.likelihoods$p_ba$nodeNames))
|
||||
|
||||
xform <- list(categoryorder = "array",
|
||||
categoryarray = .likelihoods$p_ba$nodeNames,
|
||||
zerolinewidth=10)
|
||||
|
||||
plot_ly(.likelihoods$p_ba, y = ~range, color = ~nodeNames, type = "box") %>%
|
||||
layout(xaxis = xform)
|
||||
|
||||
}
|
||||
prepPlot("ba", "Bio-Assemblage")
|
||||
})
|
||||
|
||||
|
||||
output$layer2 <- renderPlotly({
|
||||
if (length(.likelihoods$ba_os)>0) {
|
||||
|
||||
.likelihoods$ba_os$nodeNames <- factor(.likelihoods$ba_os$nodeNames, levels = unique(.likelihoods$ba_os$nodeNames))
|
||||
|
||||
xform <- list(categoryorder = "array",
|
||||
categoryarray = .likelihoods$ba_os$nodeNames,
|
||||
zerolinewidth=5)
|
||||
|
||||
|
||||
plot_ly(.likelihoods$ba_os, y = ~range, color = ~nodeNames, type = "box") %>%
|
||||
layout(xaxis = xform)
|
||||
|
||||
}
|
||||
prepPlot("op", "Output Processes")
|
||||
})
|
||||
|
||||
|
||||
output$layer3 <- renderPlotly({
|
||||
|
||||
if (length(.likelihoods$os_es)>0) {
|
||||
|
||||
.likelihoods$os_es$nodeNames <- factor(.likelihoods$os_es$nodeNames, levels = unique(.likelihoods$os_es$nodeNames))
|
||||
|
||||
xform <- list(categoryorder = "array",
|
||||
categoryarray = .likelihoods$os_es$nodeNames,
|
||||
zerolinewidth=5)
|
||||
|
||||
|
||||
plot_ly(.likelihoods$os_es, y = ~range, color = ~nodeNames, type = "box") %>%
|
||||
layout(xaxis = xform)
|
||||
|
||||
}
|
||||
prepPlot("es", "Ecosystem Services")
|
||||
})
|
||||
|
||||
|
||||
export <- function(model) {
|
||||
|
||||
#Get the network graph
|
||||
l1 <- orca(prepPlot("ba", "Bio-Assemblage"), 'tmp/layer1.png')
|
||||
l2 <- orca(prepPlot("op", "Output Processes"),'tmp/layer2.png')
|
||||
l3 <- orca(prepPlot("es", "Ecosystem Services"), 'tmp/layer3.png')
|
||||
|
||||
#Save pressure list, confidence levels, node and edge tables in xlsx
|
||||
l <- list(
|
||||
pressures = .selections$pressStatus,
|
||||
nodes = model$nodes,
|
||||
edges = model$edges,
|
||||
settings = as.data.frame(cbind(names(.resistanceScores), .resistanceScores), stringsAsFactors=FALSE)
|
||||
)
|
||||
|
||||
xl <- write.xlsx(l, 'tmp/dataset.xlsx')
|
||||
|
||||
print('saving xlsx file export tmp/dataset.xlsx')
|
||||
|
||||
zipFile <- zipr(paste0('MESO-', format(Sys.time(), "%m%d_%H%M"), '.zip'), c('tmp/layer1.png', 'tmp/layer2.png', 'tmp/layer3.png', 'tmp/dataset.xlsx'))
|
||||
|
||||
print(paste('zip file complete', zipFile))
|
||||
|
||||
return(zipFile)
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
output$linkBackgroundData <- downloadHandler(
|
||||
filename = getModelName(),
|
||||
content = function(file) {
|
||||
file.copy(getModelName(), file)
|
||||
},
|
||||
contentType = "application/xlsx"
|
||||
)
|
||||
|
||||
output$download <-downloadHandler(
|
||||
filename = paste0('MESO-', format(Sys.time(), "%m%d_%H%M"), '.zip'),
|
||||
content = function(file) {
|
||||
fName <- export(modelList[[.selections$model]])
|
||||
file.copy(fName, file)
|
||||
},
|
||||
contentType = "application/zip"
|
||||
)
|
||||
|
||||
|
||||
}
|
||||
|
||||
shinyApp(ui, server)
|
||||
Reference in New Issue
Block a user