diff --git a/app.R b/app.R index 95a9a5c..64830db 100644 --- a/app.R +++ b/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"), - - #tags$style(.times-circle {color:800000 }), - #tags$style(.check-square {color:008000 }), - + dashboardHeader(title = "JNCC MESO online", + + 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("Ingestion", tabName = "4", icon = icon("utensils")), + #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), - selectInput("layerSelect", "Select Transition", - choices=transitions, - selected=NULL, multiple=FALSE) + uiOutput("pressureList") + #selectInput("layerSelect", "Select Transition", + # choices=transitions, + # selected=NULL, multiple=FALSE) ) ), dashboardBody( tabItems( - tabItem(tabName = "1", - fluidRow( - column(width=2, - h4('Pressure Test'), - actionButton("calcAB", "Calc"), - uiOutput("pressureList") + tabItem(tabName = "1", h2('Impact Distribution'), + fluidRow( + column( + width=6, + h4('Effect on bio-assemblage') ), - 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() + column( + width=6, + actionButton("layer1Slider", "1", icon=icon("sliders-h")) ) - ) + ), + 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",h4("Bayesian Network"), + tabItem(tabName = "2",h2("Bayesian Network"), fluidPage( + p('Graphical output of the Bayesian Network. Note: large networks may never stabilise!'), fluidRow( - plotOutput("bbnGraphPlot") + column( + width=4, + checkboxInput("bbnDisplayNames", "Display Node names", value=FALSE) + ), + column( + width=4, + selectInput("bbnImpactSelect", "Impact Threshold", choices=impacts, selected='All') + ) + ), + fluidRow( + visNetworkOutput("bbnGraphPlot") ), fluidRow( column( @@ -80,12 +136,12 @@ ui<-dashboardPage( ) ) ), - tabItem(tabName = "3",h4("Habitats"), - fluidPage( - google_mapOutput(outputId = "map", width = "100%", height = "750px") - ) - ), - tabItem(tabName = "4",h4("Ingestion"), + #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"), @@ -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))" - - print(bnlearn::nodes(modelList[[.selections$model]][[layer]]$cfit)) + #build the graph + #parser$buildGraph(p_es, desc=list(inputCode='p', outputCodes=c('ba', 'op', 'es'))) sampleDists <- cpdist( fitted = modelList[[.selections$model]][[layer]]$cfit, @@ -240,21 +267,12 @@ 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( + return(data.frame( nodeNames = nodeNames, range = c( apply(sampleDists, 2, min), @@ -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, { - .selections$layer <<- match(input$layerSelect, transitions) - }) + #observeEvent(input$layerSelect, { + # .selections$layer <<- match(input$layerSelect, transitions) + #}) - - observeEvent(input$calcAB, { - #get the status of action buttons + observeEvent(reactiveValuesToList(input), { isolate(myList <- reactiveValuesToList(input)) matches <- match(pressures$code, names(myList)) - status <-NULL - for (n in 1:length(matches)) status[n] = myList[[matches[n]]] - - pressStatus <- data.frame(code=pressures$code, status=status, stringsAsFactors = FALSE) - - .likelihoods$p_ba <<- calcLikelihood(1, pressStatus) - .likelihoods$ba_os <<- calcLikelihood(2, pressStatus) - .likelihoods$os_es <<- calcLikelihood(3, pressStatus) + if (length(matches)>0) { + status <-NULL + 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') + .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({ - google_map(location = c(55, 0), zoom = 7) - }) + #output$map <- renderGoogle_map({ + # 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({ - graphviz.plot(modelList[[.selections$model]][[.selections$layer]]$net) + getLabel <- function(impact) { + 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) } }) diff --git a/data/Sub_littoral_sand.xlsx b/data/Sub_littoral_sand.xlsx deleted file mode 100644 index d979787..0000000 Binary files a/data/Sub_littoral_sand.xlsx and /dev/null differ diff --git a/data/Sub_littoral_sand_BA.xlsx b/data/Sub_littoral_sand_BA.xlsx deleted file mode 100644 index 54deb05..0000000 Binary files a/data/Sub_littoral_sand_BA.xlsx and /dev/null differ