Commit before first release
This commit is contained in:
@@ -5,3 +5,5 @@ archive
|
|||||||
data/tmp/
|
data/tmp/
|
||||||
data/new/
|
data/new/
|
||||||
node_modules/
|
node_modules/
|
||||||
|
app.R.orig
|
||||||
|
tmp/
|
||||||
|
|||||||
23
Parses.R
23
Parses.R
@@ -8,7 +8,7 @@ modules::import(stats)
|
|||||||
#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", "Legend")
|
||||||
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))
|
||||||
@@ -151,9 +151,9 @@ buildGraph <- function(model, desc) {
|
|||||||
}
|
}
|
||||||
|
|
||||||
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 = FALSE)
|
||||||
|
|
||||||
print("network build successful")
|
print("network build successful")
|
||||||
|
|
||||||
@@ -169,7 +169,7 @@ buildGraph <- function(model, desc) {
|
|||||||
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)
|
||||||
@@ -246,7 +246,7 @@ getValidNodes <- function(mapping, prevOutputs, prefix) {
|
|||||||
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)))),
|
||||||
@@ -263,7 +263,7 @@ getCode <- function(name, nodeDF) {
|
|||||||
}
|
}
|
||||||
|
|
||||||
getValidEdges <- function(mapping, nodeDF, prevEdge = NULL, prefix) {
|
getValidEdges <- function(mapping, nodeDF, prevEdge = NULL, prefix) {
|
||||||
utils::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))
|
||||||
@@ -338,6 +338,7 @@ parseSheet <- function(fName) {
|
|||||||
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")
|
||||||
|
legend <- readXL(fName,mappings[5], startRow = 1)
|
||||||
|
|
||||||
#print("building graphs")
|
#print("building graphs")
|
||||||
|
|
||||||
@@ -347,12 +348,10 @@ parseSheet <- function(fName) {
|
|||||||
|
|
||||||
print("sheet load completed")
|
print("sheet load completed")
|
||||||
return(
|
return(
|
||||||
#list(
|
list(
|
||||||
#pressBioAss = p_baNet,
|
p_esMap = p_es,
|
||||||
#pressOpProc = p_opNet,
|
legend = legend
|
||||||
#pressEcoServ = p_esNet,
|
)
|
||||||
p_esMap = p_es
|
|
||||||
#)
|
|
||||||
)
|
)
|
||||||
|
|
||||||
} else {
|
} else {
|
||||||
|
|||||||
200
app.R
200
app.R
@@ -24,15 +24,6 @@ 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",
|
|
||||||
"Suspension feeders",
|
|
||||||
"Mobile and burrow dwellers",
|
|
||||||
"Predators",
|
|
||||||
"Epifauna and algae",
|
|
||||||
"Functional groups",
|
|
||||||
"Output processes",
|
|
||||||
"Output enablers",
|
|
||||||
"Ecosystem services")
|
|
||||||
|
|
||||||
ui <- dashboardPage(
|
ui <- dashboardPage(
|
||||||
dashboardHeader(title = "JNCC MESO online",
|
dashboardHeader(title = "JNCC MESO online",
|
||||||
@@ -84,21 +75,70 @@ ui <- dashboardPage(
|
|||||||
),
|
),
|
||||||
dashboardSidebar(
|
dashboardSidebar(
|
||||||
sidebarMenu(id = "tabs",
|
sidebarMenu(id = "tabs",
|
||||||
menuItem("Pressure Test", tabName = "1", icon = icon("arrow-down")),
|
menuItem("Introduction", tabName = "1", icon = icon("arrow-down")),
|
||||||
menuItem("Bayesian Network", tabName = "2", icon = icon("atom")),
|
menuItem("Pressure Test", tabName = "2", icon = icon("arrow-down")),
|
||||||
|
menuItem("Bayesian Network", tabName = "3", 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",
|
|
||||||
# choices = transitions,
|
|
||||||
# selected = NULL, multiple = FALSE)
|
|
||||||
)
|
)
|
||||||
),
|
),
|
||||||
dashboardBody(
|
dashboardBody(
|
||||||
tabItems(
|
tabItems(
|
||||||
tabItem(tabName = "1", h2("Impact Distribution"),
|
tabItem(
|
||||||
|
tabName = "1", h2("Introduction"),
|
||||||
|
tags$p(
|
||||||
|
style = "font-size: 12pt",
|
||||||
|
"This website is provided for the Joint Nature Conservation Committee (JNCC) and is provided by",
|
||||||
|
tags$a(href = "https://avsdev.uk", "AVS Developments", target = "_BLANK"),
|
||||||
|
", working under contract to ",
|
||||||
|
tags$a(href = "https://www.mba.ac.uk", "the Marine Biology Association.", target = "_BLANK")
|
||||||
|
),
|
||||||
|
tags$p(
|
||||||
|
style = "font-size: 12pt",
|
||||||
|
"This website provides a Proof of Concept visualisation tool to assist in understanding the probabilitic impact that
|
||||||
|
Anthropogenic Pressures (i.e. human activities) has on the habitats of sub-littoral areas of the United Kingdom."
|
||||||
|
),
|
||||||
|
tags$p(
|
||||||
|
style = "font-size: 12pt",
|
||||||
|
"The tool provides a mapping using a Continuous Gaussian Bayesian Belief Network from the
|
||||||
|
Anthropogenic Pressures through the biotopes and to the output processes and ultimately the
|
||||||
|
Ecosystem services, to which the habitat supports."
|
||||||
|
),
|
||||||
|
tags$p(
|
||||||
|
style = "font-size: 12pt",
|
||||||
|
"By selecting combinations of pressures on the left hand side bar, the impact on biotopes and functions of the
|
||||||
|
habitat can be estimated on the graphs shown on the Pressure test page.
|
||||||
|
The Bayesian Network page shows the structure of the Bayesian Network itself. "
|
||||||
|
),
|
||||||
|
tags$p(
|
||||||
|
style = "font-size: 12pt",
|
||||||
|
"Five substrate types have been modelled (coarse sediment, mixed sediment, mud, rock and sand)."
|
||||||
|
),
|
||||||
|
tags$p(
|
||||||
|
style = "font-size: 12pt",
|
||||||
|
"Impact of pressures are as defined in ",
|
||||||
|
tags$a(href = "https://www.marlin.ac.uk/sensitivity/sensitivity_rationale",
|
||||||
|
"the Marine Evidence based Sensitivity Assessment (MarESA).", target = "_BLANK")
|
||||||
|
),
|
||||||
|
tags$p(
|
||||||
|
style = "margin-top: 150px; font-size: 12pt",
|
||||||
|
"Further information on the rationalale and supporting information can be found in the Studiy's Final Report
|
||||||
|
available as a download from the Help pages selectable from the Question Mark logo on the
|
||||||
|
top right hand side of the website."
|
||||||
|
),
|
||||||
|
tags$p(
|
||||||
|
style = "margin-top: 150px; font-size: 10pt",
|
||||||
|
"GDPR Notice: This website only uses cookies to provide core functionality. No personal data cookies are used."
|
||||||
|
),
|
||||||
|
tags$p(
|
||||||
|
style = "font-size: 10pt",
|
||||||
|
"Copyright Notice: All images, logos and sources are property and copyright of their respected owners"
|
||||||
|
)
|
||||||
|
),
|
||||||
|
tabItem(tabName = "2", h2("Impact Distribution"),
|
||||||
fluidRow(
|
fluidRow(
|
||||||
column(
|
column(
|
||||||
width = 6,
|
width = 6,
|
||||||
@@ -119,7 +159,7 @@ ui <- dashboardPage(
|
|||||||
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 = "3",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(
|
||||||
@@ -152,20 +192,7 @@ ui <- dashboardPage(
|
|||||||
)
|
)
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
),
|
)
|
||||||
#tabItem(tabName = "3",h4("Habitats"),
|
|
||||||
# fluidPage(
|
|
||||||
# google_mapOutput(outputId = "map", width = "100%", height = "750px")
|
|
||||||
# )
|
|
||||||
#),
|
|
||||||
tabItem(tabName = "3",h4("Ingestion"),
|
|
||||||
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")
|
|
||||||
)
|
|
||||||
)
|
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
@@ -175,7 +202,6 @@ server <- function(input, output, session) {
|
|||||||
|
|
||||||
print("Loading data")
|
print("Loading data")
|
||||||
|
|
||||||
#set_key("AIzaSyAw8_btgGN1drf8qhCxNcotP6r11qEXA_M")
|
|
||||||
dataStorage <- "data/"
|
dataStorage <- "data/"
|
||||||
|
|
||||||
models <- NULL
|
models <- NULL
|
||||||
@@ -187,9 +213,6 @@ server <- function(input, output, session) {
|
|||||||
)
|
)
|
||||||
|
|
||||||
.likelihoods <- reactiveValues(
|
.likelihoods <- reactiveValues(
|
||||||
p_ba = NULL,
|
|
||||||
ba_os = NULL,
|
|
||||||
os_es = NULL,
|
|
||||||
p_es = NULL
|
p_es = NULL
|
||||||
)
|
)
|
||||||
|
|
||||||
@@ -210,6 +233,7 @@ server <- function(input, output, session) {
|
|||||||
|
|
||||||
.selections <- reactiveValues(
|
.selections <- reactiveValues(
|
||||||
model = 1,
|
model = 1,
|
||||||
|
#runOnce = FALSE,
|
||||||
bbnImpact = 1,
|
bbnImpact = 1,
|
||||||
bbnNames = FALSE,
|
bbnNames = FALSE,
|
||||||
bbnEdges = FALSE,
|
bbnEdges = FALSE,
|
||||||
@@ -217,7 +241,6 @@ server <- function(input, output, session) {
|
|||||||
)
|
)
|
||||||
|
|
||||||
getImpact <- function(v) {
|
getImpact <- function(v) {
|
||||||
print(v)
|
|
||||||
if ((v == "INS") || (v == "IV")) return(.resistanceScores[1])
|
if ((v == "INS") || (v == "IV")) return(.resistanceScores[1])
|
||||||
if ((v == "HR") || (v == "III")) return(.resistanceScores[2])
|
if ((v == "HR") || (v == "III")) return(.resistanceScores[2])
|
||||||
if ((v == "MR") || (v == "II")) return(.resistanceScores[3])
|
if ((v == "MR") || (v == "II")) return(.resistanceScores[3])
|
||||||
@@ -235,12 +258,12 @@ server <- function(input, output, session) {
|
|||||||
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]))
|
wb <- parser$parseSheet(paste0(dataStorage, fileList[idx]))
|
||||||
print(tmp)
|
#print(tmp)
|
||||||
tmp$edges$values <- sapply(tmp$edges$impact, getImpact)
|
wb$p_es$edges$values <- sapply(wb$p_es$edges$impact, getImpact)
|
||||||
|
|
||||||
if (!is.null(tmp)) {
|
if (!is.null(wb)) {
|
||||||
modelList[[cnt]] <- tmp
|
modelList[[cnt]] <- wb
|
||||||
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")
|
||||||
@@ -259,20 +282,9 @@ server <- function(input, output, session) {
|
|||||||
|
|
||||||
isolate({
|
isolate({
|
||||||
|
|
||||||
#if (layer == 1) layerStr = "ba" else if (layer == 2) layerStr = "op" else if (layer == 3) layerStr = "es"
|
modelList[[.selections$model]]$p_es$edges$values <<- sapply(modelList[[.selections$model]]$p_es$edges$impact, getImpact)
|
||||||
|
modelList[[.selections$model]]$p_es$nodes$growth <<- .resistanceScores["ssgr"]
|
||||||
|
modelList[[.selections$model]]$p_es$nodes$confidence <<- .resistanceScores["pressSD"]
|
||||||
|
|
||||||
#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]]
|
thisModel <- modelList[[.selections$model]]
|
||||||
|
|
||||||
@@ -293,7 +305,7 @@ server <- function(input, output, session) {
|
|||||||
expr <- substr(expr, 1, nchar(expr)-2)
|
expr <- substr(expr, 1, nchar(expr)-2)
|
||||||
expr <- paste0(expr, ")")
|
expr <- paste0(expr, ")")
|
||||||
|
|
||||||
thisNet <- parser$buildGraph(thisModel, desc = list(inputCode = "p", outputCodes = c("ba", "op", "es")))
|
thisNet <- parser$buildGraph(thisModel$p_es, desc = list(inputCode = "p", outputCodes = c("ba", "op", "es")))
|
||||||
|
|
||||||
sampleDists <- cpdist(
|
sampleDists <- cpdist(
|
||||||
fitted = thisNet$cfit,
|
fitted = thisNet$cfit,
|
||||||
@@ -305,19 +317,19 @@ server <- function(input, output, session) {
|
|||||||
)
|
)
|
||||||
})
|
})
|
||||||
|
|
||||||
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$p_es$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$p_es$nodes$name), length(sampleDists)))
|
||||||
|
|
||||||
return(data.frame(
|
return(data.frame(
|
||||||
name = thisModel$nodes$name,
|
name = thisModel$p_es$nodes$name,
|
||||||
code = thisModel$nodes$code,
|
code = thisModel$p_es$nodes$code,
|
||||||
layer = thisModel$nodes$layer,
|
layer = thisModel$p_es$nodes$layer,
|
||||||
range = c(
|
range = c(
|
||||||
apply(sampleDists, 2, min),
|
apply(sampleDists, 2, min),
|
||||||
means - 2*stdDev,
|
means - 2*stdDev,
|
||||||
@@ -334,6 +346,7 @@ server <- function(input, output, session) {
|
|||||||
|
|
||||||
observeEvent(input$modelSelect, {
|
observeEvent(input$modelSelect, {
|
||||||
.selections$model <<- match(input$modelSelect, models)
|
.selections$model <<- match(input$modelSelect, models)
|
||||||
|
#.selections$runOnce <<- TRUE
|
||||||
})
|
})
|
||||||
|
|
||||||
observeEvent(reactiveValuesToList(input), {
|
observeEvent(reactiveValuesToList(input), {
|
||||||
@@ -348,13 +361,10 @@ server <- function(input, output, session) {
|
|||||||
|
|
||||||
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)) { #} || .selections$runOnce) {
|
||||||
|
#.selections$runOnce = FALSE
|
||||||
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)
|
.likelihoods$p_es <<- calcLikelihood(0, newStatus)
|
||||||
#write.xlsx(.likelihoods$p_es, "tmp.xlsx")
|
|
||||||
.selections$pressStatus <<- newStatus
|
.selections$pressStatus <<- newStatus
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -367,13 +377,19 @@ server <- function(input, output, session) {
|
|||||||
|
|
||||||
output$pressureList <- renderUI({
|
output$pressureList <- renderUI({
|
||||||
#isolate({
|
#isolate({
|
||||||
if (!is.null(modelList[[.selections$model]]$nodes)) {
|
if (!is.null(modelList[[.selections$model]]$p_es$nodes)) {
|
||||||
pressCodes <- which(startsWith(modelList[[.selections$model]]$nodes$code, "p"))
|
pressCodes <- which(startsWith(modelList[[.selections$model]]$p_es$nodes$code, "p"))
|
||||||
|
|
||||||
|
#if (is.null(.selections$pressStatus)) status <- rep("Off", length(pressCodes)) else status <- .selections$pressStatus$status
|
||||||
pressures <- data.frame(
|
pressures <- data.frame(
|
||||||
code = modelList[[.selections$model]]$nodes$code[pressCodes],
|
code = modelList[[.selections$model]]$p_es$nodes$code[pressCodes],
|
||||||
name = modelList[[.selections$model]]$nodes$name[pressCodes],
|
name = modelList[[.selections$model]]$p_es$nodes$name[pressCodes],
|
||||||
|
#status = status,
|
||||||
stringsAsFactors = FALSE
|
stringsAsFactors = FALSE
|
||||||
)
|
)
|
||||||
|
print(pressures)
|
||||||
|
#This assumes all pressures are the same...
|
||||||
|
|
||||||
setPressures(pressures)
|
setPressures(pressures)
|
||||||
btnList <- apply(pressures, 1, makeRadioButtons)
|
btnList <- apply(pressures, 1, makeRadioButtons)
|
||||||
}
|
}
|
||||||
@@ -382,12 +398,10 @@ server <- function(input, output, session) {
|
|||||||
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))
|
|
||||||
})
|
})
|
||||||
|
|
||||||
observeEvent(input$bbnDisplayNames, {
|
observeEvent(input$bbnDisplayNames, {
|
||||||
.selections$bbnNames <- input$bbnDisplayNames
|
.selections$bbnNames <- input$bbnDisplayNames
|
||||||
print(.selections$bbnNames)
|
|
||||||
})
|
})
|
||||||
|
|
||||||
observeEvent(input$bbnDisplayEdges, {
|
observeEvent(input$bbnDisplayEdges, {
|
||||||
@@ -430,9 +444,6 @@ server <- function(input, output, session) {
|
|||||||
.resistanceScores["pressSD"] <<- input$l1PressSD
|
.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)
|
|
||||||
.likelihoods$p_es <<- calcLikelihood(0, .selections$pressStatus)
|
.likelihoods$p_es <<- calcLikelihood(0, .selections$pressStatus)
|
||||||
removeModal()
|
removeModal()
|
||||||
|
|
||||||
@@ -440,7 +451,7 @@ server <- function(input, output, session) {
|
|||||||
|
|
||||||
|
|
||||||
output$nodeTable <- DT::renderDataTable(
|
output$nodeTable <- DT::renderDataTable(
|
||||||
modelList[[.selections$model]]$nodes,
|
modelList[[.selections$model]]$p_es$nodes,
|
||||||
selection = "single",
|
selection = "single",
|
||||||
server = TRUE,
|
server = TRUE,
|
||||||
escape = FALSE,
|
escape = FALSE,
|
||||||
@@ -449,7 +460,7 @@ server <- function(input, output, session) {
|
|||||||
)
|
)
|
||||||
|
|
||||||
output$edgeTable <- DT::renderDataTable(
|
output$edgeTable <- DT::renderDataTable(
|
||||||
modelList[[.selections$model]]$edges,
|
modelList[[.selections$model]]$p_es$edges,
|
||||||
selection = "single",
|
selection = "single",
|
||||||
server = TRUE,
|
server = TRUE,
|
||||||
escape = FALSE,
|
escape = FALSE,
|
||||||
@@ -464,19 +475,19 @@ server <- function(input, output, session) {
|
|||||||
}
|
}
|
||||||
|
|
||||||
makeBbnGraph <- function(model) {
|
makeBbnGraph <- function(model) {
|
||||||
nodes <- model$nodes
|
nodes <- model$p_es$nodes
|
||||||
|
|
||||||
if (.selections$bbnEdges) {
|
if (.selections$bbnEdges) {
|
||||||
labels <- sapply(model$edges$values, getLabel)
|
labels <- sapply(model$p_es$edges$values, getLabel)
|
||||||
} else {
|
} else {
|
||||||
labels <- rep("", nrow(model$edges))
|
labels <- rep("", nrow(model$p_es$edges))
|
||||||
}
|
}
|
||||||
|
|
||||||
edges <- data.frame(
|
edges <- data.frame(
|
||||||
id = rownames(model$edges),
|
id = rownames(model$p_es$edges),
|
||||||
from = match(model$edges$input, nodes$code),
|
from = match(model$p_es$edges$input, nodes$code),
|
||||||
to = match(model$edges$output, nodes$code),
|
to = match(model$p_es$edges$output, nodes$code),
|
||||||
values = model$edges$values,
|
values = model$p_es$edges$values,
|
||||||
label = labels,
|
label = labels,
|
||||||
arrows = "to",
|
arrows = "to",
|
||||||
stringsAsFactors = FALSE
|
stringsAsFactors = FALSE
|
||||||
@@ -489,7 +500,7 @@ server <- function(input, output, session) {
|
|||||||
|
|
||||||
nodeSpacing <- ifelse(.selections$bbnNames, 600, 150)
|
nodeSpacing <- ifelse(.selections$bbnNames, 600, 150)
|
||||||
|
|
||||||
palette <- brewer.pal(length(legends), "RdYlGn")
|
palette <- brewer.pal(nrow(model$legend), "Set3")
|
||||||
|
|
||||||
nodes <- data.frame(
|
nodes <- data.frame(
|
||||||
id = rownames(nodes),
|
id = rownames(nodes),
|
||||||
@@ -528,13 +539,16 @@ server <- function(input, output, session) {
|
|||||||
edgeNet <- edges
|
edgeNet <- edges
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
legendDF <- data.frame(
|
legendDF <- data.frame(
|
||||||
id = 1:length(legends),
|
id = 1:nrow(model$legend),
|
||||||
label = legends,
|
label = model$legend,
|
||||||
color = palette,
|
color = palette,
|
||||||
stringsAsFactors = FALSE
|
stringsAsFactors = FALSE
|
||||||
)
|
)
|
||||||
|
|
||||||
|
print(legendDF)
|
||||||
|
|
||||||
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) %>%
|
||||||
@@ -556,11 +570,13 @@ server <- function(input, output, session) {
|
|||||||
paste0("data/", input$modelSelect, ".xlsx")
|
paste0("data/", input$modelSelect, ".xlsx")
|
||||||
}
|
}
|
||||||
|
|
||||||
genPlot <- function(boxPlot, title) {
|
genPlot <- function(boxPlot, title, paletteLength) {
|
||||||
if (nrow(boxPlot) > 0) {
|
if (nrow(boxPlot) > 0) {
|
||||||
|
|
||||||
palette <- brewer.pal(length(legends), "RdYlGn")
|
print(paste('Palette length', paletteLength))
|
||||||
names(palette) <- 1:length(legends)
|
|
||||||
|
palette <- brewer.pal(paletteLength, "Set3")
|
||||||
|
names(palette) <- 1:paletteLength
|
||||||
|
|
||||||
#print(paste("Box plot, colours", nrow(boxPlot), length(colours)))
|
#print(paste("Box plot, colours", nrow(boxPlot), length(colours)))
|
||||||
#cat(colours)
|
#cat(colours)
|
||||||
@@ -580,7 +596,9 @@ server <- function(input, output, session) {
|
|||||||
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)
|
paletteLength <- nrow(modelList[[.selections$model]]$legend)
|
||||||
|
print(paste('prep plot palette', paletteLength))
|
||||||
|
genPlot(thisPlot, title, paletteLength)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|||||||
Binary file not shown.
Binary file not shown.
BIN
data/Sub_littoral_mud_BA_release.xlsx
Normal file
BIN
data/Sub_littoral_mud_BA_release.xlsx
Normal file
Binary file not shown.
BIN
data/Sub_littoral_rock_BA_release.xlsx
Normal file
BIN
data/Sub_littoral_rock_BA_release.xlsx
Normal file
Binary file not shown.
BIN
data/Sub_littoral_sand_BA_release.xlsx
Normal file
BIN
data/Sub_littoral_sand_BA_release.xlsx
Normal file
Binary file not shown.
BIN
www/Report.pdf
BIN
www/Report.pdf
Binary file not shown.
Reference in New Issue
Block a user