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

Syntax conformation

Browse Source
This commit is contained in:
Craig Williams
2019-04-11 12:47:53 +01:00
parent 7752b73bc6
commit 29e0bd0cf2
2 changed files with 325 additions and 297 deletions
Download Patch File Download Diff File Expand all files Collapse all files

171
Parses.R
View File

@@ -1,24 +1,24 @@
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) {
@@ -32,38 +32,50 @@ 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(
name = pressNames,
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'], 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)
)) ))
} }
@@ -73,32 +85,34 @@ getInitial <- function(string, letter) {
} }
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)
} }
@@ -128,20 +142,20 @@ 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$values[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)
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') print("network build successful")
inDist <- vector(mode = "list", length = length(inputNodes)) inDist <- vector(mode = "list", length = length(inputNodes))
@@ -151,17 +165,17 @@ 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)]
@@ -185,47 +199,51 @@ getValidNodes <- function(mapping, prevOutputs, prefix) {
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)
@@ -245,13 +263,14 @@ getCode <- function(name, nodeDF) {
} }
getValidEdges <- function(mapping, nodeDF, prevEdge = NULL, prefix) { getValidEdges <- function(mapping, nodeDF, prevEdge = NULL, prefix) {
str(nodeDF) utils::str(nodeDF)
edgeCols <- c('inputNode', 'outputNode', 'impact')
edgeCols <- c("inputNode", "outputNode", "impact")
edgeM <- matrix(data = NA, nrow = 0, ncol = length(edgeCols), dimnames = list(NULL, edgeCols)) 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)) {
@@ -259,33 +278,32 @@ getValidEdges <- function(mapping, nodeDF, prevEdge=NULL, prefix) {
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])
@@ -297,13 +315,12 @@ parseMapping <- function(mapping, prevOutputs, prefix) {
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)
@@ -312,23 +329,23 @@ parseSheet <- function(fName) {
sheets <- sort(delNA(match(names, mappings))) sheets <- sort(delNA(match(names, mappings)))
cat('starting sheet parse') cat("starting sheet parse")
print(sheets) print(sheets)
if (sum(sheets == refs) == length(refs)) { if (sum(sheets == refs) == length(refs)) {
#read all mapping tables #read all mapping tables
scenario <- parseScenario(readXL(fName,mappings[1], startRow=1), prefix='p') scenario <- parseScenario(readXL(fName,mappings[1], startRow = 1), prefix = "p")
p_ba <- parseMapping(readXL(fName,mappings[2], startRow=1), scenario, prefix='ba') 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_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,
@@ -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])
} }
} }

213
app.R
View File

