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

Merge

Browse Source
This commit is contained in:
Steve Pegg
2019-04-11 13:59:13 +01:00
parent 12dc3b2c92 fede4e3dc4
commit 1383055d3c
6 changed files with 2231 additions and 445 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
.hgignore
View File

@@ -4,3 +4,4 @@ syntax: glob
archive archive
data/tmp/ data/tmp/
data/new/ data/new/
node_modules/

321
Parses.R
View File

@@ -1,27 +1,27 @@
modules::import(openxlsx)
modules::import(bnlearn) modules::import(bnlearn)
modules::import(openxlsx)
modules::import(stringr) modules::import(stringr)
modules::import(graph)
modules::import(ggplot2)
modules::import(stats) modules::import(stats)
modules::import(plotly)
modules::import(utils)
#Improvements needed: make the selection of first row/column of nodes programmatic #Improvements needed: make the selection of first row/column of nodes programmatic
FIRST_NODE_COL <- 3 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', 'layer') states <- c("impact", "confidence", "growth", "recovery", "layer")
refs <-c(1:length(mappings)) refs <- c(1:length(mappings))
setEmpties <- function(val) { setEmpties <- function(val) {
if (is.na(val)) return(0) else return(val) if (is.na(val)) {
return(0)
} else {
return(val)
}
} }
readXL <- function(fName, sheetN, startRow=1) { readXL <- function(fName, sheetN, startRow = 1) {
xl <- read.xlsx(fName, sheet = sheetN, startRow) #, rowNames = import) xl <- read.xlsx(fName, sheet = sheetN, startRow) #, rowNames = import)
return(data.frame(xl, stringsAsFactors = FALSE, row.names = NULL)) return(data.frame(xl, stringsAsFactors = FALSE, row.names = NULL))
} }
@@ -32,73 +32,87 @@ delNA <- function(vec) {
buildExpr <- function(pressStatus) { buildExpr <- function(pressStatus) {
#pressStatus is a two column DF of name of pressure and status Ii.e. on or off) #pressStatus is a two column DF of name of pressure and status Ii.e. on or off)
MEANPRESS = 0 MEANPRESS <- 0
expr <- "(" expr <- "("
for (p in 1:nrow(pressStatus)) { for (p in 1:nrow(pressStatus)) {
if (pressStatus$status[p] == 'On') symbol='>=' else symbol='<=' if (pressStatus$status[p] == "On") {
symbol <- ">="
} else {
symbol <- "<="
}
expr <- paste0(expr, "(\"", pressStatus$code[p], "\"", symbol, MEANPRESS, ") & ") expr <- paste0(expr, "(\"", pressStatus$code[p], "\"", symbol, MEANPRESS, ") & ")
} }
expr<-substr(expr, 1, nchar(expr)-2) expr <- substr(expr, 1, nchar(expr) - 2)
expr<-paste0(expr, ')') expr <- paste0(expr, ")")
return(expr) return(expr)
} }
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=3, dimnames=list(NULL, c('growth', 'confidence', 'layer'))) 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', 'layer'), 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) {
cat('Duplicated pressure node names found') cat("Duplicated pressure node names found")
print(pressNodes[duplicated(pressNames)]) print(pressNodes[duplicated(pressNames)])
} }
return(list( return(list(
timeSeq=press, timeSeq = press,
nodes=data.frame(name = pressNames, nodes = data.frame(
code=paste0(prefix, seq(1:length(pressNames))), name = pressNames,
growth = coefs[,'growth'], code = paste0(prefix, seq(1:length(pressNames))),
confidence=coefs[,'confidence'], growth = coefs[,"growth"],
layer=coefs[,'layer'], confidence = coefs[,"confidence"],
stringsAsFactors = FALSE), layer = coefs[,"layer"],
edges=data.frame(input=NULL, output=NULL, impact=NULL) stringsAsFactors = FALSE
),
edges = data.frame(input = NULL, output = NULL, impact = NULL)
)) ))
} }
getInitial <- function(string, letter) { getInitial <- function(string, letter) {
return(tolower(substr(string, start=1, stop=1))) return(tolower(substr(string, start = 1, stop = 1)))
} }
split <- function(cell) { split <- function(cell) {
params <- unlist(strsplit(cell, ',')) params <- unlist(strsplit(cell, ","))
values <- rep(0, length(states)) values <- rep(0, length(states))
for (n in 1:length(params)) { for (n in 1:length(params)) {
kvp <- unlist(strsplit(params[n], '=')) kvp <- unlist(strsplit(params[n], "="))
ref <- match(getInitial(trimws(kvp[1])), getInitial(states)) ref <- match(getInitial(trimws(kvp[1])), getInitial(states))
if ((ref>0) & (ref<=length(values))) {
if ((ref > 0) & (ref <= length(values))) {
values[ref] <- kvp[2] values[ref] <- kvp[2]
} else { } else {
print(paste('Unrecognised parameter(s):',params[n])) print(paste("Unrecognised parameter(s):",params[n]))
} }
} }
return(values)
return(values)
} }
cleanTitles <- function(titleV) { cleanTitles <- function(titleV) {
return(str_replace_all(titleV, c(' ' = '.', '-' = ''))) return(str_replace_all(titleV, c(" " = ".", "-" = "")))
} }
getOutNodes <- function(codes, codeList) { getOutNodes <- function(codes, codeList) {
v <- vector(mode='logical', length=length(codes)) v <- vector(mode = "logical", length = length(codes))
for (idx in 1:length(codes)) { for (idx in 1:length(codes)) {
v[idx] <- (sum(startsWith(codes[idx], codeList))>0) v[idx] <- (sum(startsWith(codes[idx], codeList)) > 0)
} }
return(v) return(v)
} }
@@ -106,44 +120,44 @@ buildGraph <- function(model, desc) {
#model contains the following #model contains the following
# node table, edge table # node table, edge table
#descriptor (desc) contains: #descriptor (desc) contains:
#inputCode - the top layer of the model #inputCode - the top layer of the model
#outputCodes - all subsequent layers to be included in the model #outputCodes - all subsequent layers to be included in the model
inputNodes <- model$nodes$code[which(startsWith(model$nodes$code, desc$inputCode))] inputNodes <- model$nodes$code[which(startsWith(model$nodes$code, desc$inputCode))]
inputText <- paste0("[", inputNodes, "]", collapse ="") inputText <- paste0("[", inputNodes, "]", collapse = "")
#do the internal nodes #do the internal nodes
edges <- "" edges <- ""
outNodes <- model$nodes$code[getOutNodes(model$nodes$code, desc$outputCodes)] outNodes <- model$nodes$code[getOutNodes(model$nodes$code, desc$outputCodes)]
outDist <- vector(mode="list", length=length(outNodes)) outDist <- vector(mode = "list", length = length(outNodes))
for (idx in 1:length(outNodes)) { for (idx in 1:length(outNodes)) {
nodeRef <- match(outNodes[idx], model$nodes$code) nodeRef <- match(outNodes[idx], model$nodes$code)
rows <- which(model$edges$output == outNodes[idx]) rows <- which(model$edges$output == outNodes[idx])
inputsStr <- paste0(model$edges$input[which(model$edges$output == outNodes[idx])], sep=":", collapse="") inputsStr <- paste0(model$edges$input[which(model$edges$output == outNodes[idx])], sep = ":", collapse = "")
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$values[rows]), coefVal <- setNames(
c("(Intercept)", model$edges$input[rows]) c(model$nodes$growth[nodeRef], model$edges$values[rows]),
) c("(Intercept)", model$edges$input[rows])
)
#str(coefVal) #str(coefVal)
outDist[[idx]] <- list(coef = coefVal, outDist[[idx]] <- list(coef = coefVal, sd = model$nodes$confidence[nodeRef])
sd = model$nodes$confidence[nodeRef])
} }
print('about to build network') print("about to build network")
print(paste0(inputText, edges)) print(paste0(inputText, edges))
net <- model2network(paste0(inputText, edges), debug=TRUE) net <- model2network(paste0(inputText, edges), debug = TRUE)
print('network build successful')
inDist <- vector(mode="list", length=length(inputNodes)) print("network build successful")
inDist <- vector(mode = "list", length = length(inputNodes))
for (idx in 1:length(inputNodes)) { for (idx in 1:length(inputNodes)) {
inRef <- match(inputNodes[idx], model$nodes$code) inRef <- match(inputNodes[idx], model$nodes$code)
@@ -151,21 +165,21 @@ buildGraph <- function(model, desc) {
inDist[[idx]] <- list(coef = coefVal, sd = model$nodes$confidence[inRef]) inDist[[idx]] <- list(coef = coefVal, sd = model$nodes$confidence[inRef])
} }
allDists = as.list(setNames(c(inDist, outDist), c(inputNodes, outNodes))) allDists <- as.list(setNames(c(inDist, outDist), c(inputNodes, outNodes)))
cfit = custom.fit(net, allDists) cfit <- custom.fit(net, allDists)
cat('about to calculate sample distributions') cat("about to calculate sample distributions")
print(outNodes) print(outNodes)
sampleDists <- cpdist(cfit, nodes = outNodes, evidence = TRUE, n = 10000, method = "lw") sampleDists <- cpdist(cfit, nodes = outNodes, evidence = TRUE, n = 10000, method = "lw")
summDists <- summary(sampleDists) summDists <- summary(sampleDists)
#stdDev <- sd(sampleDists) #stdDev <- sd(sampleDists)
print('sample distribution build successful') print("sample distribution build successful")
model$edges$input <- model$nodes$name[match(model$edges$input, model$nodes$code)] model$edges$input <- model$nodes$name[match(model$edges$input, model$nodes$code)]
model$edges$output <- model$nodes$name[match(model$edges$output, model$nodes$code)] model$edges$output <- model$nodes$name[match(model$edges$output, model$nodes$code)]
return( return(
list( list(
nodes = model$nodes, nodes = model$nodes,
@@ -180,63 +194,67 @@ buildGraph <- function(model, desc) {
getValidNodes <- function(mapping, prevOutputs, prefix) { getValidNodes <- function(mapping, prevOutputs, prefix) {
#Find row id for input nodes, internal and published #Find row id for input nodes, internal and published
inputNodes <- mapping[2:nrow(mapping),1] inputNodes <- mapping[2:nrow(mapping),1]
#check that all input nodes are in the previous table #check that all input nodes are in the previous table
inputNodes <- delNA(mapping[mapping[,"Node.Type"] == 'input', "Nodes"]) inputNodes <- delNA(mapping[mapping[,"Node.Type"] == "input", "Nodes"])
if (length(inputNodes)>0) { if (length(inputNodes) > 0) {
if (sum(inputNodes %in% prevOutputs$name)<length(inputNodes)) { if (sum(inputNodes %in% prevOutputs$name) < length(inputNodes)) {
cat('Missing entries for input nodes in previous output columns') cat("Missing entries for input nodes in previous output columns")
print(inputNodes[!inputNodes %in% prevOutputs$name]) print(inputNodes[!inputNodes %in% prevOutputs$name])
} }
} else print('Invalid sheet - table must have at least one input row containing names from previous table') } else {
print("Invalid sheet - table must have at least one input row containing names from previous table")
}
#Check the row headings concur with previous names #Check the row headings concur with previous names
validInputs <- delNA(inputNodes[which(unique(inputNodes) %in% prevOutputs$name)]) validInputs <- delNA(inputNodes[which(unique(inputNodes) %in% prevOutputs$name)])
if (length(validInputs)==0) print('Invalid sheet - table must have at least one input row containing names from previous table') if (length(validInputs) == 0) {
print("Invalid sheet - table must have at least one input row containing names from previous table")
}
inputInts <- delNA(inputNodes[mapping$Node.Type!='link'])
inputInts <- delNA(inputNodes[mapping$Node.Type != "link"])
if (sum(duplicated(inputInts))>0) { if (sum(duplicated(inputInts))>0) {
cat('Duplicated input node names found') cat("Duplicated input node names found")
print(inputNodes[duplicated(inputNodes)]) print(inputNodes[duplicated(inputNodes)])
} }
outNodes <- delNA(colnames(mapping)[FIRST_NODE_COL:ncol(mapping)]) outNodes <- delNA(colnames(mapping)[FIRST_NODE_COL:ncol(mapping)])
if (sum(duplicated(outNodes))>0) { if (sum(duplicated(outNodes)) > 0) {
cat('Duplicated output node names found') cat("Duplicated output node names found")
print(outNodes[duplicated(outNodes)]) print(outNodes[duplicated(outNodes)])
} }
#check that all internal nodes are in the columns #check that all internal nodes are in the columns
intNodes <- delNA(mapping[mapping[,"Node.Type"] == 'internal', "Nodes"]) intNodes <- delNA(mapping[mapping[,"Node.Type"] == "internal", "Nodes"])
if (length(intNodes)>0) { if (length(intNodes) > 0) {
if (sum(intNodes %in% outNodes)<length(intNodes)) { if (sum(intNodes %in% outNodes)<length(intNodes)) {
cat('Missing entries for internal nodes in output columns') cat("Missing entries for internal nodes in output columns")
print(intNodes[!intNodes %in% outNodes]) print(intNodes[!(intNodes %in% outNodes)])
} }
} }
coefs <- matrix(data=NA, nrow=length(outNodes), ncol=3, dimnames=list(NULL, c('growth', 'confidence', 'layer'))) 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', 'layer'), states)] coefs[idx,] <- as.numeric(split(mapping[1, col]))[match(c("growth", "confidence", "layer"), states)]
} }
print(coefs) 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"]), layer = c(prevOutputs$layer, coefs[,"layer"]),
stringsAsFactors=FALSE stringsAsFactors = FALSE
)) ))
} }
@@ -244,91 +262,90 @@ getCode <- function(name, nodeDF) {
nodeDF$code[match(name, nodeDF$name)] nodeDF$code[match(name, nodeDF$name)]
} }
getValidEdges <- function(mapping, nodeDF, prevEdge=NULL, prefix) { getValidEdges <- function(mapping, nodeDF, prevEdge = NULL, prefix) {
str(nodeDF) utils::str(nodeDF)
edgeCols <- c('inputNode', 'outputNode', 'impact')
edgeM <- matrix(data=NA, nrow=0, ncol=length(edgeCols), dimnames=list(NULL, edgeCols)) edgeCols <- c("inputNode", "outputNode", "impact")
edgeM <- matrix(data = NA, nrow = 0, ncol = length(edgeCols), dimnames = list(NULL, edgeCols))
#to start let just get the statements and print them out.... #to start let just get the statements and print them out....
for (col in FIRST_NODE_COL:ncol(mapping)) { for (col in FIRST_NODE_COL:ncol(mapping)) {
count=0 count <- 0
for (row in 2:nrow(mapping)) { for (row in 2:nrow(mapping)) {
if (!is.na(mapping[row, col])) { if (!is.na(mapping[row, col])) {
edgeM <- rbind(edgeM, edgeM <- rbind(edgeM,
c(getCode(mapping[row, 1], nodeDF), c(getCode(mapping[row, 1], nodeDF),
getCode(colnames(mapping)[col], nodeDF), getCode(colnames(mapping)[col], nodeDF),
split(mapping[row,col])[match('impact', states)] split(mapping[row,col])[match("impact", states)]
) )
) )
count=count+1 count <- count + 1
} }
#if (count==0) print(paste('No edges found for output', colnames(mapping)[col])) #if (count == 0) print(paste("No edges found for output", colnames(mapping)[col]))
} }
} }
if (is.null(prevEdge)) return ( if (is.null(prevEdge)) {
data.frame( return (data.frame(
input = edgeM[,"inputNode"], input = edgeM[,"inputNode"],
output = edgeM[,"outputNode"], output = edgeM[,"outputNode"],
impact = edgeM[,"impact"], impact = edgeM[,"impact"],
stringsAsFactors = FALSE stringsAsFactors = FALSE
) ))
) else return ( } else {
data.frame( return (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, edgeM[,"impact"]), impact = c(prevEdge$impact, edgeM[,"impact"]),
stringsAsFactors = FALSE stringsAsFactors = FALSE
) ))
) }
} }
parseMapping <- function(mapping, prevOutputs, prefix) { parseMapping <- function(mapping, prevOutputs, prefix) {
mapping <- mapping[,-1] mapping <- mapping[,-1]
mapping[,1] <- cleanTitles(mapping[,1]) mapping[,1] <- cleanTitles(mapping[,1])
nodeDF <- getValidNodes(mapping, prevOutputs$nodes, prefix) nodeDF <- getValidNodes(mapping, prevOutputs$nodes, prefix)
edgeDF <- getValidEdges(mapping, nodeDF, prevEdge=prevOutputs$edges, prefix) edgeDF <- getValidEdges(mapping, nodeDF, prevEdge = prevOutputs$edges, prefix)
return(list( return(list(
#New structure #New structure
nodes=nodeDF, nodes = nodeDF,
edges=edgeDF edges = edgeDF
)) ))
} }
parseSheet <- function(fName) { parseSheet <- function(fName) {
#get sheet names #get sheet names
print(paste('starting sheet load', fName)) print(paste("starting sheet load", fName))
if (file.exists(fName)) { if (file.exists(fName)) {
names <- openxlsx::getSheetNames(fName) names <- openxlsx::getSheetNames(fName)
if (length(names)>0) {
sheets <- sort(delNA(match(names, mappings)))
cat('starting sheet parse')
print(sheets)
if (sum(sheets==refs)==length(refs)) {
#read all mapping tables
scenario <- parseScenario(readXL(fName,mappings[1], startRow=1), prefix='p')
p_ba <- parseMapping(readXL(fName,mappings[2], startRow=1), scenario, prefix='ba')
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')
#p_baNet <- buildGraph(p_ba, desc=list(inputCode='p', outputCodes='ba')) if (length(names) > 0) {
#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'))) sheets <- sort(delNA(match(names, mappings)))
print('sheet load completed') cat("starting sheet parse")
print(sheets)
if (sum(sheets == refs) == length(refs)) {
#read all mapping tables
scenario <- parseScenario(readXL(fName,mappings[1], startRow = 1), prefix = "p")
p_ba <- parseMapping(readXL(fName,mappings[2], startRow = 1), scenario, prefix = "ba")
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")
#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( return(
#list( #list(
#pressBioAss = p_baNet, #pressBioAss = p_baNet,
@@ -339,8 +356,8 @@ parseSheet <- function(fName) {
) )
} else { } else {
print(paste('Sheets found include', mappings[sheets])) print(paste("Sheets found include", mappings[sheets]))
cat('Missing sheets are:') cat("Missing sheets are:")
print(refs[-sheets]) print(refs[-sheets])
} }
} }

56
README.md Normal file
View File

@@ -0,0 +1,56 @@
## Installation
#### Required R libraries:
- bnlearn
- DT
- ggplot2
- graph
- htmltools
- kableExtra
- knitr
- magrittr
- openxlsx
- plotly
- processx
- RColorBrewer
- shiny
- shinyBS
- shinycssloaders
- shinydashboard
- shinydashboardPlus
- shinyjs
- stringr
- vizNetwork
- zip
```
install.packages(c("bnlearn", "DT", "ggplot2", "graph", "htmltools", "kableExtra", "knitr", "magrittr", "openxlsx", "plotly", "processx", "RColorBrewer", "shiny", "shinyBS", "shinycssloaders", "shinydashboard", "shinydashboardPlus", "shinyjs", "stringr", "vizNetwork", "zip", "devtools"))
devtools::install_github("ropensci/plotly")
```
#### ORCA for downloads:
- NodeJs (v8)
- electron
- orca
```
npm install
export PATH=`pwd`/node_modules/.bin:$PATH
```
NOTE: remember to export the path when running the application so that R can find orca
#### Start script (optional)
Assumes application runs under the `shiny` account
```
#!/bin/bash
if [ "$(whoami)" != "shiny" ]; then
sudo -u shiny $0
exit 1
fi
export NVM_DIR="$HOME/.nvm"
[ -s "$NVM_DIR/nvm.sh" ] && \. "$NVM_DIR/nvm.sh" # This loads nvm
export PATH=/srv/shiny/bin:$PATH
screen -dmS MESO R --vanilla -e "shiny::runApp('app.R', host = '0.0.0.0', port = 6376)"
```

595
app.R
View File

@@ -1,48 +1,41 @@
modules::import(DT)
modules::import(shiny) modules::import(shiny)
modules::import(shinyBS)
modules::import(shinyjs)
modules::import(shinydashboard) modules::import(shinydashboard)
modules::import(shinydashboardPlus) modules::import(shinydashboardPlus)
modules::import(htmltools)
#modules::import(DiagrammeR)
modules::import(magrittr)
modules::import(plotly)
modules::import(kableExtra)
#modules::import(Rgraphviz)
modules::import(knitr)
modules::import(shinycssloaders) modules::import(shinycssloaders)
#modules::import(googleway) modules::import(shinyjs)
modules::import(bnlearn) modules::import(bnlearn)
modules::import(visNetwork) modules::import(visNetwork)
modules::import(RColorBrewer) modules::import(RColorBrewer)
modules::import(zip) modules::import(plotly)
modules::import(processx)
modules::import(openxlsx) modules::import(openxlsx)
modules::import(zip)
modules::import(DT)
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")
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.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") addResourcePath("js", "./www/js")
ui<-dashboardPage(
dashboardHeader(title = "JNCC MESO online", 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.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")
ui <- dashboardPage(
dashboardHeader(title = "JNCC MESO online",
tags$li( tags$li(
id = "dropdownHelp", id = "dropdownHelp",
class = "dropdown", class = "dropdown",
@@ -95,52 +88,52 @@ ui<-dashboardPage(
menuItem("Bayesian Network", tabName = "2", icon = icon("atom")), menuItem("Bayesian Network", tabName = "2", icon = icon("atom")),
#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")), downloadButton("download", "", icon = icon("download")),
uiOutput("pressureList") uiOutput("pressureList")
#selectInput("layerSelect", "Select Transition", #selectInput("layerSelect", "Select Transition",
# choices=transitions, # choices = transitions,
# selected=NULL, multiple=FALSE) # selected = NULL, multiple = FALSE)
) )
), ),
dashboardBody( dashboardBody(
tabItems( tabItems(
tabItem(tabName = "1", h2('Impact Distribution'), tabItem(tabName = "1", h2("Impact Distribution"),
fluidRow( fluidRow(
column( column(
width=6, width = 6,
h4('Effect on bio-assemblage') h4("Effect on bio-assemblage")
), ),
column( column(
width=1, width = 1,
actionButton("layer1Slider", "1", icon=icon("sliders-h")) actionButton("layer1Slider", "1", icon = icon("sliders-h"))
), ),
column( column(
width=5, width = 5,
strong("Customise sensitivity weightings") strong("Customise sensitivity weightings")
) )
), ),
plotlyOutput("layer1", height="270px") %>% withSpinner(), plotlyOutput("layer1", height = "270px") %>% withSpinner(),
h4('Effect on Output Processes'), h4("Effect on Output Processes"),
plotlyOutput("layer2", height="270px") %>% withSpinner(), plotlyOutput("layer2", height = "270px") %>% withSpinner(),
h4('Effect on Ecosystem services'), h4("Effect on Ecosystem services"),
plotlyOutput("layer3", height="270px") %>% withSpinner() plotlyOutput("layer3", height = "270px") %>% withSpinner()
), ),
tabItem(tabName = "2",h2("Bayesian Network"), tabItem(tabName = "2",h2("Bayesian Network"),
fluidPage( fluidPage(
p('Graphical output of the Bayesian Network. Note: The graph will only draw if pressures are applied!'), 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( column(
width=4, width = 4,
checkboxInput("bbnDisplayEdges", "Display edge status", value=FALSE) 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(
@@ -148,14 +141,14 @@ ui<-dashboardPage(
), ),
fluidRow( fluidRow(
column( column(
width=6, width = 6,
h4('Ecoservice nodes'), h4("Ecoservice nodes"),
DT::dataTableOutput('nodeTable') DT::dataTableOutput("nodeTable")
), ),
column( column(
width=6, width = 6,
h4('Ecoservice influences'), h4("Ecoservice influences"),
DT::dataTableOutput('edgeTable') DT::dataTableOutput("edgeTable")
) )
) )
) )
@@ -164,13 +157,13 @@ ui<-dashboardPage(
# fluidPage( # fluidPage(
# google_mapOutput(outputId = "map", width = "100%", height = "750px") # google_mapOutput(outputId = "map", width = "100%", height = "750px")
# ) # )
#), #),
tabItem(tabName = "3",h4("Ingestion"), tabItem(tabName = "3",h4("Ingestion"),
fluidPage( fluidPage(
p("Select a spreadsheet from your network for input into the JNCC Bayesian Network Analyser:"), p("Select a spreadsheet from your network for input into the JNCC Bayesian Network Analyser:"),
fileInput("fileSelect", "Choose Excel Spreadsheet File (xlsx format)", multiple = FALSE, accept = "xlsx"), fileInput("fileSelect", "Choose Excel Spreadsheet File (xlsx format)", multiple = FALSE, accept = "xlsx"),
fluidRow(renderUI('status')), fluidRow(renderUI("status")),
actionButton('loadAB', 'Load') # icon='upload') actionButton("loadAB", "Load") # icon = "upload")
) )
) )
) )
@@ -179,34 +172,34 @@ ui<-dashboardPage(
server <- function(input, output, session) { server <- function(input, output, session) {
#SERVER Constants #SERVER Constants
print('Loading data') print("Loading data")
#set_key("AIzaSyAw8_btgGN1drf8qhCxNcotP6r11qEXA_M") #set_key("AIzaSyAw8_btgGN1drf8qhCxNcotP6r11qEXA_M")
dataStorage <- 'data/' dataStorage <- "data/"
models<-NULL models <- NULL
pressures <- NULL pressures <- NULL
.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
) )
.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 p_es = NULL
) )
setPressures <- function(newPressures) { setPressures <- function(newPressures) {
pressures <<- newPressures pressures <<- newPressures
} }
.resistanceScores <- c( .resistanceScores <- c(
ins= -0.01, ins = -0.01,
hr = -0.2, hr = -0.2,
mr = -0.75, mr = -0.75,
lr = -0.95, lr = -0.95,
@@ -214,15 +207,15 @@ server <- function(input, output, session) {
ssgr = 0, ssgr = 0,
pressSD = 0.5 pressSD = 0.5
) )
.selections <- reactiveValues( .selections <- reactiveValues(
model=1, model = 1,
bbnImpact=1, bbnImpact = 1,
bbnNames=FALSE, bbnNames = FALSE,
bbnEdges=FALSE, bbnEdges = FALSE,
pressStatus=NULL pressStatus = NULL
) )
getImpact <- function(v) { getImpact <- function(v) {
print(v) print(v)
if ((v == "INS") || (v == "IV")) return(.resistanceScores[1]) if ((v == "INS") || (v == "IV")) return(.resistanceScores[1])
@@ -232,75 +225,75 @@ server <- function(input, output, session) {
if (v == "NR") return(.resistanceScores[5]) if (v == "NR") return(.resistanceScores[5])
as.numeric(v) as.numeric(v)
} }
getAvailableModels <- function() { getAvailableModels <- function() {
fileList <- list.files(dataStorage, pattern='.xlsx') fileList <- list.files(dataStorage, pattern = ".xlsx")
modelList <- list() modelList <- list()
cnt<-1 cnt <- 1
for (idx in 1:length(fileList)) { for (idx in 1:length(fileList)) {
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) print(tmp)
tmp$edges$values <- sapply(tmp$edges$impact, getImpact) 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') #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)
} }
#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) { 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(thisModel$nodes$code, layerStr)) #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 #nodeCodes <- thisModel$nodes$code[layerRange]
MEANNEG=0 #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
expr <- "list(" expr <- "list("
for (p in 1:nrow(pressStatus)) { for (p in 1:nrow(pressStatus)) {
if (pressStatus$status[p] == 'On') { if (pressStatus$status[p] == "On") {
threshold = MEANPOS threshold <- MEANPOS
} else { } else {
threshold = MEANNEG threshold <- MEANNEG
} }
expr <- paste0(expr, "\"", pressStatus$code[p], "\"=", threshold, ", ") expr <- paste0(expr, "\"", pressStatus$code[p], "\" = ", threshold, ", ")
} }
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'))) thisNet <- parser$buildGraph(thisModel, desc = list(inputCode = "p", outputCodes = c("ba", "op", "es")))
sampleDists <- cpdist( sampleDists <- cpdist(
fitted = thisNet$cfit, fitted = thisNet$cfit,
@@ -308,130 +301,135 @@ server <- function(input, output, session) {
evidence = eval(parse(text = expr)), evidence = eval(parse(text = expr)),
method = "lw", method = "lw",
n = 10000, n = 10000,
debug=TRUE debug = FALSE
) )
}) })
print(sampleDists) print(sampleDists)
#displayCols <- match(nodeCodes, colnames(sampleDists)) #displayCols <- match(nodeCodes, colnames(sampleDists))
sampleDists <- sampleDists[,match(thisModel$nodes$code, 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))) print(paste("Building likelihoods from model, sample dists", length(thisModel$nodes$name), length(sampleDists)))
return(data.frame( return(data.frame(
name = thisModel$nodes$name, name = thisModel$nodes$name,
code = thisModel$nodes$code, code = thisModel$nodes$code,
layer = thisModel$nodes$layer, layer = thisModel$nodes$layer,
range = c( range = c(
apply(sampleDists, 2, min), apply(sampleDists, 2, min),
means - 2*stdDev, means - 2*stdDev,
means - stdDev, means - stdDev,
means, means,
means + stdDev, means + stdDev,
means + 2*stdDev, means + 2*stdDev,
apply(sampleDists, 2, max) apply(sampleDists, 2, max)
), ),
stringsAsFactors=FALSE stringsAsFactors = FALSE
)) ))
} }
observeEvent(input$modelSelect, { observeEvent(input$modelSelect, {
.selections$model <<- match(input$modelSelect, models) .selections$model <<- match(input$modelSelect, models)
}) })
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))
if (length(matches)>0) { if (length(matches) > 0) {
status <-NULL status <- NULL
for (n in 1:length(matches)) status[n] = myList[[matches[n]]] for (n in 1:length(matches)) {
status[n] <- myList[[matches[n]]]
newStatus <- data.frame(code=pressures$code, status=status, stringsAsFactors = FALSE) }
newStatus <- data.frame(code = pressures$code, status = status, stringsAsFactors = FALSE)
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) .likelihoods$p_es <<- calcLikelihood(0, newStatus)
#write.xlsx(.likelihoods$p_es, 'tmp.xlsx') #write.xlsx(.likelihoods$p_es, "tmp.xlsx")
.selections$pressStatus <<- newStatus .selections$pressStatus <<- newStatus
} }
} }
}) })
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$pressureList <- renderUI({ output$pressureList <- renderUI({
#isolate({ #isolate({
if (!is.null(modelList[[.selections$model]]$nodes)) { if (!is.null(modelList[[.selections$model]]$nodes)) {
pressCodes <- which(startsWith(modelList[[.selections$model]]$nodes$code, 'p')) pressCodes <- which(startsWith(modelList[[.selections$model]]$nodes$code, "p"))
pressures <- data.frame(code = modelList[[.selections$model]]$nodes$code[pressCodes], pressures <- data.frame(
name = modelList[[.selections$model]]$nodes$name[pressCodes], stringsAsFactors=FALSE) code = modelList[[.selections$model]]$nodes$code[pressCodes],
name = modelList[[.selections$model]]$nodes$name[pressCodes],
stringsAsFactors = FALSE
)
setPressures(pressures) setPressures(pressures)
btnList <- apply(pressures, 1, makeRadioButtons) btnList <- apply(pressures, 1, makeRadioButtons)
} }
}) })
observeEvent(input$bbnImpactSelect, { observeEvent(input$bbnImpactSelect, {
#filter nodes and edges to #filter nodes and edges to
.selections$bbnImpact <- thresholds[match(input$bbnImpactSelect, impacts)] .selections$bbnImpact <- thresholds[match(input$bbnImpactSelect, impacts)]
print(paste("Setting bbn impact", .selections$bbnImpact)) print(paste("Setting bbn impact", .selections$bbnImpact))
}) })
observeEvent(input$bbnDisplayNames, { observeEvent(input$bbnDisplayNames, {
.selections$bbnNames <- input$bbnDisplayNames .selections$bbnNames <- input$bbnDisplayNames
print(.selections$bbnNames) print(.selections$bbnNames)
}) })
observeEvent(input$bbnDisplayEdges, { observeEvent(input$bbnDisplayEdges, {
.selections$bbnEdges <- input$bbnDisplayEdges .selections$bbnEdges <- input$bbnDisplayEdges
}) })
observeEvent(input$layer1Slider, { observeEvent(input$layer1Slider, {
showModal( showModal(
modalDialog({ modalDialog({
tagList( tagList(
sliderInput("l1VL", "Insensitive", 0.01, 0.2, abs(.resistanceScores[1]), step=0.01), 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("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("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("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("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("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) sliderInput("l1PressSD", "Pressure Std Dev", 0.1, 1.0, .resistanceScores[7], step = 0.01)
) )
}, },
title='Layer 1 controls', title = "Layer 1 controls",
footer=tagList( footer = tagList(
modalButton("Cancel"), modalButton("Cancel"),
actionButton("modalOK", "OK") actionButton("modalOK", "OK")
), ),
size='s') size = "s")
) )
}) })
observeEvent(input$modalOK, {
print('Modal ok pressed')
.resistanceScores['nr'] <<- -input$l1VH observeEvent(input$modalOK, {
.resistanceScores['lr'] <<- -input$l1H print("Modal ok pressed")
.resistanceScores['mr'] <<- -input$l1M
.resistanceScores['hr'] <<- -input$l1L .resistanceScores["nr"] <<- -input$l1VH
.resistanceScores['ins'] <<- -input$l1VL .resistanceScores["lr"] <<- -input$l1H
.resistanceScores['ssgr'] <<- input$ssgr .resistanceScores["mr"] <<- -input$l1M
.resistanceScores['pressSD'] <<- input$l1PressSD .resistanceScores["hr"] <<- -input$l1L
.resistanceScores["ins"] <<- -input$l1VL
print('Running calc') .resistanceScores["ssgr"] <<- input$ssgr
.resistanceScores["pressSD"] <<- input$l1PressSD
print("Running calc")
#.likelihoods$p_ba <<- calcLikelihood(1, .selections$pressStatus) #.likelihoods$p_ba <<- calcLikelihood(1, .selections$pressStatus)
#.likelihoods$ba_os <<- calcLikelihood(2, .selections$pressStatus) #.likelihoods$ba_os <<- calcLikelihood(2, .selections$pressStatus)
#.likelihoods$os_es <<- calcLikelihood(3, .selections$pressStatus) #.likelihoods$os_es <<- calcLikelihood(3, .selections$pressStatus)
@@ -439,46 +437,60 @@ server <- function(input, output, session) {
removeModal() removeModal()
}) })
output$nodeTable <- DT::renderDataTable( output$nodeTable <- DT::renderDataTable(
modelList[[.selections$model]]$nodes, modelList[[.selections$model]]$nodes,
selection = 'single',options = list(searching = TRUE, pageLength = 10, editable=TRUE),server = TRUE, escape = FALSE,rownames= TRUE selection = "single",
) server = TRUE,
escape = FALSE,
rownames = TRUE,
options = list(searching = TRUE, pageLength = 10, editable = TRUE)
)
output$edgeTable <- DT::renderDataTable( output$edgeTable <- DT::renderDataTable(
modelList[[.selections$model]]$edges, modelList[[.selections$model]]$edges,
selection = 'single',options = list(searching = TRUE, pageLength = 10, editable=TRUE),server = TRUE, escape = FALSE,rownames= TRUE selection = "single",
server = TRUE,
escape = FALSE,
rownames = TRUE,
options = list(searching = TRUE, pageLength = 10, editable = TRUE)
) )
getLabel <- function(value) { getLabel <- function(value) {
sign <- ifelse(value<0, "-", "+") sign <- ifelse(value < 0, "-", "+")
idx <- min(which((abs(value)>=thresholds)==TRUE)) idx <- min(which((abs(value) >= thresholds) == TRUE))
return(paste0(sign, impLabels[idx])) return(paste0(sign, impLabels[idx]))
} }
makeBbnGraph <- function(model) { makeBbnGraph <- function(model) {
nodes <- model$nodes nodes <- model$nodes
if (.selections$bbnEdges) {labels <- sapply(model$edges$values, getLabel)} else {labels <- rep("", nrow(model$edges))} if (.selections$bbnEdges) {
labels <- sapply(model$edges$values, getLabel)
} else {
labels <- rep("", nrow(model$edges))
}
edges <- data.frame( edges <- data.frame(
id = rownames(model$edges), id = rownames(model$edges),
from=match(model$edges$input, nodes$code), from = match(model$edges$input, nodes$code),
to=match(model$edges$output, nodes$code), to = match(model$edges$output, nodes$code),
values=model$edges$values, values = model$edges$values,
label=labels, label = labels,
arrows="to", arrows = "to",
stringsAsFactors=FALSE stringsAsFactors = FALSE
) )
if (.selections$bbnNames) {labels <- nodes$name} else {labels <- nodes$code} if (.selections$bbnNames) {
labels <- nodes$name
} else {
labels <- nodes$code
}
nodeSpacing <- ifelse(.selections$bbnNames, 600, 150) nodeSpacing <- ifelse(.selections$bbnNames, 600, 150)
palette <- brewer.pal(length(legends), "RdYlGn") palette <- brewer.pal(length(legends), "RdYlGn")
nodes <- data.frame( nodes <- data.frame(
id = rownames(nodes), id = rownames(nodes),
label = labels, label = labels,
@@ -486,135 +498,132 @@ server <- function(input, output, session) {
group = nodes$layer, group = nodes$layer,
color = palette[as.integer(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$values) >= .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
repeat { repeat {
nodesToAdd <- nodes[nodes$id %in% edgeNet$to, ] nodesToAdd <- nodes[nodes$id %in% edgeNet$to, ]
nodesToAdd <- nodesToAdd[!(nodesToAdd$id %in% nodeNet$id),] nodesToAdd <- nodesToAdd[!(nodesToAdd$id %in% nodeNet$id),]
edgesToAdd <- edges[edges$from %in% nodesToAdd$id, ] edgesToAdd <- edges[edges$from %in% nodesToAdd$id, ]
edgesToAdd <- edgesToAdd[!(edgesToAdd$id %in% edgeNet$id),] edgesToAdd <- edgesToAdd[!(edgesToAdd$id %in% edgeNet$id),]
idx <- idx + 1 idx <- idx + 1
if ((idx>20) || ((nrow(nodesToAdd)==0) && (nrow(edgesToAdd)==0))) break if ((idx > 20) || ((nrow(nodesToAdd) == 0) && (nrow(edgesToAdd) == 0))) break
nodeNet <- rbind(nodeNet, nodesToAdd) nodeNet <- rbind(nodeNet, nodesToAdd)
edgeNet <- rbind(edgeNet, edgesToAdd) edgeNet <- rbind(edgeNet, edgesToAdd)
} #until finished } #until finished
} else edgeNet <- edges } else {
edgeNet <- edges
}
legendDF <- data.frame( legendDF <- data.frame(
id = 1:length(legends), id = 1:length(legends),
label = legends, label = legends,
color = palette, color = palette,
stringsAsFactors = FALSE stringsAsFactors = FALSE
) )
visNetwork(nodeNet, edgeNet, width = "100%", main='Bayesian Belief Network', submain=input$modelSelect) %>% visNetwork(nodeNet, edgeNet, width = "100%", main = "Bayesian Belief Network", submain = input$modelSelect) %>%
visExport() %>% visExport() %>%
visLegend(useGroups=FALSE, addNodes=legendDF) %>% visLegend(useGroups = FALSE, addNodes = legendDF) %>%
visHierarchicalLayout(nodeSpacing=nodeSpacing, direction='LR') %>% visHierarchicalLayout(nodeSpacing = nodeSpacing, direction = "LR") %>%
visOptions(highlightNearest = TRUE) #%>% visOptions(highlightNearest = TRUE) #%>%
#visInteraction(navigationButtons = TRUE, dragNodes = TRUE, dragView = TRUE, zoomView = TRUE) #visInteraction(navigationButtons = TRUE, dragNodes = TRUE, dragView = TRUE, zoomView = TRUE)
} }
output$bbnGraphPlot <- renderVisNetwork({ output$bbnGraphPlot <- renderVisNetwork({
makeBbnGraph(modelList[[.selections$model]]) makeBbnGraph(modelList[[.selections$model]])
}) })
#observe({ #observe({
# visNetworkProxy("bbnGraphPlot") %>% # visNetworkProxy("bbnGraphPlot") %>%
# visStabilize(iterations=10) # visStabilize(iterations = 10)
#}) #})
getModelName <- function() { getModelName <- function() {
paste0('data/', input$modelSelect, '.xlsx') paste0("data/", input$modelSelect, ".xlsx")
} }
genPlot <- function(boxPlot, title) { genPlot <- function(boxPlot, title) {
if (nrow(boxPlot)>0) { if (nrow(boxPlot) > 0) {
palette <- brewer.pal(length(legends), "RdYlGn") palette <- brewer.pal(length(legends), "RdYlGn")
#print(palette) names(palette) <- 1:length(legends)
colours <- palette[as.integer(boxPlot$Group)] #print(paste("Box plot, colours", nrow(boxPlot), length(colours)))
#print(paste('Box plot, colours', nrow(boxPlot), length(colours)))
#cat(colours) #cat(colours)
xform <- list(categoryorder = "array", xform <- list(categoryorder = "array",
categoryarray = boxPlot[,1], categoryarray = boxPlot[,1],
zerolinewidth=10) zerolinewidth = 10)
# #
plot_ly(boxPlot, x = boxPlot[,1], y = ~Range, color = colours, colors = palette, type = "box") %>% plot_ly(boxPlot, x = boxPlot[,1], y = ~Range, color = as.character(boxPlot$Group), colors = palette, type = "box") %>%
layout(xaxis = xform, showlegend=FALSE, title=title) layout(xaxis = xform, showlegend = FALSE, title = title)
} }
} }
prepPlot <- function(code="ba", name="Bio-Assemblage") { prepPlot <- function(code = "ba", name = "Bio-Assemblage") {
if (!is.null(.likelihoods$p_es)) { if (!is.null(.likelihoods$p_es)) {
inScope <- startsWith(.likelihoods$p_es$code, code) inScope <- startsWith(.likelihoods$p_es$code, code)
thisPlot <- .likelihoods$p_es[inScope, c(1,3,4)] thisPlot <- .likelihoods$p_es[inScope, c(1,3,4)]
colnames(thisPlot) <- c(name, "Group", "Range") colnames(thisPlot) <- c(name, "Group", "Range")
title <- paste(input$modelSelect, name, 'Box Plot') title <- paste(input$modelSelect, name, "Box Plot")
genPlot(thisPlot, title) genPlot(thisPlot, title)
} }
} }
output$layer1 <- renderPlotly({ output$layer1 <- renderPlotly({
prepPlot("ba", "Bio-Assemblage") prepPlot("ba", "Bio-Assemblage")
}) })
output$layer2 <- renderPlotly({ output$layer2 <- renderPlotly({
prepPlot("op", "Output Processes") prepPlot("op", "Output Processes")
}) })
output$layer3 <- renderPlotly({ output$layer3 <- renderPlotly({
prepPlot("es", "Ecosystem Services") prepPlot("es", "Ecosystem Services")
}) })
export <- function(model) { export <- function(model) {
#Get the network graph #Get the network graph
l1 <- orca(prepPlot("ba", "Bio-Assemblage"), 'tmp/layer1.png') l1 <- orca(prepPlot("ba", "Bio-Assemblage"), "tmp/layer1.png")
l2 <- orca(prepPlot("op", "Output Processes"),'tmp/layer2.png') l2 <- orca(prepPlot("op", "Output Processes"),"tmp/layer2.png")
l3 <- orca(prepPlot("es", "Ecosystem Services"), 'tmp/layer3.png') l3 <- orca(prepPlot("es", "Ecosystem Services"), "tmp/layer3.png")
#Save pressure list, confidence levels, node and edge tables in xlsx #Save pressure list, confidence levels, node and edge tables in xlsx
l <- list( l <- list(
pressures = .selections$pressStatus, pressures = .selections$pressStatus,
nodes = model$nodes, nodes = model$nodes,
edges = model$edges, edges = model$edges,
settings = as.data.frame(cbind(names(.resistanceScores), .resistanceScores), stringsAsFactors=FALSE) settings = as.data.frame(cbind(names(.resistanceScores), .resistanceScores), stringsAsFactors = FALSE)
) )
xl <- write.xlsx(l, 'tmp/dataset.xlsx') xl <- write.xlsx(l, "tmp/dataset.xlsx")
print('saving xlsx file export tmp/dataset.xlsx') print("saving xlsx file export tmp/dataset.xlsx")
zipFile <- zipr(paste0('tmp/MESO-', format(Sys.time(), "%m%d_%H%M"), '.zip'), c('tmp/layer1.png', 'tmp/layer2.png', 'tmp/layer3.png', 'tmp/dataset.xlsx')) zipFile <- zipr(paste0("tmp/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)) print(paste("zip file complete", zipFile))
return(zipFile) return(zipFile)
} }
output$linkBackgroundData <- downloadHandler( output$linkBackgroundData <- downloadHandler(
filename = getModelName(), filename = getModelName(),
content = function(file) { content = function(file) {
@@ -622,9 +631,9 @@ server <- function(input, output, session) {
}, },
contentType = "application/xlsx" contentType = "application/xlsx"
) )
output$download <-downloadHandler( output$download <- downloadHandler(
filename = paste0('MESO-', format(Sys.time(), "%m%d_%H%M"), '.zip'), filename = paste0("MESO-", format(Sys.time(), "%m%d_%H%M"), ".zip"),
content = function(file) { content = function(file) {
fName <- export(modelList[[.selections$model]]) fName <- export(modelList[[.selections$model]])
file.copy(fName, file) file.copy(fName, file)
@@ -632,7 +641,7 @@ server <- function(input, output, session) {
contentType = "application/zip" contentType = "application/zip"
) )
} }
shinyApp(ui, server) shinyApp(ui, server)

1688
package-lock.json generated Normal file
View File

File diff suppressed because it is too large Load Diff

15
package.json Normal file
View File

@@ -0,0 +1,15 @@
{
"name": "jncc-meso",
"version": "1.0.0",
"description": "A Bayesian Belief Network to estimate the impacts of pressure of marine environments",
"dependencies": {
"electron": "^4.1.4",
"orca": "^1.2.1"
},
"devDependencies": {},
"scripts": {
"test": "echo \"Error: no test specified\" && exit 1"
},
"author": "AVS Developments Ltd",
"license": "MIT"
}