diff --git a/app.R b/app.R index 4836592..63cee53 100644 --- a/app.R +++ b/app.R @@ -103,14 +103,14 @@ ui <- dashboardPage( ), 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 + "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. + "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( @@ -203,9 +203,9 @@ server <- function(input, output, session) { print("Loading data") dataStorage <- "data/" - + palette <- c("firebrick", "coral", "rosybrown", "tan", "salmon", "olivedrab", "seagreen", "aquamarine", "darkcyan", "dodgerblue", "steelblue", "royalblue") - + models <- NULL pressures <- NULL @@ -382,7 +382,7 @@ server <- function(input, output, session) { #isolate({ 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]]$p_es$nodes$code[pressCodes], @@ -392,7 +392,7 @@ server <- function(input, output, session) { ) print(pressures) #This assumes all pressures are the same... - + setPressures(pressures) btnList <- apply(pressures, 1, makeRadioButtons) } @@ -503,7 +503,7 @@ server <- function(input, output, session) { nodeSpacing <- ifelse(.selections$bbnNames, 600, 150) - + nodes <- data.frame( id = rownames(nodes), label = labels, @@ -540,8 +540,8 @@ server <- function(input, output, session) { } else { edgeNet <- edges } - - + + legendDF <- data.frame( id = 1:nrow(model$legend), @@ -549,7 +549,7 @@ server <- function(input, output, session) { color = palette, stringsAsFactors = FALSE ) - + print(legendDF) visNetwork(nodeNet, edgeNet, width = "100%", main = "Bayesian Belief Network", submain = input$modelSelect) %>% @@ -575,13 +575,13 @@ server <- function(input, output, session) { genPlot <- function(boxPlot, title, paletteLength) { if (nrow(boxPlot) > 0) { - + #print(paste('Palette length', paletteLength)) #palette <- brewer.pal(paletteLength, "Set3") - + #palette <- c("red", "sienna3", "plum2", "rosybrown4", "sandybrown", "yellow", "seashell3", "palegreen", "springgreen4", "steelblue", "azure") - + names(palette) <- 1:length(palette) #print(paste("Box plot, colours", nrow(boxPlot), length(colours))) @@ -621,13 +621,51 @@ server <- function(input, output, session) { }) - export <- function(model, fPath) { - - return(zipFile) + exportOrca <- function (p, file = "plot.png", format = tools::file_ext(file), + scale = NULL, width = NULL, height = NULL, + verbose = FALSE, debug = FALSE, safe = FALSE) + { + if (Sys.which("orca") == "") { + stop("The orca command-line utility is required to use the `orca()` function.\n\n", + "Follow the installation instructions here -- https://github.com/plotly/orca#installation", + call. = FALSE) + } + + b <- plotly_build(p) + + plotlyjs <- b$dependencies[sapply(b$dependencies, function(d) { d$name == "plotly-main" })][[1]] + plotlyjs_file <- file.path(plotlyjs$src$file, plotlyjs$script) + + args <- c( + "graph", shQuote(jsonlite::toJSON( + b$x[c("data", "layout")], + digits = 50, + auto_unbox = TRUE, + force = TRUE, + null = "null", + na = "null" + )), + "-o", file, + "--format", format, + "--plotlyjs", plotlyjs_file + ) + if (debug) + args <- c(args, "--debug") + if (verbose) + args <- c(args, "--verbose") + if (safe) + args <- c(args, "--safe-mode") + if (!is.null(scale)) + args <- c(args, "--scale", scale) + if (!is.null(width)) + args <- c(args, "--width", width) + if (!is.null(height)) + args <- c(args, "--height", height) + + invisible(system2("orca", args)) } - output$linkBackgroundData <- downloadHandler( filename = getModelName(), content = function(file) { @@ -637,32 +675,28 @@ server <- function(input, output, session) { ) output$download <- downloadHandler( - filename = function() {paste0("MESO-", format(Sys.time(), "%m%d_%H%M"), ".zip")}, + filename = function() { paste0("MESO-", format(Sys.time(), "%m%d_%H%M"), ".zip") }, content = function(file) { showModal( modalDialog( fluidRow( column(width = 12) %>% withSpinner(type = 5, proxy.height = "200px") - ), + ), footer=div() ) ) - + oldDir <- getwd() - + tmp <- tempfile("") - - print(tmp) dir.create(tmp) - setwd(tmp) - + #Get the network graph - l1 <- orca(prepPlot("ba", "Bio-Assemblage"), "layer1.png") - l2 <- orca(prepPlot("op", "Output Processes"),"layer2.png") - l3 <- orca(prepPlot("es", "Ecosystem Services"),"layer3.png") - - + l1 <- exportOrca(prepPlot("ba", "Bio-Assemblage"), "layer1.png") + l2 <- exportOrca(prepPlot("op", "Output Processes"),"layer2.png") + l3 <- exportOrca(prepPlot("es", "Ecosystem Services"),"layer3.png") + #Save pressure list, confidence levels, node and edge tables in xlsx l <- list( pressures = .selections$pressStatus, @@ -671,14 +705,14 @@ server <- function(input, output, session) { settings = as.data.frame(cbind(names(.resistanceScores), .resistanceScores), stringsAsFactors = FALSE) ) xl <- write.xlsx(l, "dataset.xlsx") - + zipFile <- zipr(file, c("layer1.png", "layer2.png", "layer3.png", "dataset.xlsx")) - + print(paste("zip file complete", zipFile)) setwd(oldDir) unlink(tmp) - + removeModal() }, contentType = "application/zip"