JNCC/MESO
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Updates to downloads and colour graphics

Browse Source
This commit is contained in:
Steve Pegg
2019-04-10 10:57:37 +01:00
parent b2e7a363cb
commit 9b039297a0
2 changed files with 311 additions and 220 deletions
Download Patch File Download Diff File Expand all files Collapse all files

42
Parses.R
View File

@@ -14,7 +14,7 @@ FIRST_NODE_COL <- 3
mappings <- c('TestScenario', 'Map_P_BA', 'Map_BA_OP', 'Map_OP_ES') mappings <- c('TestScenario', 'Map_P_BA', 'Map_BA_OP', 'Map_OP_ES')
nodeTypes <- c('Input.Nodes', 'Internal.Nodes', 'Published.Nodes') 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)) refs <-c(1:length(mappings))
setEmpties <- function(val) { setEmpties <- function(val) {
@@ -46,9 +46,9 @@ buildExpr <- function(pressStatus) {
parseScenario <- function(press, prefix = 'p') { parseScenario <- function(press, prefix = 'p') {
pressNames <- colnames(press)[2:length(colnames(press))] 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)) { 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 press[is.na(press)] <- 0
if (sum(duplicated(pressNames))>0) { if (sum(duplicated(pressNames))>0) {
@@ -62,6 +62,7 @@ parseScenario <- function(press, prefix = 'p') {
code=paste0(prefix, seq(1:length(pressNames))), code=paste0(prefix, seq(1:length(pressNames))),
growth = coefs[,'growth'], growth = coefs[,'growth'],
confidence=coefs[,'confidence'], confidence=coefs[,'confidence'],
layer=coefs[,'layer'],
stringsAsFactors = FALSE), stringsAsFactors = FALSE),
edges=data.frame(input=NULL, output=NULL, impact=NULL) 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)), "]")) edges <- paste0(edges, paste0("[", outNodes[idx], "|", substr(inputsStr, start=1, stop=(nchar(inputsStr)-1)), "]"))
#Make the coefficient of the distribution #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]) c("(Intercept)", model$edges$input[rows])
) )
#str(coefVal) #str(coefVal)
@@ -136,8 +137,9 @@ buildGraph <- function(model, desc) {
} }
print('about to build network') 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') 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)) { for (idx in 1:length(outNodes)) {
col <- match(outNodes[idx], colnames(mapping)) 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( return(data.frame(
code=c(prevOutputs$code, paste0(prefix, seq(1:length(outNodes)))), code=c(prevOutputs$code, paste0(prefix, seq(1:length(outNodes)))),
name=c(prevOutputs$name, outNodes), name=c(prevOutputs$name, outNodes),
growth=c(prevOutputs$growth, coefs[,"growth"]), growth=c(prevOutputs$growth, coefs[,"growth"]),
confidence=c(prevOutputs$confidence, coefs[,"confidence"]), confidence=c(prevOutputs$confidence, coefs[,"confidence"]),
layer=c(prevOutputs$layer, coefs[,"layer"]),
stringsAsFactors=FALSE stringsAsFactors=FALSE
)) ))
} }
@@ -266,14 +271,14 @@ getValidEdges <- function(mapping, nodeDF, prevEdge=NULL, prefix) {
data.frame( data.frame(
input = edgeM[,"inputNode"], input = edgeM[,"inputNode"],
output = edgeM[,"outputNode"], output = edgeM[,"outputNode"],
impact = as.numeric(edgeM[,"impact"]), impact = edgeM[,"impact"],
stringsAsFactors = FALSE stringsAsFactors = FALSE
) )
) else return ( ) else return (
data.frame( data.frame(
input = c(prevEdge$input, edgeM[,"inputNode"]), input = c(prevEdge$input, edgeM[,"inputNode"]),
output = c(prevEdge$output, edgeM[,"outputNode"]), output = c(prevEdge$output, edgeM[,"outputNode"]),
impact = c(prevEdge$impact, as.numeric(edgeM[,"impact"])), impact = c(prevEdge$impact, edgeM[,"impact"]),
stringsAsFactors = FALSE stringsAsFactors = FALSE
) )
) )
@@ -317,19 +322,20 @@ parseSheet <- function(fName) {
p_op <- parseMapping(readXL(fName,mappings[3], startRow=1), p_ba, prefix='op') 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') 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_baNet <- buildGraph(p_ba, desc=list(inputCode='p', outputCodes='ba'))
p_opNet <- buildGraph(p_op, desc=list(inputCode='p', outputCodes=c('ba', 'op'))) #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_esNet <- buildGraph(p_es, desc=list(inputCode='p', outputCodes=c('ba', 'op', 'es')))
print('sheet load completed') print('sheet load completed')
return( return(
list( #list(
pressBioAss = p_baNet, #pressBioAss = p_baNet,
pressOpProc = p_opNet, #pressOpProc = p_opNet,
pressEcoServ = p_esNet #pressEcoServ = p_esNet,
) p_esMap = p_es
#)
) )
} else { } else {

435
app.R
View File

@@ -15,20 +15,34 @@ modules::import(shinycssloaders)
modules::import(googleway) modules::import(googleway)
modules::import(bnlearn) modules::import(bnlearn)
modules::import(visNetwork) modules::import(visNetwork)
modules::import(RColorBrewer)
modules::import(zip)
modules::import(processx)
modules::import(openxlsx)
parser <- modules::use('Parses.R') parser <- modules::use('Parses.R')
layers <- c("Pressures to Bio-Assemblages", "Bio-Assemblages to Output Processes", "Output Processes to Ecosystem services") 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") transitions <- c("Pressures to Bio-Assemblages", "Pressures to Output Processes", "Pressures to Ecosystem services")
impacts <- c('Very High', '>=High', '>=Medium', '>=Low', 'All') 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') 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") addResourcePath("js", "./www/js")
ui<-dashboardPage( ui<-dashboardPage(
dashboardHeader(title = "JNCC MESO online", dashboardHeader(title = "JNCC MESO online",
tags$li( tags$li(
id = "dropdownHelp", id = "dropdownHelp",
class = "dropdown", class = "dropdown",
@@ -58,16 +72,17 @@ ui<-dashboardPage(
tags$a( tags$a(
href = "Manual.pdf", href = "Manual.pdf",
target = "_BLANK", target = "_BLANK",
"Open user guide in a new tab" "Open user guide in tab"
) )
) )
), ),
tags$li( tags$li(
tags$div( tags$div(
style = "margin-left: auto; margin-right: auto; width: 90%;", style = "margin-left: auto; margin-right: auto; width: 90%;",
downloadLink( tags$a(
"linkBackgroundData", href = "Report.pdf",
"Download excel sheets" target = "_BLANK",
"Open Final Report in tab"
) )
) )
) )
@@ -81,6 +96,7 @@ ui<-dashboardPage(
#menuItem("Habitats", tabName = "3", icon = icon("atlas")), #menuItem("Habitats", tabName = "3", icon = icon("atlas")),
#menuItem("Ingestion", tabName = "3", icon = icon("utensils")), #menuItem("Ingestion", tabName = "3", icon = icon("utensils")),
selectInput("modelSelect", "Select MESO model", choices=c(""), selected=NULL, multiple=FALSE), selectInput("modelSelect", "Select MESO model", choices=c(""), selected=NULL, multiple=FALSE),
downloadButton("download", "", icon=icon("download")),
uiOutput("pressureList") uiOutput("pressureList")
#selectInput("layerSelect", "Select Transition", #selectInput("layerSelect", "Select Transition",
# choices=transitions, # choices=transitions,
@@ -96,8 +112,12 @@ ui<-dashboardPage(
h4('Effect on bio-assemblage') h4('Effect on bio-assemblage')
), ),
column( column(
width=6, width=1,
actionButton("layer1Slider", "1", icon=icon("sliders-h")) actionButton("layer1Slider", "1", icon=icon("sliders-h"))
),
column(
width=5,
strong("Customise sensitivity weightings")
) )
), ),
plotlyOutput("layer1", height="270px") %>% withSpinner(), plotlyOutput("layer1", height="270px") %>% withSpinner(),
@@ -108,19 +128,23 @@ ui<-dashboardPage(
), ),
tabItem(tabName = "2",h2("Bayesian Network"), tabItem(tabName = "2",h2("Bayesian Network"),
fluidPage( 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( fluidRow(
column( column(
width=4, width=4,
checkboxInput("bbnDisplayNames", "Display Node names", value=FALSE) checkboxInput("bbnDisplayNames", "Display Node names", value=FALSE)
), ),
column(
width=4,
checkboxInput("bbnDisplayEdges", "Display edge status", value=FALSE)
),
column( column(
width=4, width=4,
selectInput("bbnImpactSelect", "Impact Threshold", choices=impacts, selected='All') selectInput("bbnImpactSelect", "Impact Threshold", choices=impacts, selected='All')
) )
), ),
fluidRow( fluidRow(
visNetworkOutput("bbnGraphPlot") visNetworkOutput("bbnGraphPlot", width = "100%", height = "1000px")
), ),
fluidRow( fluidRow(
column( column(
@@ -164,9 +188,6 @@ server <- function(input, output, session) {
models<-NULL models<-NULL
pressures <- NULL pressures <- NULL
#disable(input$loadAb)
.loadStatus <- reactiveValues( .loadStatus <- reactiveValues(
valid = c(p=FALSE, ba=FALSE, op=FALSE, es=FALSE), valid = c(p=FALSE, ba=FALSE, op=FALSE, es=FALSE),
msgs = NULL msgs = NULL
@@ -175,23 +196,46 @@ server <- function(input, output, session) {
.likelihoods <-reactiveValues( .likelihoods <-reactiveValues(
p_ba = NULL, p_ba = NULL,
ba_os = NULL, ba_os = NULL,
os_es = NULL os_es = NULL,
p_es = NULL
) )
setPressures <- function(newPressures) { setPressures <- function(newPressures) {
pressures <<- newPressures pressures <<- newPressures
} }
validateSheets <- function() {
req(inputs$selectFile)
##TO DO - run parser on it and output the errors to .resistanceScores <- c(
ins= -0.01,
hr = -0.2,
mr = -0.75,
lr = -0.95,
nr = -0.99,
ssgr = 0,
pressSD = 0.5
)
.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() { getAvailableModels <- function() {
fileList <- list.files(dataStorage, pattern='.xlsx') fileList <- list.files(dataStorage, pattern='.xlsx')
print(fileList)
modelList <- list() modelList <- list()
cnt<-1 cnt<-1
@@ -199,43 +243,46 @@ server <- function(input, output, session) {
print(paste('attempting to load', paste0(dataStorage, fileList[idx]))) print(paste('attempting to load', paste0(dataStorage, fileList[idx])))
tmp <- parser$parseSheet(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)) { if (!is.null(tmp)) {
modelList[[cnt]] <- tmp modelList[[cnt]] <- tmp
models <<- c(models, substr(fileList[idx], 1, (nchar(fileList[idx])-5))) models <<- c(models, substr(fileList[idx], 1, (nchar(fileList[idx])-5)))
print(paste('Model file successfully loaded', fileList[idx])) print(paste('Model file successfully loaded', fileList[idx]))
save(tmp, file='tmp.RData')
cnt=cnt+1 cnt=cnt+1
} }
} }
updateSelectInput(session, "modelSelect", choices=models) updateSelectInput(session, "modelSelect", choices=models)
return(modelList) 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 #parse on load sheets in the input sheet folder - replace with R Data
modelList <- getAvailableModels() modelList <- getAvailableModels()
calcLikelihood <- function(layer, pressStatus, confLevels) {
calcLikelihood <- function(layer, pressStatus) {
isolate({ 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 MEANPOS=1
MEANNEG=0 MEANNEG=0
@@ -253,13 +300,11 @@ server <- function(input, output, session) {
expr <-substr(expr, 1, nchar(expr)-2) expr <-substr(expr, 1, nchar(expr)-2)
expr<-paste0(expr, ')') expr<-paste0(expr, ')')
thisNet <- parser$buildGraph(thisModel, desc=list(inputCode='p', outputCodes=c('ba', 'op', 'es')))
#build the graph
#parser$buildGraph(p_es, desc=list(inputCode='p', outputCodes=c('ba', 'op', 'es')))
sampleDists <- cpdist( sampleDists <- cpdist(
fitted = modelList[[.selections$model]][[layer]]$cfit, fitted = thisNet$cfit,
nodes = bnlearn::nodes(modelList[[.selections$model]][[layer]]$cfit), nodes = bnlearn::nodes(thisNet$cfit),
evidence = eval(parse(text = expr)), evidence = eval(parse(text = expr)),
method = "lw", method = "lw",
n = 10000, n = 10000,
@@ -267,13 +312,19 @@ server <- function(input, output, session) {
) )
}) })
displayCols <- match(nodeCodes, colnames(sampleDists)) print(sampleDists)
sampleDists <- sampleDists[,displayCols]
#displayCols <- match(nodeCodes, colnames(sampleDists))
sampleDists <- sampleDists[,match(thisModel$nodes$code, colnames(sampleDists))]
means <- apply(sampleDists, 2, mean) means <- apply(sampleDists, 2, mean)
stdDev <- apply(sampleDists, 2, sd) stdDev <- apply(sampleDists, 2, sd)
print(paste('Building likelihoods from model, sample dists', length(thisModel$nodes$name), length(sampleDists)))
return(data.frame( return(data.frame(
nodeNames = nodeNames, name = thisModel$nodes$name,
code = thisModel$nodes$code,
layer = thisModel$nodes$layer,
range = c( range = c(
apply(sampleDists, 2, min), apply(sampleDists, 2, min),
means - 2*stdDev, means - 2*stdDev,
@@ -287,39 +338,11 @@ server <- function(input, output, session) {
)) ))
} }
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, { observeEvent(input$modelSelect, {
.selections$model <<- match(input$modelSelect, models) .selections$model <<- match(input$modelSelect, models)
}) })
#observeEvent(input$layerSelect, {
# .selections$layer <<- match(input$layerSelect, transitions)
#})
observeEvent(reactiveValuesToList(input), { observeEvent(reactiveValuesToList(input), {
isolate(myList <- reactiveValuesToList(input)) isolate(myList <- reactiveValuesToList(input))
matches <- match(pressures$code, names(myList)) matches <- match(pressures$code, names(myList))
@@ -332,44 +355,27 @@ server <- function(input, output, session) {
if (!identical(newStatus, .selections$pressStatus)) { if (!identical(newStatus, .selections$pressStatus)) {
print('Running calc') print('Running calc')
.likelihoods$p_ba <<- calcLikelihood(1, newStatus) #.likelihoods$p_ba <<- calcLikelihood(1, newStatus)
.likelihoods$ba_os <<- calcLikelihood(2, newStatus) #.likelihoods$ba_os <<- calcLikelihood(2, newStatus)
.likelihoods$os_es <<- calcLikelihood(3, newStatus) #.likelihoods$os_es <<- calcLikelihood(3, newStatus)
.likelihoods$p_es <<- calcLikelihood(0, newStatus)
write.xlsx(.likelihoods$p_es, 'tmp.xlsx')
.selections$pressStatus <<- newStatus .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) { makeRadioButtons <- function(row) {
radioButtons(row['code'], row['name'], choices=c('Off', 'On'), selected='Off', inline=TRUE) 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({ output$pressureList <- renderUI({
#isolate({ #isolate({
if (!is.null(modelList[[.selections$model]][[1]]$nodes)) { if (!is.null(modelList[[.selections$model]]$nodes)) {
pressCodes <- which(startsWith(modelList[[.selections$model]][[1]]$nodes$code, 'p')) pressCodes <- which(startsWith(modelList[[.selections$model]]$nodes$code, 'p'))
pressures <- data.frame(code = modelList[[.selections$model]][[1]]$nodes$code[pressCodes], pressures <- data.frame(code = modelList[[.selections$model]]$nodes$code[pressCodes],
name = modelList[[.selections$model]][[1]]$nodes$name[pressCodes], stringsAsFactors=FALSE) name = modelList[[.selections$model]]$nodes$name[pressCodes], stringsAsFactors=FALSE)
setPressures(pressures) setPressures(pressures)
btnList <- apply(pressures, 1, makeRadioButtons) btnList <- apply(pressures, 1, makeRadioButtons)
} }
@@ -386,64 +392,84 @@ server <- function(input, output, session) {
print(.selections$bbnNames) print(.selections$bbnNames)
}) })
observeEvent(input$bbnDisplayEdges, {
.selections$bbnEdges <- input$bbnDisplayEdges
})
observeEvent(input$layer1Slider, { observeEvent(input$layer1Slider, {
showModal( showModal(
modalDialog({ modalDialog({
tagList( tagList(
sliderInput("l1VH", "Very High Sensitivity", 0.9, 1.0, 0.99, step=0.01), sliderInput("l1VL", "Insensitive", 0.01, 0.2, abs(.resistanceScores[1]), step=0.01),
sliderInput("l1H", "High Sensitivity", 0.75, 1.0, 0.95, step=0.01), sliderInput("l1L", "Low Sensitivity/High resistance", 0.15, 0.5, abs(.resistanceScores[2]), step=0.01),
sliderInput("l1M", "Medium Sensitivity", 0.5, 0.75, 0.95, step=0.01), sliderInput("l1M", "Medium Sensitivity/Med resistance", 0.5, 0.75, abs(.resistanceScores[3]), step=0.01),
sliderInput("l1L", "Low Sensitivity", 0.15, 0.5, 0.2, step=0.01), sliderInput("l1H", "High Sensitivity/Low resistance", 0.75, 1.0, abs(.resistanceScores[4]), step=0.01),
sliderInput("l1VL", "Very Low Sensitivity", 0.01, 0.2, 0.15, step=0.01), sliderInput("l1VH", "Very High Sensitivity/No resistance", 0.9, 1.0, abs(.resistanceScores[5]), step=0.01),
sliderInput("pressStdDev", "Pressure SD", 0.1, 1, 0.5, step=0.1), sliderInput("ssgr", "Steady state growth rate", -0.1, 0.1,.resistanceScores[6], step=0.01),
sliderInput("baStdDev", "Bio-Assemblage SD", 0.1, 1, 0.5, step=0.1) 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( 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 selection = 'single',options = list(searching = TRUE, pageLength = 10, editable=TRUE),server = TRUE, escape = FALSE,rownames= TRUE
) )
output$edgeTable <- DT::renderDataTable( 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 selection = 'single',options = list(searching = TRUE, pageLength = 10, editable=TRUE),server = TRUE, escape = FALSE,rownames= TRUE
) )
getLabel <- function(impact) { getLabel <- function(value) {
sign <- ifelse(impact<0, "-", "+") sign <- ifelse(value<0, "-", "+")
idx <- min(which((abs(impact)>=thresholds)==TRUE)) idx <- min(which((abs(value)>=thresholds)==TRUE))
return(paste0(sign, impLabels[idx])) return(paste0(sign, impLabels[idx]))
} }
getLevels <- function(code) { makeBbnGraph <- function(model) {
if (startsWith(code, 'p')) return(1) nodes <- model$nodes
else if (startsWith(code, 'ba')) return(2)
else if (startsWith(code, 'op')) return(3)
else if (startsWith(code, 'es')) return(4)
else return(5)
}
if (.selections$bbnEdges) {labels <- sapply(model$edges$values, getLabel)} else {labels <- rep("", nrow(model$edges))}
output$bbnGraphPlot <- renderVisNetwork({
#graphviz.plot(modelList[[.selections$model]][[.selections$layer]]$net)
nodes <- modelList[[.selections$model]][[.selections$layer]]$nodes
edges <- data.frame( edges <- data.frame(
id = rownames(modelList[[.selections$model]][[.selections$layer]]$edges), id = rownames(model$edges),
from=match(modelList[[.selections$model]][[.selections$layer]]$edges$input, nodes$name), from=match(model$edges$input, nodes$code),
to=match(modelList[[.selections$model]][[.selections$layer]]$edges$output, nodes$name), to=match(model$edges$output, nodes$code),
impact=modelList[[.selections$model]][[.selections$layer]]$edges$impact, values=model$edges$values,
label=sapply(modelList[[.selections$model]][[.selections$layer]]$edges$impact, getLabel), label=labels,
arrows="to", arrows="to",
stringsAsFactors=FALSE stringsAsFactors=FALSE
) )
@@ -451,25 +477,25 @@ server <- function(input, output, session) {
nodeSpacing <- ifelse(.selections$bbnNames, 600, 150) nodeSpacing <- ifelse(.selections$bbnNames, 600, 150)
palette <- brewer.pal(length(legends), "RdYlGn")
nodes <- data.frame( nodes <- data.frame(
id = rownames(nodes), id = rownames(nodes),
label = labels, label = labels,
level = sapply(nodes$code, getLevels), level = nodes$layer,
group = nodes$layer,
color = palette[as.integer(nodes$layer)],
code = nodes$code, code = nodes$code,
stringsAsFactors=FALSE stringsAsFactors=FALSE
) )
edges <- edges[(abs(edges$values)>=.selections$bbnImpact),]
edges <- edges[(abs(edges$impact)>=.selections$bbnImpact),]
nodeNet <- nodes[(nodes$code %in% .selections$pressStatus$code[.selections$pressStatus$status %in% c('On')]),] nodeNet <- nodes[(nodes$code %in% .selections$pressStatus$code[.selections$pressStatus$status %in% c('On')]),]
save(nodes, edges, nodeNet, file = 'tmp.RData') save(nodes, edges, nodeNet, file = 'tmp.RData')
if (nrow(nodeNet)>0) { if (nrow(nodeNet)>0) {
#do pressures #do pressures
edgeNet <- edges[edges$from %in% nodeNet$id, ] edgeNet <- edges[edges$from %in% nodeNet$id, ]
idx = 1 idx = 1
@@ -488,66 +514,125 @@ server <- function(input, output, session) {
} #until finished } #until finished
} else edgeNet <- edges } else edgeNet <- edges
visNetwork(nodeNet, edgeNet, width = "100%") %>% legendDF <- data.frame(
visHierarchicalLayout(nodeSpacing=nodeSpacing) %>% id = 1:length(legends),
visOptions(highlightNearest = TRUE) %>% label = legends,
#visPhysics(hierarchicalRepulsion = nodeSpacing) %>% color = palette,
visInteraction(navigationButtons = TRUE, dragNodes = TRUE, dragView = TRUE, zoomView = TRUE) 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({ #observe({
visNetworkProxy("bbnGraphPlot") %>% # visNetworkProxy("bbnGraphPlot") %>%
visStabilize(iterations=10) # visStabilize(iterations=10)
}) #})
getModelName <- function() {
paste0('data/', input$modelSelect, '.xlsx')
}
output$layer1 <- renderPlotly({ genPlot <- function(boxPlot, title) {
if (length(.likelihoods$p_ba)>0) { if (nrow(boxPlot)>0) {
.likelihoods$p_ba$nodeNames <- factor(.likelihoods$p_ba$nodeNames, levels = unique(.likelihoods$p_ba$nodeNames)) 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", xform <- list(categoryorder = "array",
categoryarray = .likelihoods$p_ba$nodeNames, categoryarray = boxPlot[,1],
zerolinewidth=10) zerolinewidth=10)
#
plot_ly(.likelihoods$p_ba, y = ~range, color = ~nodeNames, type = "box") %>% plot_ly(boxPlot, x = boxPlot[,1], y = ~Range, color = colours, colors = palette, type = "box") %>%
layout(xaxis = xform) 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({
prepPlot("ba", "Bio-Assemblage")
}) })
output$layer2 <- renderPlotly({ output$layer2 <- renderPlotly({
if (length(.likelihoods$ba_os)>0) { prepPlot("op", "Output Processes")
.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)
}
}) })
output$layer3 <- renderPlotly({ output$layer3 <- renderPlotly({
prepPlot("es", "Ecosystem Services")
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)
}
}) })
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) shinyApp(ui, server)