Syntax conformation
This commit is contained in:
171
Parses.R
171
Parses.R
@@ -1,24 +1,24 @@
|
||||
|
||||
modules::import(openxlsx)
|
||||
modules::import(bnlearn)
|
||||
modules::import(openxlsx)
|
||||
modules::import(stringr)
|
||||
modules::import(graph)
|
||||
modules::import(ggplot2)
|
||||
modules::import(stats)
|
||||
modules::import(plotly)
|
||||
modules::import(utils)
|
||||
|
||||
|
||||
#Improvements needed: make the selection of first row/column of nodes programmatic
|
||||
FIRST_NODE_COL <- 3
|
||||
|
||||
mappings <- c('TestScenario', 'Map_P_BA', 'Map_BA_OP', 'Map_OP_ES')
|
||||
nodeTypes <- c('Input.Nodes', 'Internal.Nodes', 'Published.Nodes')
|
||||
states <- c('impact', 'confidence', 'growth', 'recovery', 'layer')
|
||||
mappings <- c("TestScenario", "Map_P_BA", "Map_BA_OP", "Map_OP_ES")
|
||||
nodeTypes <- c("Input.Nodes", "Internal.Nodes", "Published.Nodes")
|
||||
states <- c("impact", "confidence", "growth", "recovery", "layer")
|
||||
refs <- c(1:length(mappings))
|
||||
|
||||
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) {
|
||||
@@ -32,38 +32,50 @@ delNA <- function(vec) {
|
||||
|
||||
buildExpr <- function(pressStatus) {
|
||||
#pressStatus is a two column DF of name of pressure and status Ii.e. on or off)
|
||||
MEANPRESS = 0
|
||||
MEANPRESS <- 0
|
||||
expr <- "("
|
||||
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 <- substr(expr, 1, nchar(expr) - 2)
|
||||
expr<-paste0(expr, ')')
|
||||
expr <- paste0(expr, ")")
|
||||
|
||||
return(expr)
|
||||
}
|
||||
|
||||
parseScenario <- function(press, prefix = 'p') {
|
||||
parseScenario <- function(press, prefix = "p") {
|
||||
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)) {
|
||||
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
|
||||
if (sum(duplicated(pressNames)) > 0) {
|
||||
cat('Duplicated pressure node names found')
|
||||
cat("Duplicated pressure node names found")
|
||||
print(pressNodes[duplicated(pressNames)])
|
||||
}
|
||||
|
||||
return(list(
|
||||
timeSeq = press,
|
||||
nodes=data.frame(name = pressNames,
|
||||
nodes = data.frame(
|
||||
name = pressNames,
|
||||
code = paste0(prefix, seq(1:length(pressNames))),
|
||||
growth = coefs[,'growth'],
|
||||
confidence=coefs[,'confidence'],
|
||||
layer=coefs[,'layer'],
|
||||
stringsAsFactors = FALSE),
|
||||
growth = coefs[,"growth"],
|
||||
confidence = coefs[,"confidence"],
|
||||
layer = coefs[,"layer"],
|
||||
stringsAsFactors = FALSE
|
||||
),
|
||||
edges = data.frame(input = NULL, output = NULL, impact = NULL)
|
||||
))
|
||||
}
|
||||
@@ -73,32 +85,34 @@ getInitial <- function(string, letter) {
|
||||
}
|
||||
|
||||
split <- function(cell) {
|
||||
params <- unlist(strsplit(cell, ','))
|
||||
params <- unlist(strsplit(cell, ","))
|
||||
values <- rep(0, length(states))
|
||||
|
||||
for (n in 1:length(params)) {
|
||||
kvp <- unlist(strsplit(params[n], '='))
|
||||
kvp <- unlist(strsplit(params[n], "="))
|
||||
ref <- match(getInitial(trimws(kvp[1])), getInitial(states))
|
||||
|
||||
if ((ref > 0) & (ref <= length(values))) {
|
||||
values[ref] <- kvp[2]
|
||||
} else {
|
||||
print(paste('Unrecognised parameter(s):',params[n]))
|
||||
print(paste("Unrecognised parameter(s):",params[n]))
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
return(values)
|
||||
|
||||
}
|
||||
|
||||
cleanTitles <- function(titleV) {
|
||||
return(str_replace_all(titleV, c(' ' = '.', '-' = '')))
|
||||
return(str_replace_all(titleV, c(" " = ".", "-" = "")))
|
||||
}
|
||||
|
||||
getOutNodes <- function(codes, codeList) {
|
||||
v <- vector(mode='logical', length=length(codes))
|
||||
v <- vector(mode = "logical", length = length(codes))
|
||||
|
||||
for (idx in 1:length(codes)) {
|
||||
v[idx] <- (sum(startsWith(codes[idx], codeList)) > 0)
|
||||
}
|
||||
|
||||
return(v)
|
||||
}
|
||||
|
||||
@@ -128,20 +142,20 @@ buildGraph <- function(model, desc) {
|
||||
edges <- paste0(edges, paste0("[", outNodes[idx], "|", substr(inputsStr, start = 1, stop = (nchar(inputsStr)-1)), "]"))
|
||||
|
||||
#Make the coefficient of the distribution
|
||||
coefVal <- setNames(c(model$nodes$growth[nodeRef], model$edges$values[rows]),
|
||||
coefVal <- setNames(
|
||||
c(model$nodes$growth[nodeRef], model$edges$values[rows]),
|
||||
c("(Intercept)", model$edges$input[rows])
|
||||
)
|
||||
#str(coefVal)
|
||||
outDist[[idx]] <- list(coef = coefVal,
|
||||
sd = model$nodes$confidence[nodeRef])
|
||||
outDist[[idx]] <- list(coef = coefVal, sd = model$nodes$confidence[nodeRef])
|
||||
}
|
||||
|
||||
print('about to build network')
|
||||
print("about to build network")
|
||||
print(paste0(inputText, edges))
|
||||
|
||||
net <- model2network(paste0(inputText, edges), debug = TRUE)
|
||||
|
||||
print('network build successful')
|
||||
print("network build successful")
|
||||
|
||||
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])
|
||||
}
|
||||
|
||||
allDists = as.list(setNames(c(inDist, outDist), c(inputNodes, outNodes)))
|
||||
cfit = custom.fit(net, allDists)
|
||||
allDists <- as.list(setNames(c(inDist, outDist), c(inputNodes, outNodes)))
|
||||
cfit <- custom.fit(net, allDists)
|
||||
|
||||
cat('about to calculate sample distributions')
|
||||
cat("about to calculate sample distributions")
|
||||
print(outNodes)
|
||||
|
||||
sampleDists <- cpdist(cfit, nodes = outNodes, evidence = TRUE, n = 10000, method = "lw")
|
||||
summDists <- summary(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$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]
|
||||
|
||||
#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 (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])
|
||||
}
|
||||
} 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
|
||||
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) {
|
||||
cat('Duplicated input node names found')
|
||||
cat("Duplicated input node names found")
|
||||
print(inputNodes[duplicated(inputNodes)])
|
||||
}
|
||||
|
||||
outNodes <- delNA(colnames(mapping)[FIRST_NODE_COL:ncol(mapping)])
|
||||
if (sum(duplicated(outNodes)) > 0) {
|
||||
cat('Duplicated output node names found')
|
||||
cat("Duplicated output node names found")
|
||||
print(outNodes[duplicated(outNodes)])
|
||||
}
|
||||
|
||||
|
||||
#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 (sum(intNodes %in% outNodes)<length(intNodes)) {
|
||||
cat('Missing entries for internal nodes in output columns')
|
||||
print(intNodes[!intNodes %in% outNodes])
|
||||
cat("Missing entries for internal nodes in output columns")
|
||||
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)) {
|
||||
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)
|
||||
@@ -245,13 +263,14 @@ getCode <- function(name, nodeDF) {
|
||||
}
|
||||
|
||||
getValidEdges <- function(mapping, nodeDF, prevEdge = NULL, prefix) {
|
||||
str(nodeDF)
|
||||
edgeCols <- c('inputNode', 'outputNode', 'impact')
|
||||
utils::str(nodeDF)
|
||||
|
||||
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....
|
||||
for (col in FIRST_NODE_COL:ncol(mapping)) {
|
||||
count=0
|
||||
count <- 0
|
||||
|
||||
for (row in 2:nrow(mapping)) {
|
||||
|
||||
@@ -259,33 +278,32 @@ getValidEdges <- function(mapping, nodeDF, prevEdge=NULL, prefix) {
|
||||
edgeM <- rbind(edgeM,
|
||||
c(getCode(mapping[row, 1], 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 (
|
||||
data.frame(
|
||||
if (is.null(prevEdge)) {
|
||||
return (data.frame(
|
||||
input = edgeM[,"inputNode"],
|
||||
output = edgeM[,"outputNode"],
|
||||
impact = edgeM[,"impact"],
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
) else return (
|
||||
data.frame(
|
||||
))
|
||||
} else {
|
||||
return (data.frame(
|
||||
input = c(prevEdge$input, edgeM[,"inputNode"]),
|
||||
output = c(prevEdge$output, edgeM[,"outputNode"]),
|
||||
impact = c(prevEdge$impact, edgeM[,"impact"]),
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
)
|
||||
))
|
||||
}
|
||||
}
|
||||
|
||||
parseMapping <- function(mapping, prevOutputs, prefix) {
|
||||
|
||||
mapping <- mapping[,-1]
|
||||
mapping[,1] <- cleanTitles(mapping[,1])
|
||||
|
||||
@@ -297,13 +315,12 @@ parseMapping <- function(mapping, prevOutputs, prefix) {
|
||||
nodes = nodeDF,
|
||||
edges = edgeDF
|
||||
))
|
||||
|
||||
}
|
||||
|
||||
parseSheet <- function(fName) {
|
||||
#get sheet names
|
||||
|
||||
print(paste('starting sheet load', fName))
|
||||
print(paste("starting sheet load", fName))
|
||||
|
||||
if (file.exists(fName)) {
|
||||
names <- openxlsx::getSheetNames(fName)
|
||||
@@ -312,23 +329,23 @@ parseSheet <- function(fName) {
|
||||
|
||||
sheets <- sort(delNA(match(names, mappings)))
|
||||
|
||||
cat('starting sheet parse')
|
||||
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')
|
||||
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')
|
||||
#print("building graphs")
|
||||
|
||||
#p_baNet <- buildGraph(p_ba, desc=list(inputCode='p', outputCodes='ba'))
|
||||
#p_opNet <- buildGraph(p_op, desc=list(inputCode='p', outputCodes=c('ba', 'op')))
|
||||
#p_esNet <- buildGraph(p_es, desc=list(inputCode='p', outputCodes=c('ba', 'op', 'es')))
|
||||
#p_baNet <- buildGraph(p_ba, desc = list(inputCode = "p", outputCodes = "ba"))
|
||||
#p_opNet <- buildGraph(p_op, desc = list(inputCode = "p", outputCodes = c("ba", "op")))
|
||||
#p_esNet <- buildGraph(p_es, desc = list(inputCode = "p", outputCodes = c("ba", "op", "es")))
|
||||
|
||||
print('sheet load completed')
|
||||
print("sheet load completed")
|
||||
return(
|
||||
#list(
|
||||
#pressBioAss = p_baNet,
|
||||
@@ -339,8 +356,8 @@ parseSheet <- function(fName) {
|
||||
)
|
||||
|
||||
} else {
|
||||
print(paste('Sheets found include', mappings[sheets]))
|
||||
cat('Missing sheets are:')
|
||||
print(paste("Sheets found include", mappings[sheets]))
|
||||
cat("Missing sheets are:")
|
||||
print(refs[-sheets])
|
||||
}
|
||||
}
|
||||
|
||||
213
app.R
213
app.R
@@ -1,45 +1,38 @@
|
||||
modules::import(DT)
|
||||
modules::import(shiny)
|
||||
modules::import(shinyBS)
|
||||
modules::import(shinyjs)
|
||||
modules::import(shinydashboard)
|
||||
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(googleway)
|
||||
modules::import(shinyjs)
|
||||
|
||||
modules::import(bnlearn)
|
||||
modules::import(visNetwork)
|
||||
modules::import(RColorBrewer)
|
||||
modules::import(zip)
|
||||
modules::import(processx)
|
||||
modules::import(plotly)
|
||||
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")
|
||||
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)
|
||||
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")
|
||||
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",
|
||||
@@ -105,11 +98,11 @@ ui<-dashboardPage(
|
||||
),
|
||||
dashboardBody(
|
||||
tabItems(
|
||||
tabItem(tabName = "1", h2('Impact Distribution'),
|
||||
tabItem(tabName = "1", h2("Impact Distribution"),
|
||||
fluidRow(
|
||||
column(
|
||||
width = 6,
|
||||
h4('Effect on bio-assemblage')
|
||||
h4("Effect on bio-assemblage")
|
||||
),
|
||||
column(
|
||||
width = 1,
|
||||
@@ -121,14 +114,14 @@ ui<-dashboardPage(
|
||||
)
|
||||
),
|
||||
plotlyOutput("layer1", height = "270px") %>% withSpinner(),
|
||||
h4('Effect on Output Processes'),
|
||||
h4("Effect on Output Processes"),
|
||||
plotlyOutput("layer2", height = "270px") %>% withSpinner(),
|
||||
h4('Effect on Ecosystem services'),
|
||||
h4("Effect on Ecosystem services"),
|
||||
plotlyOutput("layer3", height = "270px") %>% withSpinner()
|
||||
),
|
||||
tabItem(tabName = "2",h2("Bayesian Network"),
|
||||
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(
|
||||
column(
|
||||
width = 4,
|
||||
@@ -140,7 +133,7 @@ ui<-dashboardPage(
|
||||
),
|
||||
column(
|
||||
width = 4,
|
||||
selectInput("bbnImpactSelect", "Impact Threshold", choices=impacts, selected='All')
|
||||
selectInput("bbnImpactSelect", "Impact Threshold", choices = impacts, selected = "All")
|
||||
)
|
||||
),
|
||||
fluidRow(
|
||||
@@ -149,13 +142,13 @@ ui<-dashboardPage(
|
||||
fluidRow(
|
||||
column(
|
||||
width = 6,
|
||||
h4('Ecoservice nodes'),
|
||||
DT::dataTableOutput('nodeTable')
|
||||
h4("Ecoservice nodes"),
|
||||
DT::dataTableOutput("nodeTable")
|
||||
),
|
||||
column(
|
||||
width = 6,
|
||||
h4('Ecoservice influences'),
|
||||
DT::dataTableOutput('edgeTable')
|
||||
h4("Ecoservice influences"),
|
||||
DT::dataTableOutput("edgeTable")
|
||||
)
|
||||
)
|
||||
)
|
||||
@@ -169,8 +162,8 @@ ui<-dashboardPage(
|
||||
fluidPage(
|
||||
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"),
|
||||
fluidRow(renderUI('status')),
|
||||
actionButton('loadAB', 'Load') # icon='upload')
|
||||
fluidRow(renderUI("status")),
|
||||
actionButton("loadAB", "Load") # icon = "upload")
|
||||
)
|
||||
)
|
||||
)
|
||||
@@ -180,10 +173,10 @@ ui<-dashboardPage(
|
||||
server <- function(input, output, session) {
|
||||
#SERVER Constants
|
||||
|
||||
print('Loading data')
|
||||
print("Loading data")
|
||||
|
||||
#set_key("AIzaSyAw8_btgGN1drf8qhCxNcotP6r11qEXA_M")
|
||||
dataStorage <- 'data/'
|
||||
dataStorage <- "data/"
|
||||
|
||||
models <- NULL
|
||||
pressures <- NULL
|
||||
@@ -234,13 +227,13 @@ server <- function(input, output, session) {
|
||||
}
|
||||
|
||||
getAvailableModels <- function() {
|
||||
fileList <- list.files(dataStorage, pattern='.xlsx')
|
||||
fileList <- list.files(dataStorage, pattern = ".xlsx")
|
||||
|
||||
modelList <- list()
|
||||
cnt <- 1
|
||||
|
||||
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]))
|
||||
print(tmp)
|
||||
@@ -249,9 +242,9 @@ server <- function(input, output, session) {
|
||||
if (!is.null(tmp)) {
|
||||
modelList[[cnt]] <- tmp
|
||||
models <<- c(models, substr(fileList[idx], 1, (nchar(fileList[idx])-5)))
|
||||
print(paste('Model file successfully loaded', fileList[idx]))
|
||||
#save(tmp, file='tmp.RData')
|
||||
cnt=cnt+1
|
||||
print(paste("Model file successfully loaded", fileList[idx]))
|
||||
#save(tmp, file = "tmp.RData")
|
||||
cnt <- cnt+1
|
||||
}
|
||||
}
|
||||
updateSelectInput(session, "modelSelect", choices = models)
|
||||
@@ -266,7 +259,7 @@ server <- function(input, output, session) {
|
||||
|
||||
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]]
|
||||
|
||||
modelList[[.selections$model]]$edges$values <<- sapply(thisModel$edges$impact, getImpact)
|
||||
modelList[[.selections$model]]$nodes$growth <<- .resistanceScores['ssgr']
|
||||
modelList[[.selections$model]]$nodes$confidence <<- .resistanceScores['pressSD']
|
||||
modelList[[.selections$model]]$nodes$growth <<- .resistanceScores["ssgr"]
|
||||
modelList[[.selections$model]]$nodes$confidence <<- .resistanceScores["pressSD"]
|
||||
|
||||
thisModel <- modelList[[.selections$model]]
|
||||
|
||||
|
||||
MEANPOS=1
|
||||
MEANNEG=0
|
||||
MEANPOS <- 1
|
||||
MEANNEG <- 0
|
||||
|
||||
expr <- "list("
|
||||
for (p in 1:nrow(pressStatus)) {
|
||||
if (pressStatus$status[p] == 'On') {
|
||||
threshold = MEANPOS
|
||||
if (pressStatus$status[p] == "On") {
|
||||
threshold <- MEANPOS
|
||||
} else {
|
||||
threshold = MEANNEG
|
||||
threshold <- MEANNEG
|
||||
}
|
||||
|
||||
expr <- paste0(expr, "\"", pressStatus$code[p], "\" = ", threshold, ", ")
|
||||
}
|
||||
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(
|
||||
fitted = thisNet$cfit,
|
||||
@@ -319,7 +312,7 @@ server <- function(input, output, session) {
|
||||
means <- apply(sampleDists, 2, mean)
|
||||
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(
|
||||
name = thisModel$nodes$name,
|
||||
@@ -349,17 +342,19 @@ server <- function(input, output, session) {
|
||||
|
||||
if (length(matches) > 0) {
|
||||
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)
|
||||
|
||||
if (!identical(newStatus, .selections$pressStatus)) {
|
||||
print('Running calc')
|
||||
print("Running calc")
|
||||
#.likelihoods$p_ba <<- calcLikelihood(1, newStatus)
|
||||
#.likelihoods$ba_os <<- calcLikelihood(2, newStatus)
|
||||
#.likelihoods$os_es <<- calcLikelihood(3, newStatus)
|
||||
.likelihoods$p_es <<- calcLikelihood(0, newStatus)
|
||||
#write.xlsx(.likelihoods$p_es, 'tmp.xlsx')
|
||||
#write.xlsx(.likelihoods$p_es, "tmp.xlsx")
|
||||
.selections$pressStatus <<- newStatus
|
||||
}
|
||||
|
||||
@@ -367,15 +362,18 @@ server <- function(input, output, session) {
|
||||
})
|
||||
|
||||
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({
|
||||
#isolate({
|
||||
if (!is.null(modelList[[.selections$model]]$nodes)) {
|
||||
pressCodes <- which(startsWith(modelList[[.selections$model]]$nodes$code, 'p'))
|
||||
pressures <- data.frame(code = modelList[[.selections$model]]$nodes$code[pressCodes],
|
||||
name = modelList[[.selections$model]]$nodes$name[pressCodes], stringsAsFactors=FALSE)
|
||||
pressCodes <- which(startsWith(modelList[[.selections$model]]$nodes$code, "p"))
|
||||
pressures <- data.frame(
|
||||
code = modelList[[.selections$model]]$nodes$code[pressCodes],
|
||||
name = modelList[[.selections$model]]$nodes$name[pressCodes],
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
setPressures(pressures)
|
||||
btnList <- apply(pressures, 1, makeRadioButtons)
|
||||
}
|
||||
@@ -411,27 +409,27 @@ server <- function(input, output, session) {
|
||||
sliderInput("l1PressSD", "Pressure Std Dev", 0.1, 1.0, .resistanceScores[7], step = 0.01)
|
||||
)
|
||||
},
|
||||
title='Layer 1 controls',
|
||||
title = "Layer 1 controls",
|
||||
footer = tagList(
|
||||
modalButton("Cancel"),
|
||||
actionButton("modalOK", "OK")
|
||||
),
|
||||
size='s')
|
||||
size = "s")
|
||||
)
|
||||
})
|
||||
|
||||
observeEvent(input$modalOK, {
|
||||
print('Modal ok pressed')
|
||||
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
|
||||
.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')
|
||||
print("Running calc")
|
||||
#.likelihoods$p_ba <<- calcLikelihood(1, .selections$pressStatus)
|
||||
#.likelihoods$ba_os <<- calcLikelihood(2, .selections$pressStatus)
|
||||
#.likelihoods$os_es <<- calcLikelihood(3, .selections$pressStatus)
|
||||
@@ -442,15 +440,21 @@ server <- function(input, output, session) {
|
||||
|
||||
|
||||
output$nodeTable <- DT::renderDataTable(
|
||||
|
||||
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(
|
||||
|
||||
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) {
|
||||
@@ -462,7 +466,11 @@ server <- function(input, output, session) {
|
||||
makeBbnGraph <- function(model) {
|
||||
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(
|
||||
id = rownames(model$edges),
|
||||
@@ -473,7 +481,11 @@ server <- function(input, output, session) {
|
||||
arrows = "to",
|
||||
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)
|
||||
|
||||
@@ -491,14 +503,14 @@ server <- function(input, output, session) {
|
||||
|
||||
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) {
|
||||
#do pressures
|
||||
edgeNet <- edges[edges$from %in% nodeNet$id, ]
|
||||
idx = 1
|
||||
idx <- 1
|
||||
repeat {
|
||||
nodesToAdd <- nodes[nodes$id %in% edgeNet$to, ]
|
||||
nodesToAdd <- nodesToAdd[!(nodesToAdd$id %in% nodeNet$id),]
|
||||
@@ -512,7 +524,9 @@ server <- function(input, output, session) {
|
||||
edgeNet <- rbind(edgeNet, edgesToAdd)
|
||||
|
||||
} #until finished
|
||||
} else edgeNet <- edges
|
||||
} else {
|
||||
edgeNet <- edges
|
||||
}
|
||||
|
||||
legendDF <- data.frame(
|
||||
id = 1:length(legends),
|
||||
@@ -521,10 +535,10 @@ server <- function(input, output, session) {
|
||||
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() %>%
|
||||
visLegend(useGroups = FALSE, addNodes = legendDF) %>%
|
||||
visHierarchicalLayout(nodeSpacing=nodeSpacing, direction='LR') %>%
|
||||
visHierarchicalLayout(nodeSpacing = nodeSpacing, direction = "LR") %>%
|
||||
visOptions(highlightNearest = TRUE) #%>%
|
||||
#visInteraction(navigationButtons = TRUE, dragNodes = TRUE, dragView = TRUE, zoomView = TRUE)
|
||||
}
|
||||
@@ -539,7 +553,7 @@ server <- function(input, output, session) {
|
||||
#})
|
||||
|
||||
getModelName <- function() {
|
||||
paste0('data/', input$modelSelect, '.xlsx')
|
||||
paste0("data/", input$modelSelect, ".xlsx")
|
||||
}
|
||||
|
||||
genPlot <- function(boxPlot, title) {
|
||||
@@ -550,7 +564,7 @@ server <- function(input, output, session) {
|
||||
|
||||
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)
|
||||
xform <- list(categoryorder = "array",
|
||||
categoryarray = boxPlot[,1],
|
||||
@@ -567,7 +581,7 @@ server <- function(input, output, session) {
|
||||
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')
|
||||
title <- paste(input$modelSelect, name, "Box Plot")
|
||||
genPlot(thisPlot, title)
|
||||
}
|
||||
}
|
||||
@@ -588,9 +602,9 @@ server <- function(input, output, session) {
|
||||
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')
|
||||
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(
|
||||
@@ -600,21 +614,18 @@ server <- function(input, output, session) {
|
||||
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)
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
output$linkBackgroundData <- downloadHandler(
|
||||
filename = getModelName(),
|
||||
content = function(file) {
|
||||
@@ -624,7 +635,7 @@ server <- function(input, output, session) {
|
||||
)
|
||||
|
||||
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) {
|
||||
fName <- export(modelList[[.selections$model]])
|
||||
file.copy(fName, file)
|
||||
|
||||
Reference in New Issue
Block a user