Inclusion of visNetwork as bbn drawing package

app.R

@@ -14,57 +14,113 @@ modules::import(knitr)
 modules::import(shinycssloaders)
 modules::import(googleway)
 modules::import(bnlearn)
+modules::import(visNetwork)
 
 parser <- modules::use('Parses.R')
 
 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')
+thresholds <- c(0.97, 0.9, 0.7, 0.17, 0)
+impLabels <- c('Very High', 'High', 'Medium', 'Low', 'Very Low')
+
 addResourcePath("js", "./www/js")
 
-
-    
-
 ui<-dashboardPage(
-      dashboardHeader(title = "JNCC MESO online"),
+      dashboardHeader(title = "JNCC MESO online", 
-      
-      #tags$style(.times-circle {color:800000 }),
-      #tags$style(.check-square {color:008000 }),
         
+        tags$li(
+          id = "dropdownHelp",
+          class = "dropdown",
+          tags$head(
+            tags$script(
+              paste0(
+                "$(document).ready(function(){",
+                "  $('#dropdownHelp')",
+                "  .find('ul')",
+                "  .click(function(e) { e.stopPropagation(); });",
+                "});"
+              )
+            )
+          ),
+          tags$a(
+            href = "javascript:void(0);",
+            class = "dropdown-toggle",
+            `data-toggle` = "dropdown",
+            icon("question")
+          ),
+          tags$ul(
+            class = "dropdown-menu",
+            style = "left: auto; right: 0; min-width: 200px",
+            tags$li(
+              tags$div(
+                style = "margin-left: auto; margin-right: auto; width: 90%;",
+                tags$a(
+                  href = "Manual.pdf",
+                  target = "_BLANK",
+                  "Open user guide in a new tab"
+                )
+              )
+            ),
+            tags$li(
+              tags$div(
+                style = "margin-left: auto; margin-right: auto; width: 90%;",
+                downloadLink(
+                  "linkBackgroundData",
+                  "Download excel sheets"
+                )
+              )
+            )
+          )
+        )
+      ),
       dashboardSidebar(
         sidebarMenu(id = "tabs",
             menuItem("Pressure Test", tabName = "1", icon = icon("arrow-down")),
             menuItem("Bayesian Network", tabName = "2", icon = icon("atom")),
-            menuItem("Habitats", tabName = "3", icon = icon("atlas")),
+            #menuItem("Habitats", tabName = "3", icon = icon("atlas")),
-            menuItem("Ingestion", tabName = "4", icon = icon("utensils")),
+            #menuItem("Ingestion", tabName = "3", icon = icon("utensils")),
             selectInput("modelSelect", "Select MESO model", choices=c(""), selected=NULL, multiple=FALSE),
-            selectInput("layerSelect", "Select Transition", 
+            uiOutput("pressureList")
-                        choices=transitions, 
+            #selectInput("layerSelect", "Select Transition", 
-                        selected=NULL, multiple=FALSE)
+            #            choices=transitions, 
+            #            selected=NULL, multiple=FALSE)
         )
       ),
       dashboardBody(
         tabItems(
-          tabItem(tabName = "1",
+          tabItem(tabName = "1", h2('Impact Distribution'),
             fluidRow(
-              column(width=2,
+              column(
-                h4('Pressure Test'),
+                width=6, 
-                actionButton("calcAB", "Calc"),
+                h4('Effect on bio-assemblage')
-                uiOutput("pressureList")
+              ),
+              column(
+                width=6,
+                actionButton("layer1Slider", "1", icon=icon("sliders-h"))
+              )
             ),
-              column(width=10, 
-                h4('Effect on bio-assemblage'),
             plotlyOutput("layer1", height="270px") %>% withSpinner(),
             h4('Effect on Output Processes'),
             plotlyOutput("layer2", height="270px") %>% withSpinner(),
             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: large networks may never stabilise!'),
+              fluidRow(
+                column(
+                  width=4,
+                  checkboxInput("bbnDisplayNames", "Display Node names", value=FALSE)
+                ),
+                column(
+                  width=4,
+                  selectInput("bbnImpactSelect", "Impact Threshold", choices=impacts, selected='All')
                 )
               ),
-          tabItem(tabName = "2",h4("Bayesian Network"),
-            fluidPage(
               fluidRow(
-                plotOutput("bbnGraphPlot")
+                visNetworkOutput("bbnGraphPlot")
               ),
               fluidRow(
                 column(
@@ -80,12 +136,12 @@ ui<-dashboardPage(
               )
             )
           ),
-          tabItem(tabName = "3",h4("Habitats"),
+          #tabItem(tabName = "3",h4("Habitats"),
-              fluidPage(
+          #    fluidPage(
-                google_mapOutput(outputId = "map", width = "100%", height = "750px")
+          #      google_mapOutput(outputId = "map", width = "100%", height = "750px")
-              )
+          #    )
-          ), 
+          #), 
-          tabItem(tabName = "4",h4("Ingestion"),
+          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"),
@@ -102,12 +158,13 @@ server <- function(input, output, session) {
  
   print('Loading data')
   
-  set_key("AIzaSyAw8_btgGN1drf8qhCxNcotP6r11qEXA_M")
+  #set_key("AIzaSyAw8_btgGN1drf8qhCxNcotP6r11qEXA_M")
   dataStorage <- 'data/'
   
   models<-NULL
   pressures <- NULL
   
+  
   #disable(input$loadAb)
   
   .loadStatus <- reactiveValues(
@@ -140,11 +197,11 @@ 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]))
 
       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]))
         cnt=cnt+1
@@ -158,37 +215,24 @@ server <- function(input, output, session) {
   }
   
   
-  .selections <- reactiveValues(model=1, layer=1)
+  .selections <- reactiveValues(
+    model=1, 
+    layer=1, 
+    bbnImpact=1, 
+    bbnNames=FALSE,
+    pressStatus=NULL
+  )
   
   #parse on load sheets in the input sheet folder - replace with R Data
   modelList <- getAvailableModels()
   
-  calcLikelihood <- function(layer, pressStatus) {
+  calcLikelihood <- function(layer, pressStatus, confLevels) {
     
-    # isolate({
-    #   if (layer==1) layerStr='ba' else if (layer==2) layerStr='op' else layerStr ='es'
-    #   nodeList <- modelList[[.selections$model]][[.selections$layer]]$nodes
-    #   str(nodeList)
-    #   nodeNames <- nodeList$name[startsWith(nodeList$code, layerStr)]
-    #   mean = runif(length(nodeNames), min=-1, max=1)
-    #   sd = runif(length(nodeNames), min=-0.25, max=0.25)
-    # 
-    #   df <- data.frame(
-    #     nodeNames = nodeNames,
-    #     range = c((mean - (3*sd)), (mean - (2*sd)), (mean - sd), mean,
-    #               (mean + sd), (mean + (2*sd)), (mean + (3*sd))),
-    #     stringsAsFactors=FALSE
-    #   )
-    #   print(df)
-    # })
-    # return(
-    #   df
-    # )
     isolate({
 
       if (layer==1) layerStr='ba' else if (layer==2) layerStr='op' else if (layer==3) layerStr='es'
 
-      layerRange <- which(startsWith(modelList[[.selections$model]][[layer]]$nodes$code, layerStr))
+      layerRange <- which(startsWith(modelList[[.selections$model]][[3]]$nodes$code, layerStr))
    
       nodeCodes <- modelList[[.selections$model]][[layer]]$nodes$code[layerRange]
       nodeNames <- modelList[[.selections$model]][[layer]]$nodes$name[layerRange]
@@ -196,21 +240,6 @@ server <- function(input, output, session) {
       MEANPOS=1
       MEANNEG=0
       
-      # expr <- "("
-      # for (p in 1:nrow(pressStatus)) {
-      #   if (pressStatus$status[p] == 'On') {
-      #     threshold = MEANPOS
-      #   } else {
-      #     threshold = MEANNEG
-      #   }
-      #   
-      #   expr <- paste0(expr, "(\"", pressStatus$code[p], "\">=", threshold, ") & ")
-      # }
-      # expr <-substr(expr, 1, nchar(expr)-2)
-      # expr<-paste0(expr, ')')
-      # 
-      # print(expr)
-      
       expr <- "list("
       for (p in 1:nrow(pressStatus)) {
         if (pressStatus$status[p] == 'On') {
@@ -224,11 +253,9 @@ server <- function(input, output, session) {
       expr <-substr(expr, 1, nchar(expr)-2)
       expr<-paste0(expr, ')')
       
-      print(expr)
       
-      #txtStringWkg = "((\"p1\">=0.5) & (\"p10\">=0.5) & (\"p2\">=0.5))"  
+      #build the graph
-      
+      #parser$buildGraph(p_es, desc=list(inputCode='p', outputCodes=c('ba', 'op', 'es')))
-      print(bnlearn::nodes(modelList[[.selections$model]][[layer]]$cfit))
 
       sampleDists <- cpdist(
         fitted = modelList[[.selections$model]][[layer]]$cfit,
@@ -240,20 +267,11 @@ server <- function(input, output, session) {
       )
     })
     
-    #print (sum(res[, 1] * attr(res, "weights")) / sum(attr(res, "weights")))
-    
-    print("Sample dists")
-    print(sampleDists)
-    
-    print("Weights")
-    print(unique(attr(sampleDists, "weights")))
     displayCols <- match(nodeCodes, colnames(sampleDists))
     sampleDists <- sampleDists[,displayCols]
     means <- apply(sampleDists, 2, mean)
     stdDev <- apply(sampleDists, 2, sd)
     
-    print(modelList[[.selections$model]][[layer]]$nodes$name)
-      
     return(data.frame(
            nodeNames = nodeNames,
            range = c(
@@ -289,53 +307,63 @@ server <- function(input, output, session) {
        column(width=3, icon(renderStatus(2))),
        column(width=3, icon(renderStatus(3))),
        column(width=3, icon(renderStatus(4)))
-      )#,
+      )
-      #fluidRow(
-      #  verbatimTextOutput("msgBoard", .loadStatus$msg, placeholder=TRUE)
-      #)
     )
   })
   
     
-  observeEvent(input$loadAB, {
-    #TO DO get spreadsheet
-    #copy validated sheet into the data folder and either add or replace the sheet in the RData file
-    #reload the RData file
-    print('Load button pressed')
-  })             
- 
   observeEvent(input$modelSelect, {
     .selections$model <<- match(input$modelSelect, models)
   })
   
-  observeEvent(input$layerSelect, {
+  #observeEvent(input$layerSelect, {
-    .selections$layer <<- match(input$layerSelect, transitions)
+  #  .selections$layer <<- match(input$layerSelect, transitions)
-  })
+  #})
   
-  
+  observeEvent(reactiveValuesToList(input), {
-  observeEvent(input$calcAB, {
-    #get the status of action buttons
     isolate(myList <- reactiveValuesToList(input))
     matches <- match(pressures$code,  names(myList))
+
+    if (length(matches)>0) {
       status <-NULL
       for (n in 1:length(matches))  status[n] = myList[[matches[n]]]
       
-    pressStatus <- data.frame(code=pressures$code, status=status, stringsAsFactors = FALSE)
+      newStatus <- data.frame(code=pressures$code, status=status, stringsAsFactors = FALSE)
       
-    .likelihoods$p_ba <<- calcLikelihood(1,  pressStatus)
+      if (!identical(newStatus, .selections$pressStatus)) {
-    .likelihoods$ba_os <<- calcLikelihood(2,  pressStatus)
+        print('Running calc')
-    .likelihoods$os_es <<- calcLikelihood(3, pressStatus)
+        .likelihoods$p_ba <<- calcLikelihood(1,  newStatus)
+        .likelihoods$ba_os <<- calcLikelihood(2,  newStatus)
+        .likelihoods$os_es <<- calcLikelihood(3, newStatus)
         
+        .selections$pressStatus <<- newStatus
+      }
+      
+    }
+    sliderControls <- c("l1VH", "l1H", "l1M", "l1L", "l1VL", "l1Conf")
+    matches <- match(sliderControls,  names(myList))
+    if (length(matches)>0) {
+      print(matches)
+    }
   })
   
-  output$map <- renderGoogle_map({
+  #output$map <- renderGoogle_map({
-    google_map(location = c(55, 0), zoom = 7)
+  #  google_map(location = c(55, 0), zoom = 7)
-  })
+  #})
   
   makeRadioButtons <- function(row) {
     radioButtons(row['code'], row['name'], choices=c('Off', 'On'), selected='Off', inline=TRUE)
   }
   
+  output$linkBackgroundData <- downloadHandler(
+    filename = "JNCC MESO.xlsx",
+    content = function(file) {
+      file.copy("JNCC MESO.xlsx", file)
+    },
+    contentType = "application/xlsx"
+  )
+  
+  
   output$pressureList <- renderUI({
     #isolate({
     if (!is.null(modelList[[.selections$model]][[1]]$nodes)) {
@@ -347,6 +375,36 @@ 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$layer1Slider, {
+    showModal(
+      modalDialog({
+        tagList(
+          sliderInput("l1VH", "Very High Sensitivity", 0.9, 1.0, 0.99, step=0.01),
+          sliderInput("l1H", "High Sensitivity", 0.75, 1.0, 0.95, step=0.01),
+          sliderInput("l1M", "Medium Sensitivity", 0.5, 0.75, 0.95, step=0.01),
+          sliderInput("l1L", "Low Sensitivity", 0.15, 0.5, 0.2, step=0.01),
+          sliderInput("l1VL", "Very Low Sensitivity", 0.01, 0.2, 0.15, step=0.01),
+          sliderInput("pressStdDev", "Pressure SD", 0.1, 1, 0.5, step=0.1),
+          sliderInput("baStdDev", "Bio-Assemblage SD", 0.1, 1, 0.5, step=0.1)
+        )
+      }, title='Layer 1 controls', size='s')
+    )
+  })
+  
+  
+  
+
   
   output$nodeTable <- DT::renderDataTable(
     
@@ -360,31 +418,133 @@ server <- function(input, output, session) {
       selection = 'single',options = list(searching = TRUE, pageLength = 10, editable=TRUE),server = TRUE, escape = FALSE,rownames= TRUE
   )
   
-  output$bbnGraphPlot <- renderPlot({
+  getLabel <- function(impact) {
-    graphviz.plot(modelList[[.selections$model]][[.selections$layer]]$net)
+    sign <- ifelse(impact<0, "-", "+")
+    idx <- min(which((abs(impact)>=thresholds)==TRUE))
+    return(paste0(sign, impLabels[idx]))
+  }
+  
+  getLevels <- function(code) {
+    if (startsWith(code, 'p')) return(1)
+    else if (startsWith(code, 'ba')) return(2)
+    else if (startsWith(code, 'op')) return(3)
+    else if (startsWith(code, 'es')) return(4)
+    else return(5)
+  }
+  
+  
+  output$bbnGraphPlot <- renderVisNetwork({
+    #graphviz.plot(modelList[[.selections$model]][[.selections$layer]]$net)
+
+    nodes <- modelList[[.selections$model]][[.selections$layer]]$nodes
+
+    edges <- data.frame(
+      id = rownames(modelList[[.selections$model]][[.selections$layer]]$edges),
+      from=match(modelList[[.selections$model]][[.selections$layer]]$edges$input, nodes$name),
+      to=match(modelList[[.selections$model]][[.selections$layer]]$edges$output, nodes$name),
+      impact=modelList[[.selections$model]][[.selections$layer]]$edges$impact,
+      label=sapply(modelList[[.selections$model]][[.selections$layer]]$edges$impact, getLabel),
+      arrows="to",
+      stringsAsFactors=FALSE
+    ) 
+    if (.selections$bbnNames) {labels <- nodes$name} else {labels <- nodes$code}
+
+    nodeSpacing <- ifelse(.selections$bbnNames, 600, 150)
+    
+    nodes <- data.frame(
+      id = rownames(nodes),
+      label = labels,
+      level = sapply(nodes$code, getLevels),
+      code = nodes$code,
+      stringsAsFactors=FALSE
+    ) 
+    
+    
+    
+    edges <- edges[(abs(edges$impact)>=.selections$bbnImpact),]
+    
+    nodeNet <- nodes[(nodes$code %in% .selections$pressStatus$code[.selections$pressStatus$status %in% c('On')]),]
+    
+    save(nodes, edges, nodeNet, file = 'tmp.RData')
+    
+    
+    if (nrow(nodeNet)>0) {
+
+      #do pressures 
+      edgeNet <- edges[edges$from %in% nodeNet$id, ]
+      idx = 1
+      repeat {
+        nodesToAdd <- nodes[nodes$id %in% edgeNet$to, ]
+        nodesToAdd <- nodesToAdd[!(nodesToAdd$id %in% nodeNet$id),]
+        
+        edgesToAdd <- edges[edges$from %in% nodesToAdd$id, ]
+        edgesToAdd <- edgesToAdd[!(edgesToAdd$id %in% edgeNet$id),]
+        
+        idx <- idx + 1
+        if ((idx>20) || ((nrow(nodesToAdd)==0) && (nrow(edgesToAdd)==0))) break
+        nodeNet <- rbind(nodeNet, nodesToAdd)
+        edgeNet <- rbind(edgeNet, edgesToAdd)
+
+      } #until finished
+    } else edgeNet <- edges
+    
+    visNetwork(nodeNet, edgeNet, width = "100%") %>% 
+      visHierarchicalLayout(nodeSpacing=nodeSpacing) %>%
+      visOptions(highlightNearest = TRUE) %>%
+      #visPhysics(hierarchicalRepulsion = nodeSpacing) %>%
+      visInteraction(navigationButtons = TRUE, dragNodes = TRUE, dragView = TRUE, zoomView = TRUE)
   })
   
+  observe({
+    visNetworkProxy("bbnGraphPlot") %>%
+      visStabilize(iterations=10)
+  })
+  
+  
   output$layer1 <- renderPlotly({
     if (length(.likelihoods$p_ba)>0) {
+      
+      .likelihoods$p_ba$nodeNames <- factor(.likelihoods$p_ba$nodeNames, levels = unique(.likelihoods$p_ba$nodeNames))
+      
+      xform <- list(categoryorder = "array",
+                    categoryarray = .likelihoods$p_ba$nodeNames,
+                    zerolinewidth=10)
+      
       plot_ly(.likelihoods$p_ba, y = ~range, color = ~nodeNames, type = "box") %>%
-        layout(xaxis = list(zerolinewidth=2)) 
+        layout(xaxis = xform)
     
     } 
   })
 
   output$layer2 <- renderPlotly({
-    if (.selections$layer>1) {
+    if (length(.likelihoods$ba_os)>0) {
+      
+      .likelihoods$ba_os$nodeNames <- factor(.likelihoods$ba_os$nodeNames, levels = unique(.likelihoods$ba_os$nodeNames))
+      
+      xform <- list(categoryorder = "array",
+                    categoryarray = .likelihoods$ba_os$nodeNames,
+                    zerolinewidth=5)
+      
+      
       plot_ly(.likelihoods$ba_os, y = ~range, color = ~nodeNames, type = "box") %>%
-        layout(xaxis = list(zerolinewidth=2))
+        layout(xaxis = xform)
      
     }
   })
 
   output$layer3 <- renderPlotly({
     
-    if (.selections$layer>2) {
+    if (length(.likelihoods$os_es)>0) {
+      
+      .likelihoods$os_es$nodeNames <- factor(.likelihoods$os_es$nodeNames, levels = unique(.likelihoods$os_es$nodeNames))
+      
+      xform <- list(categoryorder = "array",
+                    categoryarray = .likelihoods$os_es$nodeNames,
+                    zerolinewidth=5)
+      
+      
       plot_ly(.likelihoods$os_es, y = ~range, color = ~nodeNames, type = "box") %>%
-        layout(xaxis = list(zerolinewidth=2)) 
+        layout(xaxis = xform) 
    
     }
   })