JNCC/MESO
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Fix download by not using processx

Browse Source
This commit is contained in:
Craig Williams
2019-04-16 17:20:02 +01:00
parent b5349eb81a
commit fe6a17841d
1 changed files with 69 additions and 35 deletions
Download Patch File Download Diff File Expand all files Collapse all files

104
app.R
View File

@@ -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"