Commit before first release

.hgignore

@@ -5,3 +5,5 @@ archive
 data/tmp/
 data/new/
 node_modules/
+app.R.orig
+tmp/

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 {

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)
     }
   }