From 9b039297a0b26815e18db85fe8f9a5385ff17e40 Mon Sep 17 00:00:00 2001 From: spegg Date: Wed, 10 Apr 2019 10:57:37 +0100 Subject: [PATCH] Updates to downloads and colour graphics --- Parses.R | 42 +++-- app.R | 489 ++++++++++++++++++++++++++++++++----------------------- 2 files changed, 311 insertions(+), 220 deletions(-) diff --git a/Parses.R b/Parses.R index c71bfc5..71fefa2 100644 --- a/Parses.R +++ b/Parses.R @@ -14,7 +14,7 @@ FIRST_NODE_COL <- 3 mappings <- c('TestScenario', 'Map_P_BA', 'Map_BA_OP', 'Map_OP_ES') nodeTypes <- c('Input.Nodes', 'Internal.Nodes', 'Published.Nodes') -states <- c('impact', 'confidence', 'growth', 'recovery') +states <- c('impact', 'confidence', 'growth', 'recovery', 'layer') refs <-c(1:length(mappings)) setEmpties <- function(val) { @@ -46,9 +46,9 @@ buildExpr <- function(pressStatus) { parseScenario <- function(press, prefix = 'p') { pressNames <- colnames(press)[2:length(colnames(press))] - coefs <- matrix(data=NA, nrow=length(pressNames), ncol=2, dimnames=list(NULL, c('growth', 'confidence'))) + coefs <- matrix(data=NA, nrow=length(pressNames), ncol=3, dimnames=list(NULL, c('growth', 'confidence', 'layer'))) for (col in 2:ncol(press)) { - coefs[col-1,] <- as.numeric(split(press[1, col]))[match(c('growth', 'confidence'), states)] + coefs[col-1,] <- as.numeric(split(press[1, col]))[match(c('growth', 'confidence', 'layer'), states)] } press[is.na(press)] <- 0 if (sum(duplicated(pressNames))>0) { @@ -62,6 +62,7 @@ parseScenario <- function(press, prefix = 'p') { code=paste0(prefix, seq(1:length(pressNames))), growth = coefs[,'growth'], confidence=coefs[,'confidence'], + layer=coefs[,'layer'], stringsAsFactors = FALSE), edges=data.frame(input=NULL, output=NULL, impact=NULL) )) @@ -127,7 +128,7 @@ buildGraph <- function(model, desc) { edges <- paste0(edges, paste0("[", outNodes[idx], "|", substr(inputsStr, start=1, stop=(nchar(inputsStr)-1)), "]")) #Make the coefficient of the distribution - coefVal <- setNames(c(model$nodes$growth[nodeRef], model$edges$impact[rows]), + coefVal <- setNames(c(model$nodes$growth[nodeRef], model$edges$values[rows]), c("(Intercept)", model$edges$input[rows]) ) #str(coefVal) @@ -136,8 +137,9 @@ buildGraph <- function(model, desc) { } print('about to build network') + print(paste0(inputText, edges)) - net <- model2network(paste0(inputText, edges)) + net <- model2network(paste0(inputText, edges), debug=TRUE) print('network build successful') @@ -220,17 +222,20 @@ getValidNodes <- function(mapping, prevOutputs, prefix) { } } - coefs <- matrix(data=NA, nrow=length(outNodes), ncol=2, dimnames=list(NULL, c('growth', 'confidence'))) + coefs <- matrix(data=NA, nrow=length(outNodes), ncol=3, dimnames=list(NULL, c('growth', 'confidence', 'layer'))) for (idx in 1:length(outNodes)) { col <- match(outNodes[idx], colnames(mapping)) - coefs[idx,] <- as.numeric(split(mapping[1, col]))[match(c('growth', 'confidence'), states)] + coefs[idx,] <- as.numeric(split(mapping[1, col]))[match(c('growth', 'confidence', 'layer'), states)] } + + print(coefs) return(data.frame( code=c(prevOutputs$code, paste0(prefix, seq(1:length(outNodes)))), name=c(prevOutputs$name, outNodes), growth=c(prevOutputs$growth, coefs[,"growth"]), confidence=c(prevOutputs$confidence, coefs[,"confidence"]), + layer=c(prevOutputs$layer, coefs[,"layer"]), stringsAsFactors=FALSE )) } @@ -266,14 +271,14 @@ getValidEdges <- function(mapping, nodeDF, prevEdge=NULL, prefix) { data.frame( input = edgeM[,"inputNode"], output = edgeM[,"outputNode"], - impact = as.numeric(edgeM[,"impact"]), + impact = edgeM[,"impact"], stringsAsFactors = FALSE ) ) else return ( data.frame( input = c(prevEdge$input, edgeM[,"inputNode"]), output = c(prevEdge$output, edgeM[,"outputNode"]), - impact = c(prevEdge$impact, as.numeric(edgeM[,"impact"])), + impact = c(prevEdge$impact, edgeM[,"impact"]), stringsAsFactors = FALSE ) ) @@ -317,19 +322,20 @@ parseSheet <- function(fName) { 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') - print('building graphs') + #print('building graphs') - p_baNet <- buildGraph(p_ba, desc=list(inputCode='p', outputCodes='ba')) - p_opNet <- buildGraph(p_op, desc=list(inputCode='p', outputCodes=c('ba', 'op'))) - p_esNet <- buildGraph(p_es, desc=list(inputCode='p', outputCodes=c('ba', 'op', 'es'))) + #p_baNet <- buildGraph(p_ba, desc=list(inputCode='p', outputCodes='ba')) + #p_opNet <- buildGraph(p_op, desc=list(inputCode='p', outputCodes=c('ba', 'op'))) + #p_esNet <- buildGraph(p_es, desc=list(inputCode='p', outputCodes=c('ba', 'op', 'es'))) print('sheet load completed') return( - list( - pressBioAss = p_baNet, - pressOpProc = p_opNet, - pressEcoServ = p_esNet - ) + #list( + #pressBioAss = p_baNet, + #pressOpProc = p_opNet, + #pressEcoServ = p_esNet, + p_esMap = p_es + #) ) } else { diff --git a/app.R b/app.R index 64830db..354d8d6 100644 --- a/app.R +++ b/app.R @@ -15,20 +15,34 @@ modules::import(shinycssloaders) modules::import(googleway) modules::import(bnlearn) modules::import(visNetwork) +modules::import(RColorBrewer) +modules::import(zip) +modules::import(processx) +modules::import(openxlsx) + 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) +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') + addResourcePath("js", "./www/js") ui<-dashboardPage( dashboardHeader(title = "JNCC MESO online", - tags$li( id = "dropdownHelp", class = "dropdown", @@ -58,16 +72,17 @@ ui<-dashboardPage( tags$a( href = "Manual.pdf", target = "_BLANK", - "Open user guide in a new tab" + "Open user guide in tab" ) ) ), tags$li( tags$div( style = "margin-left: auto; margin-right: auto; width: 90%;", - downloadLink( - "linkBackgroundData", - "Download excel sheets" + tags$a( + href = "Report.pdf", + target = "_BLANK", + "Open Final Report in tab" ) ) ) @@ -81,6 +96,7 @@ ui<-dashboardPage( #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, @@ -96,8 +112,12 @@ ui<-dashboardPage( h4('Effect on bio-assemblage') ), column( - width=6, + width=1, actionButton("layer1Slider", "1", icon=icon("sliders-h")) + ), + column( + width=5, + strong("Customise sensitivity weightings") ) ), plotlyOutput("layer1", height="270px") %>% withSpinner(), @@ -108,31 +128,35 @@ ui<-dashboardPage( ), tabItem(tabName = "2",h2("Bayesian Network"), fluidPage( - p('Graphical output of the Bayesian Network. Note: large networks may never stabilise!'), + p('Graphical output of the Bayesian Network. Note: The graph will only draw if pressures are applied!'), fluidRow( column( width=4, checkboxInput("bbnDisplayNames", "Display Node names", value=FALSE) ), + column( + width=4, + checkboxInput("bbnDisplayEdges", "Display edge status", value=FALSE) + ), column( width=4, selectInput("bbnImpactSelect", "Impact Threshold", choices=impacts, selected='All') ) ), fluidRow( - visNetworkOutput("bbnGraphPlot") + visNetworkOutput("bbnGraphPlot", width = "100%", height = "1000px") ), fluidRow( - column( - width=6, - h4('Ecoservice nodes'), - DT::dataTableOutput('nodeTable') - ), - column( - width=6, - h4('Ecoservice influences'), - DT::dataTableOutput('edgeTable') - ) + column( + width=6, + h4('Ecoservice nodes'), + DT::dataTableOutput('nodeTable') + ), + column( + width=6, + h4('Ecoservice influences'), + DT::dataTableOutput('edgeTable') + ) ) ) ), @@ -164,9 +188,6 @@ server <- function(input, output, session) { models<-NULL pressures <- NULL - - #disable(input$loadAb) - .loadStatus <- reactiveValues( valid = c(p=FALSE, ba=FALSE, op=FALSE, es=FALSE), msgs = NULL @@ -175,68 +196,94 @@ server <- function(input, output, session) { .likelihoods <-reactiveValues( p_ba = NULL, ba_os = NULL, - os_es = NULL + os_es = NULL, + p_es = NULL ) setPressures <- function(newPressures) { pressures <<- newPressures } + + + .resistanceScores <- c( + ins= -0.01, + hr = -0.2, + mr = -0.75, + lr = -0.95, + nr = -0.99, + ssgr = 0, + pressSD = 0.5 + ) - validateSheets <- function() { - req(inputs$selectFile) - - ##TO DO - run parser on it and output the errors to + .selections <- reactiveValues( + model=1, + bbnImpact=1, + bbnNames=FALSE, + bbnEdges=FALSE, + pressStatus=NULL + ) + + 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]) + if ((v == "LR") || (v == "I")) return(.resistanceScores[4]) + if (v == "NR") return(.resistanceScores[5]) + as.numeric(v) } getAvailableModels <- function() { fileList <- list.files(dataStorage, pattern='.xlsx') - print(fileList) modelList <- list() cnt<-1 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) + 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])) + save(tmp, file='tmp.RData') cnt=cnt+1 - } } - updateSelectInput(session, "modelSelect", choices=models) - return(modelList) } - - .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, confLevels) { + + calcLikelihood <- function(layer, pressStatus) { isolate({ - if (layer==1) layerStr='ba' else if (layer==2) layerStr='op' else if (layer==3) layerStr='es' + #if (layer==1) layerStr='ba' else if (layer==2) layerStr='op' else if (layer==3) layerStr='es' - 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] + + #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]] + + MEANPOS=1 MEANNEG=0 @@ -253,13 +300,11 @@ server <- function(input, output, session) { expr <-substr(expr, 1, nchar(expr)-2) expr<-paste0(expr, ')') - - #build the graph - #parser$buildGraph(p_es, desc=list(inputCode='p', outputCodes=c('ba', 'op', 'es'))) + thisNet <- parser$buildGraph(thisModel, desc=list(inputCode='p', outputCodes=c('ba', 'op', 'es'))) sampleDists <- cpdist( - fitted = modelList[[.selections$model]][[layer]]$cfit, - nodes = bnlearn::nodes(modelList[[.selections$model]][[layer]]$cfit), + fitted = thisNet$cfit, + nodes = bnlearn::nodes(thisNet$cfit), evidence = eval(parse(text = expr)), method = "lw", n = 10000, @@ -267,13 +312,19 @@ server <- function(input, output, session) { ) }) - displayCols <- match(nodeCodes, colnames(sampleDists)) - sampleDists <- sampleDists[,displayCols] + print(sampleDists) + + #displayCols <- match(nodeCodes, colnames(sampleDists)) + sampleDists <- sampleDists[,match(thisModel$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))) + return(data.frame( - nodeNames = nodeNames, + name = thisModel$nodes$name, + code = thisModel$nodes$code, + layer = thisModel$nodes$layer, range = c( apply(sampleDists, 2, min), means - 2*stdDev, @@ -286,40 +337,12 @@ server <- function(input, output, session) { stringsAsFactors=FALSE )) } - - renderStatus <- function(layer) { - isolate({ - if (.loadStatus$valid[layer]) return('check-square') else return('times-circle') - }) - } - - output$status <- renderUI({ - - tagList( - fluidRow( - column(width=3, h4('Pressures')), - column(width=3, h4('Bio-assemblages')), - column(width=3, h4('Output processes')), - column(width=3, h4('Ecosystem services')) - ), - fluidRow( - column(width=3, icon(renderStatus(1))), - column(width=3, icon(renderStatus(2))), - column(width=3, icon(renderStatus(3))), - column(width=3, icon(renderStatus(4))) - ) - ) - }) observeEvent(input$modelSelect, { .selections$model <<- match(input$modelSelect, models) }) - #observeEvent(input$layerSelect, { - # .selections$layer <<- match(input$layerSelect, transitions) - #}) - observeEvent(reactiveValuesToList(input), { isolate(myList <- reactiveValuesToList(input)) matches <- match(pressures$code, names(myList)) @@ -332,44 +355,27 @@ server <- function(input, output, session) { 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) - + #.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 } } - 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) - #}) - 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)) { - pressCodes <- which(startsWith(modelList[[.selections$model]][[1]]$nodes$code, 'p')) - pressures <- data.frame(code = modelList[[.selections$model]][[1]]$nodes$code[pressCodes], - name = modelList[[.selections$model]][[1]]$nodes$name[pressCodes], stringsAsFactors=FALSE) + if (!is.null(modelList[[.selections$model]]$nodes)) { + pressCodes <- which(startsWith(modelList[[.selections$model]]$nodes$code, 'p')) + pressures <- data.frame(code = modelList[[.selections$model]]$nodes$code[pressCodes], + name = modelList[[.selections$model]]$nodes$name[pressCodes], stringsAsFactors=FALSE) setPressures(pressures) btnList <- apply(pressures, 1, makeRadioButtons) } @@ -386,90 +392,110 @@ server <- function(input, output, session) { print(.selections$bbnNames) }) + observeEvent(input$bbnDisplayEdges, { + .selections$bbnEdges <- input$bbnDisplayEdges + + }) + + 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) + sliderInput("l1VL", "Insensitive", 0.01, 0.2, abs(.resistanceScores[1]), step=0.01), + sliderInput("l1L", "Low Sensitivity/High resistance", 0.15, 0.5, abs(.resistanceScores[2]), step=0.01), + sliderInput("l1M", "Medium Sensitivity/Med resistance", 0.5, 0.75, abs(.resistanceScores[3]), step=0.01), + sliderInput("l1H", "High Sensitivity/Low resistance", 0.75, 1.0, abs(.resistanceScores[4]), step=0.01), + sliderInput("l1VH", "Very High Sensitivity/No resistance", 0.9, 1.0, abs(.resistanceScores[5]), step=0.01), + sliderInput("ssgr", "Steady state growth rate", -0.1, 0.1,.resistanceScores[6], step=0.01), + sliderInput("l1PressSD", "Pressure Std Dev", 0.1, 1.0, .resistanceScores[7], step=0.01) ) - }, title='Layer 1 controls', size='s') + }, + title='Layer 1 controls', + footer=tagList( + modalButton("Cancel"), + actionButton("modalOK", "OK") + ), + size='s') ) }) - - + observeEvent(input$modalOK, { + print('Modal ok pressed') + .resistanceScores['nr'] <<- -input$l1VH + .resistanceScores['lr'] <<- -input$l1H + .resistanceScores['mr'] <<- -input$l1M + .resistanceScores['hr'] <<- -input$l1L + .resistanceScores['ins'] <<- -input$l1VL + .resistanceScores['ssgr'] <<- input$ssgr + .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() + + }) + output$nodeTable <- DT::renderDataTable( - modelList[[.selections$model]][[.selections$layer]]$nodes, + modelList[[.selections$model]]$nodes, selection = 'single',options = list(searching = TRUE, pageLength = 10, editable=TRUE),server = TRUE, escape = FALSE,rownames= TRUE ) output$edgeTable <- DT::renderDataTable( - modelList[[.selections$model]][[.selections$layer]]$edges, + modelList[[.selections$model]]$edges, selection = 'single',options = list(searching = TRUE, pageLength = 10, editable=TRUE),server = TRUE, escape = FALSE,rownames= TRUE ) - getLabel <- function(impact) { - sign <- ifelse(impact<0, "-", "+") - idx <- min(which((abs(impact)>=thresholds)==TRUE)) + getLabel <- function(value) { + sign <- ifelse(value<0, "-", "+") + idx <- min(which((abs(value)>=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 - + makeBbnGraph <- function(model) { + nodes <- model$nodes + + if (.selections$bbnEdges) {labels <- sapply(model$edges$values, getLabel)} else {labels <- rep("", nrow(model$edges))} + 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), + id = rownames(model$edges), + from=match(model$edges$input, nodes$code), + to=match(model$edges$output, nodes$code), + values=model$edges$values, + label=labels, arrows="to", stringsAsFactors=FALSE ) if (.selections$bbnNames) {labels <- nodes$name} else {labels <- nodes$code} - + nodeSpacing <- ifelse(.selections$bbnNames, 600, 150) + palette <- brewer.pal(length(legends), "RdYlGn") + nodes <- data.frame( id = rownames(nodes), label = labels, - level = sapply(nodes$code, getLevels), + level = nodes$layer, + group = nodes$layer, + color = palette[as.integer(nodes$layer)], code = nodes$code, stringsAsFactors=FALSE ) - - - edges <- edges[(abs(edges$impact)>=.selections$bbnImpact),] + edges <- edges[(abs(edges$values)>=.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 @@ -484,70 +510,129 @@ server <- function(input, output, session) { 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) + legendDF <- data.frame( + id = 1:length(legends), + label = legends, + color = palette, + stringsAsFactors = FALSE + ) + + visNetwork(nodeNet, edgeNet, width = "100%", main='Bayesian Belief Network', submain=input$modelSelect) %>% + visExport() %>% + visLegend(useGroups=FALSE, addNodes=legendDF) %>% + visHierarchicalLayout(nodeSpacing=nodeSpacing, direction='LR') %>% + visOptions(highlightNearest = TRUE) #%>% + #visInteraction(navigationButtons = TRUE, dragNodes = TRUE, dragView = TRUE, zoomView = TRUE) + } + + output$bbnGraphPlot <- renderVisNetwork({ + makeBbnGraph(modelList[[.selections$model]]) }) - observe({ - visNetworkProxy("bbnGraphPlot") %>% - visStabilize(iterations=10) - }) + #observe({ + # visNetworkProxy("bbnGraphPlot") %>% + # visStabilize(iterations=10) + #}) + getModelName <- function() { + paste0('data/', input$modelSelect, '.xlsx') + } + + genPlot <- function(boxPlot, title) { + if (nrow(boxPlot)>0) { + + palette <- brewer.pal(length(legends), "RdYlGn") + #print(palette) + + colours <- palette[as.integer(boxPlot$Group)] + + #print(paste('Box plot, colours', nrow(boxPlot), length(colours))) + #cat(colours) + xform <- list(categoryorder = "array", + categoryarray = boxPlot[,1], + zerolinewidth=10) + # + plot_ly(boxPlot, x = boxPlot[,1], y = ~Range, color = colours, colors = palette, type = "box") %>% + layout(xaxis = xform, showlegend=FALSE, title=title) + + } + } + + prepPlot <- function(code="ba", name="Bio-Assemblage") { + if (!is.null(.likelihoods$p_es)) { + inScope <- startsWith(.likelihoods$p_es$code, code) + 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) + } + } 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 = xform) - - } + prepPlot("ba", "Bio-Assemblage") }) - + output$layer2 <- renderPlotly({ - 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 = xform) - - } + prepPlot("op", "Output Processes") }) - + output$layer3 <- renderPlotly({ - - 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 = xform) - - } + prepPlot("es", "Ecosystem Services") }) + + + export <- function(model) { + + #Get the network graph + l1 <- orca(prepPlot("ba", "Bio-Assemblage"), 'tmp/layer1.png') + l2 <- orca(prepPlot("op", "Output Processes"),'tmp/layer2.png') + l3 <- orca(prepPlot("es", "Ecosystem Services"), 'tmp/layer3.png') + + #Save pressure list, confidence levels, node and edge tables in xlsx + l <- list( + pressures = .selections$pressStatus, + nodes = model$nodes, + edges = model$edges, + settings = as.data.frame(cbind(names(.resistanceScores), .resistanceScores), stringsAsFactors=FALSE) + ) + + xl <- write.xlsx(l, 'tmp/dataset.xlsx') + + print('saving xlsx file export tmp/dataset.xlsx') + + zipFile <- zipr(paste0('MESO-', format(Sys.time(), "%m%d_%H%M"), '.zip'), c('tmp/layer1.png', 'tmp/layer2.png', 'tmp/layer3.png', 'tmp/dataset.xlsx')) + + print(paste('zip file complete', zipFile)) + + return(zipFile) + } + + + + + + output$linkBackgroundData <- downloadHandler( + filename = getModelName(), + content = function(file) { + file.copy(getModelName(), file) + }, + contentType = "application/xlsx" + ) + + output$download <-downloadHandler( + filename = paste0('MESO-', format(Sys.time(), "%m%d_%H%M"), '.zip'), + content = function(file) { + fName <- export(modelList[[.selections$model]]) + file.copy(fName, file) + }, + contentType = "application/zip" + ) + + } shinyApp(ui, server) \ No newline at end of file