@@ -1,45 +1,38 @@
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') addResourcePath("js", "./www/js")
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.45, 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', legends <- c("Pressures",
'Suspension feeders', "Suspension feeders",
'Mobile and burrow dwellers', "Mobile and burrow dwellers",
'Predators', "Predators",
'Epifauna and algae', "Epifauna and algae",
'Functional groups', "Functional groups",
'Output processes', "Output processes",
'Output enablers', "Output enablers",
'Ecosystem services') "Ecosystem services")
addResourcePath("js", "./www/js")
ui <- dashboardPage( ui <- dashboardPage(
dashboardHeader(title = "JNCC MESO online", dashboardHeader(title = "JNCC MESO online",
@@ -105,11 +98,11 @@ ui<-dashboardPage(
), ),
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,
@@ -121,14 +114,14 @@ ui<-dashboardPage(
) )
), ),
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,
@@ -140,7 +133,7 @@ ui<-dashboardPage(
), ),
column( column(
width = 4, width = 4,
selectInput("bbnImpactSelect", "Impact Threshold", choices=impacts, selected='All') selectInput("bbnImpactSelect", "Impact Threshold", choices = impacts, selected = "All")
) )
), ),
fluidRow( fluidRow(
@@ -149,13 +142,13 @@ 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")
) )
) )
) )
@@ -169,8 +162,8 @@ ui<-dashboardPage(
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")
) )
) )
) )
@@ -180,10 +173,10 @@ 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
@@ -234,13 +227,13 @@ server <- function(input, output, session) {
} }
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)
@@ -249,9 +242,9 @@ server <- function(input, output, session) {
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)
@@ -266,7 +259,7 @@ server <- function(input, output, session) {
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"
@@ -278,29 +271,29 @@ server <- function(input, output, session) {
thisModel <- modelList[[.selections$model]] thisModel <- modelList[[.selections$model]]
modelList[[.selections$model]]$edges$values <<- sapply(thisModel$edges$impact, getImpact) modelList[[.selections$model]]$edges$values <<- sapply(thisModel$edges$impact, getImpact)
modelList[[.selections$model]]$nodes$growth <<- .resistanceScores['ssgr'] modelList[[.selections$model]]$nodes$growth <<- .resistanceScores["ssgr"]
modelList[[.selections$model]]$nodes$confidence <<- .resistanceScores['pressSD'] modelList[[.selections$model]]$nodes$confidence <<- .resistanceScores["pressSD"]
thisModel <- modelList[[.selections$model]] thisModel <- modelList[[.selections$model]]
MEANPOS=1 MEANPOS <- 1
MEANNEG=0 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,
@@ -319,7 +312,7 @@ server <- function(input, output, session) {
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,
@@ -349,17 +342,19 @@ server <- function(input, output, session) {
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
} }
@@ -367,15 +362,18 @@ server <- function(input, output, session) {
}) })
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)
} }
@@ -411,27 +409,27 @@ server <- function(input, output, session) {
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, { observeEvent(input$modalOK, {
print('Modal ok pressed') print("Modal ok pressed")
.resistanceScores['nr'] <<- -input$l1VH .resistanceScores["nr"] <<- -input$l1VH
.resistanceScores['lr'] <<- -input$l1H .resistanceScores["lr"] <<- -input$l1H
.resistanceScores['mr'] <<- -input$l1M .resistanceScores["mr"] <<- -input$l1M
.resistanceScores['hr'] <<- -input$l1L .resistanceScores["hr"] <<- -input$l1L
.resistanceScores['ins'] <<- -input$l1VL .resistanceScores["ins"] <<- -input$l1VL
.resistanceScores['ssgr'] <<- input$ssgr .resistanceScores["ssgr"] <<- input$ssgr
.resistanceScores['pressSD'] <<- input$l1PressSD .resistanceScores["pressSD"] <<- input$l1PressSD
print('Running calc') 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)
@@ -442,15 +440,21 @@ server <- function(input, output, session) {
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) {
@@ -462,7 +466,11 @@ server <- function(input, output, session) {
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),
@@ -473,7 +481,11 @@ server <- function(input, output, session) {
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)
@@ -491,14 +503,14 @@ server <- function(input, output, session) {
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),]
@@ -512,7 +524,9 @@ server <- function(input, output, session) {
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),
@@ -521,10 +535,10 @@ server <- function(input, output, session) {
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)
} }
@@ -539,7 +553,7 @@ server <- function(input, output, session) {
#}) #})
getModelName <- function() { getModelName <- function() {
paste0('data/', input$modelSelect, '.xlsx') paste0("data/", input$modelSelect, ".xlsx")
} }
genPlot <- function(boxPlot, title) { genPlot <- function(boxPlot, title) {
@@ -550,7 +564,7 @@ server <- function(input, output, session) {
colours <- palette[as.integer(boxPlot$Group)] 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],
@@ -567,7 +581,7 @@ server <- function(input, output, session) {
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)
} }
} }
@@ -588,9 +602,9 @@ server <- function(input, output, session) {
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(
@@ -600,21 +614,18 @@ server <- function(input, output, session) {
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) {
@@ -624,7 +635,7 @@ server <- function(input, output, session) {
) )
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)