diff --git a/.hgignore b/.hgignore index 2045612..eba041f 100644 --- a/.hgignore +++ b/.hgignore @@ -5,3 +5,5 @@ archive data/tmp/ data/new/ node_modules/ +app.R.orig +tmp/ diff --git a/Parses.R b/Parses.R index d12c844..af95a5b 100644 --- a/Parses.R +++ b/Parses.R @@ -8,7 +8,7 @@ modules::import(stats) #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") +mappings <- c("TestScenario", "Map_P_BA", "Map_BA_OP", "Map_OP_ES", "Legend") nodeTypes <- c("Input.Nodes", "Internal.Nodes", "Published.Nodes") states <- c("impact", "confidence", "growth", "recovery", "layer") refs <- c(1:length(mappings)) @@ -151,9 +151,9 @@ buildGraph <- function(model, desc) { } 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") @@ -169,7 +169,7 @@ buildGraph <- function(model, desc) { cfit <- custom.fit(net, allDists) cat("about to calculate sample distributions") - print(outNodes) + #print(outNodes) sampleDists <- cpdist(cfit, nodes = outNodes, evidence = TRUE, n = 10000, method = "lw") 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)] } - print(coefs) + #print(coefs) return(data.frame( 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) { - utils::str(nodeDF) + #utils::str(nodeDF) edgeCols <- c("inputNode", "outputNode", "impact") edgeM <- matrix(data = NA, nrow = 0, ncol = length(edgeCols), dimnames = list(NULL, edgeCols)) @@ -338,7 +338,8 @@ parseSheet <- function(fName) { 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") - + legend <- readXL(fName,mappings[5], startRow = 1) + #print("building graphs") #p_baNet <- buildGraph(p_ba, desc = list(inputCode = "p", outputCodes = "ba")) @@ -347,12 +348,10 @@ parseSheet <- function(fName) { print("sheet load completed") return( - #list( - #pressBioAss = p_baNet, - #pressOpProc = p_opNet, - #pressEcoServ = p_esNet, - p_esMap = p_es - #) + list( + p_esMap = p_es, + legend = legend + ) ) } else { diff --git a/app.R b/app.R index b99b919..bd2c904 100644 --- a/app.R +++ b/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) impLabels <- c("Very High", "High", "Medium", "Low", "Very Low") -legends <- c("Pressures", - "Suspension feeders", - "Mobile and burrow dwellers", - "Predators", - "Epifauna and algae", - "Functional groups", - "Output processes", - "Output enablers", - "Ecosystem services") ui <- dashboardPage( dashboardHeader(title = "JNCC MESO online", @@ -84,21 +75,70 @@ ui <- dashboardPage( ), dashboardSidebar( sidebarMenu(id = "tabs", - menuItem("Pressure Test", tabName = "1", icon = icon("arrow-down")), - menuItem("Bayesian Network", tabName = "2", icon = icon("atom")), + menuItem("Introduction", tabName = "1", icon = icon("arrow-down")), + 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("Ingestion", tabName = "3", icon = icon("utensils")), selectInput("modelSelect", "Select MESO model", choices = c(""), selected = NULL, multiple = FALSE), downloadButton("download", "", icon = icon("download")), uiOutput("pressureList") - #selectInput("layerSelect", "Select Transition", - # choices = transitions, - # selected = NULL, multiple = FALSE) ) ), dashboardBody( 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( column( width = 6, @@ -119,7 +159,7 @@ ui <- dashboardPage( h4("Effect on Ecosystem services"), plotlyOutput("layer3", height = "270px") %>% withSpinner() ), - tabItem(tabName = "2",h2("Bayesian Network"), + tabItem(tabName = "3",h2("Bayesian Network"), fluidPage( p("Graphical output of the Bayesian Network. Note: The graph will only draw if pressures are applied!"), 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") - #set_key("AIzaSyAw8_btgGN1drf8qhCxNcotP6r11qEXA_M") dataStorage <- "data/" models <- NULL @@ -187,9 +213,6 @@ server <- function(input, output, session) { ) .likelihoods <- reactiveValues( - p_ba = NULL, - ba_os = NULL, - os_es = NULL, p_es = NULL ) @@ -210,6 +233,7 @@ server <- function(input, output, session) { .selections <- reactiveValues( model = 1, + #runOnce = FALSE, bbnImpact = 1, bbnNames = FALSE, bbnEdges = FALSE, @@ -217,7 +241,6 @@ server <- function(input, output, session) { ) getImpact <- function(v) { - print(v) if ((v == "INS") || (v == "IV")) return(.resistanceScores[1]) if ((v == "HR") || (v == "III")) return(.resistanceScores[2]) if ((v == "MR") || (v == "II")) return(.resistanceScores[3]) @@ -235,12 +258,12 @@ server <- function(input, output, session) { for (idx in 1:length(fileList)) { print(paste("attempting to load", paste0(dataStorage, fileList[idx]))) - tmp <- parser$parseSheet(paste0(dataStorage, fileList[idx])) - print(tmp) - tmp$edges$values <- sapply(tmp$edges$impact, getImpact) + wb <- parser$parseSheet(paste0(dataStorage, fileList[idx])) + #print(tmp) + wb$p_es$edges$values <- sapply(wb$p_es$edges$impact, getImpact) - if (!is.null(tmp)) { - modelList[[cnt]] <- tmp + if (!is.null(wb)) { + modelList[[cnt]] <- wb models <<- c(models, substr(fileList[idx], 1, (nchar(fileList[idx])-5))) print(paste("Model file successfully loaded", fileList[idx])) #save(tmp, file = "tmp.RData") @@ -259,20 +282,9 @@ server <- function(input, output, session) { isolate({ - #if (layer == 1) layerStr = "ba" else if (layer == 2) layerStr = "op" else if (layer == 3) layerStr = "es" - - - - #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"] + 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"] thisModel <- modelList[[.selections$model]] @@ -293,7 +305,7 @@ server <- function(input, output, session) { expr <- substr(expr, 1, nchar(expr)-2) 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( fitted = thisNet$cfit, @@ -305,19 +317,19 @@ server <- function(input, output, session) { ) }) - print(sampleDists) + #print(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) 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( - name = thisModel$nodes$name, - code = thisModel$nodes$code, - layer = thisModel$nodes$layer, + name = thisModel$p_es$nodes$name, + code = thisModel$p_es$nodes$code, + layer = thisModel$p_es$nodes$layer, range = c( apply(sampleDists, 2, min), means - 2*stdDev, @@ -334,6 +346,7 @@ server <- function(input, output, session) { observeEvent(input$modelSelect, { .selections$model <<- match(input$modelSelect, models) + #.selections$runOnce <<- TRUE }) observeEvent(reactiveValuesToList(input), { @@ -348,13 +361,10 @@ server <- function(input, output, session) { 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") - #.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") .selections$pressStatus <<- newStatus } @@ -367,13 +377,19 @@ server <- function(input, output, session) { output$pressureList <- renderUI({ #isolate({ - if (!is.null(modelList[[.selections$model]]$nodes)) { - pressCodes <- which(startsWith(modelList[[.selections$model]]$nodes$code, "p")) + if (!is.null(modelList[[.selections$model]]$p_es$nodes)) { + 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( - code = modelList[[.selections$model]]$nodes$code[pressCodes], - name = modelList[[.selections$model]]$nodes$name[pressCodes], + code = modelList[[.selections$model]]$p_es$nodes$code[pressCodes], + name = modelList[[.selections$model]]$p_es$nodes$name[pressCodes], + #status = status, stringsAsFactors = FALSE ) + print(pressures) + #This assumes all pressures are the same... + setPressures(pressures) btnList <- apply(pressures, 1, makeRadioButtons) } @@ -382,12 +398,10 @@ server <- function(input, output, session) { observeEvent(input$bbnImpactSelect, { #filter nodes and edges to .selections$bbnImpact <- thresholds[match(input$bbnImpactSelect, impacts)] - print(paste("Setting bbn impact", .selections$bbnImpact)) }) observeEvent(input$bbnDisplayNames, { .selections$bbnNames <- input$bbnDisplayNames - print(.selections$bbnNames) }) observeEvent(input$bbnDisplayEdges, { @@ -430,9 +444,6 @@ server <- function(input, output, session) { .resistanceScores["pressSD"] <<- input$l1PressSD print("Running calc") - #.likelihoods$p_ba <<- calcLikelihood(1, .selections$pressStatus) - #.likelihoods$ba_os <<- calcLikelihood(2, .selections$pressStatus) - #.likelihoods$os_es <<- calcLikelihood(3, .selections$pressStatus) .likelihoods$p_es <<- calcLikelihood(0, .selections$pressStatus) removeModal() @@ -440,7 +451,7 @@ server <- function(input, output, session) { output$nodeTable <- DT::renderDataTable( - modelList[[.selections$model]]$nodes, + modelList[[.selections$model]]$p_es$nodes, selection = "single", server = TRUE, escape = FALSE, @@ -449,7 +460,7 @@ server <- function(input, output, session) { ) output$edgeTable <- DT::renderDataTable( - modelList[[.selections$model]]$edges, + modelList[[.selections$model]]$p_es$edges, selection = "single", server = TRUE, escape = FALSE, @@ -464,19 +475,19 @@ server <- function(input, output, session) { } makeBbnGraph <- function(model) { - nodes <- model$nodes + nodes <- model$p_es$nodes if (.selections$bbnEdges) { - labels <- sapply(model$edges$values, getLabel) + labels <- sapply(model$p_es$edges$values, getLabel) } else { - labels <- rep("", nrow(model$edges)) + labels <- rep("", nrow(model$p_es$edges)) } edges <- data.frame( - id = rownames(model$edges), - from = match(model$edges$input, nodes$code), - to = match(model$edges$output, nodes$code), - values = model$edges$values, + id = rownames(model$p_es$edges), + from = match(model$p_es$edges$input, nodes$code), + to = match(model$p_es$edges$output, nodes$code), + values = model$p_es$edges$values, label = labels, arrows = "to", stringsAsFactors = FALSE @@ -489,7 +500,7 @@ server <- function(input, output, session) { nodeSpacing <- ifelse(.selections$bbnNames, 600, 150) - palette <- brewer.pal(length(legends), "RdYlGn") + palette <- brewer.pal(nrow(model$legend), "Set3") nodes <- data.frame( id = rownames(nodes), @@ -527,13 +538,16 @@ server <- function(input, output, session) { } else { edgeNet <- edges } + legendDF <- data.frame( - id = 1:length(legends), - label = legends, + id = 1:nrow(model$legend), + label = model$legend, color = palette, stringsAsFactors = FALSE ) + + print(legendDF) visNetwork(nodeNet, edgeNet, width = "100%", main = "Bayesian Belief Network", submain = input$modelSelect) %>% visExport() %>% @@ -556,11 +570,13 @@ server <- function(input, output, session) { paste0("data/", input$modelSelect, ".xlsx") } - genPlot <- function(boxPlot, title) { + genPlot <- function(boxPlot, title, paletteLength) { if (nrow(boxPlot) > 0) { + + print(paste('Palette length', paletteLength)) - palette <- brewer.pal(length(legends), "RdYlGn") - names(palette) <- 1:length(legends) + palette <- brewer.pal(paletteLength, "Set3") + names(palette) <- 1:paletteLength #print(paste("Box plot, colours", nrow(boxPlot), length(colours))) #cat(colours) @@ -580,7 +596,9 @@ server <- function(input, output, session) { thisPlot <- .likelihoods$p_es[inScope, c(1,3,4)] colnames(thisPlot) <- c(name, "Group", "Range") title <- paste(input$modelSelect, name, "Box Plot") - genPlot(thisPlot, title) + paletteLength <- nrow(modelList[[.selections$model]]$legend) + print(paste('prep plot palette', paletteLength)) + genPlot(thisPlot, title, paletteLength) } } diff --git a/data/Sub_littoral_coarse_BA_release.xlsx b/data/Sub_littoral_coarse_BA_release.xlsx index 65f5fe9..3308218 100644 Binary files a/data/Sub_littoral_coarse_BA_release.xlsx and b/data/Sub_littoral_coarse_BA_release.xlsx differ diff --git a/data/Sub_littoral_mixed_BA_release.xlsx b/data/Sub_littoral_mixed_BA_release.xlsx index fca91ec..7c39cd5 100644 Binary files a/data/Sub_littoral_mixed_BA_release.xlsx and b/data/Sub_littoral_mixed_BA_release.xlsx differ diff --git a/data/Sub_littoral_mud_BA_release.xlsx b/data/Sub_littoral_mud_BA_release.xlsx new file mode 100644 index 0000000..156e550 Binary files /dev/null and b/data/Sub_littoral_mud_BA_release.xlsx differ diff --git a/data/Sub_littoral_rock_BA_release.xlsx b/data/Sub_littoral_rock_BA_release.xlsx new file mode 100644 index 0000000..01d9c91 Binary files /dev/null and b/data/Sub_littoral_rock_BA_release.xlsx differ diff --git a/data/Sub_littoral_sand_BA_release.xlsx b/data/Sub_littoral_sand_BA_release.xlsx new file mode 100644 index 0000000..37f411f Binary files /dev/null and b/data/Sub_littoral_sand_BA_release.xlsx differ diff --git a/www/Report.pdf b/www/Report.pdf index 2be0e4b..fcbb7fe 100644 Binary files a/www/Report.pdf and b/www/Report.pdf differ