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

Merge

Browse Source
This commit is contained in:
Steve Pegg
2019-04-11 13:59:13 +01:00
parent 12dc3b2c92 fede4e3dc4
commit 1383055d3c
6 changed files with 2231 additions and 445 deletions
Download Patch File Download Diff File Expand all files Collapse all files

595
app.R
View File

@@ -1,48 +1,41 @@
modules::import(DT)
modules::import(shiny)
modules::import(shinyBS)
modules::import(shinyjs)
modules::import(shinydashboard)
modules::import(shinydashboardPlus)
modules::import(htmltools)
#modules::import(DiagrammeR)
modules::import(magrittr)
modules::import(plotly)
modules::import(kableExtra)
#modules::import(Rgraphviz)
modules::import(knitr)
modules::import(shinycssloaders)
#modules::import(googleway)
modules::import(shinyjs)
modules::import(bnlearn)
modules::import(visNetwork)
modules::import(RColorBrewer)
modules::import(zip)
modules::import(processx)
modules::import(plotly)
modules::import(openxlsx)
modules::import(zip)
modules::import(DT)
parser <- modules::use("Parses.R")
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.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",
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.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")
ui <- dashboardPage(
dashboardHeader(title = "JNCC MESO online",
tags$li(
id = "dropdownHelp",
class = "dropdown",
@@ -95,52 +88,52 @@ ui<-dashboardPage(
menuItem("Bayesian Network", tabName = "2", icon = icon("atom")),
#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")),
selectInput("modelSelect", "Select MESO model", choices = c(""), selected = NULL, multiple = FALSE),
downloadButton("download", "", icon = icon("download")),
uiOutput("pressureList")
#selectInput("layerSelect", "Select Transition",
# choices=transitions,
# selected=NULL, multiple=FALSE)
#selectInput("layerSelect", "Select Transition",
# choices = transitions,
# selected = NULL, multiple = FALSE)
)
),
dashboardBody(
tabItems(
tabItem(tabName = "1", h2('Impact Distribution'),
tabItem(tabName = "1", h2("Impact Distribution"),
fluidRow(
column(
width=6,
h4('Effect on bio-assemblage')
width = 6,
h4("Effect on bio-assemblage")
),
column(
width=1,
actionButton("layer1Slider", "1", icon=icon("sliders-h"))
width = 1,
actionButton("layer1Slider", "1", icon = icon("sliders-h"))
),
column(
width=5,
width = 5,
strong("Customise sensitivity weightings")
)
),
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()
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: The graph will only draw if pressures are applied!'),
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)
width = 4,
checkboxInput("bbnDisplayNames", "Display Node names", value = FALSE)
),
column(
width=4,
checkboxInput("bbnDisplayEdges", "Display edge status", value=FALSE)
width = 4,
checkboxInput("bbnDisplayEdges", "Display edge status", value = FALSE)
),
column(
width=4,
selectInput("bbnImpactSelect", "Impact Threshold", choices=impacts, selected='All')
width = 4,
selectInput("bbnImpactSelect", "Impact Threshold", choices = impacts, selected = "All")
)
),
fluidRow(
@@ -148,14 +141,14 @@ ui<-dashboardPage(
),
fluidRow(
column(
width=6,
h4('Ecoservice nodes'),
DT::dataTableOutput('nodeTable')
width = 6,
h4("Ecoservice nodes"),
DT::dataTableOutput("nodeTable")
),
column(
width=6,
h4('Ecoservice influences'),
DT::dataTableOutput('edgeTable')
width = 6,
h4("Ecoservice influences"),
DT::dataTableOutput("edgeTable")
)
)
)
@@ -164,13 +157,13 @@ ui<-dashboardPage(
# 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"),
fluidRow(renderUI('status')),
actionButton('loadAB', 'Load') # icon='upload')
fluidRow(renderUI("status")),
actionButton("loadAB", "Load") # icon = "upload")
)
)
)
@@ -179,34 +172,34 @@ ui<-dashboardPage(
server <- function(input, output, session) {
#SERVER Constants
print('Loading data')
print("Loading data")
#set_key("AIzaSyAw8_btgGN1drf8qhCxNcotP6r11qEXA_M")
dataStorage <- 'data/'
models<-NULL
dataStorage <- "data/"
models <- NULL
pressures <- NULL
.loadStatus <- reactiveValues(
valid = c(p=FALSE, ba=FALSE, op=FALSE, es=FALSE),
valid = c(p = FALSE, ba = FALSE, op = FALSE, es = FALSE),
msgs = NULL
)
.likelihoods <-reactiveValues(
.likelihoods <- reactiveValues(
p_ba = NULL,
ba_os = NULL,
os_es = NULL,
p_es = NULL
)
setPressures <- function(newPressures) {
pressures <<- newPressures
}
.resistanceScores <- c(
ins= -0.01,
ins = -0.01,
hr = -0.2,
mr = -0.75,
lr = -0.95,
@@ -214,15 +207,15 @@ server <- function(input, output, session) {
ssgr = 0,
pressSD = 0.5
)
.selections <- reactiveValues(
model=1,
bbnImpact=1,
bbnNames=FALSE,
bbnEdges=FALSE,
pressStatus=NULL
model = 1,
bbnImpact = 1,
bbnNames = FALSE,
bbnEdges = FALSE,
pressStatus = NULL
)
getImpact <- function(v) {
print(v)
if ((v == "INS") || (v == "IV")) return(.resistanceScores[1])
@@ -232,75 +225,75 @@ server <- function(input, output, session) {
if (v == "NR") return(.resistanceScores[5])
as.numeric(v)
}
getAvailableModels <- function() {
fileList <- list.files(dataStorage, pattern='.xlsx')
fileList <- list.files(dataStorage, pattern = ".xlsx")
modelList <- list()
cnt<-1
cnt <- 1
for (idx in 1:length(fileList)) {
print(paste('attempting to load', paste0(dataStorage, fileList[idx])))
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
print(paste("Model file successfully loaded", fileList[idx]))
#save(tmp, file = "tmp.RData")
cnt <- cnt+1
}
}
updateSelectInput(session, "modelSelect", choices=models)
updateSelectInput(session, "modelSelect", choices = models)
return(modelList)
}
#parse on load sheets in the input sheet folder - replace with R Data
modelList <- getAvailableModels()
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(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
#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
expr <- "list("
for (p in 1:nrow(pressStatus)) {
if (pressStatus$status[p] == 'On') {
threshold = MEANPOS
if (pressStatus$status[p] == "On") {
threshold <- MEANPOS
} else {
threshold = MEANNEG
threshold <- MEANNEG
}
expr <- paste0(expr, "\"", pressStatus$code[p], "\"=", threshold, ", ")
expr <- paste0(expr, "\"", pressStatus$code[p], "\" = ", threshold, ", ")
}
expr <-substr(expr, 1, nchar(expr)-2)
expr<-paste0(expr, ')')
thisNet <- parser$buildGraph(thisModel, desc=list(inputCode='p', outputCodes=c('ba', 'op', 'es')))
expr <- substr(expr, 1, nchar(expr)-2)
expr <- paste0(expr, ")")
thisNet <- parser$buildGraph(thisModel, desc = list(inputCode = "p", outputCodes = c("ba", "op", "es")))
sampleDists <- cpdist(
fitted = thisNet$cfit,
@@ -308,130 +301,135 @@ server <- function(input, output, session) {
evidence = eval(parse(text = expr)),
method = "lw",
n = 10000,
debug=TRUE
debug = FALSE
)
})
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)))
print(paste("Building likelihoods from model, sample dists", length(thisModel$nodes$name), length(sampleDists)))
return(data.frame(
name = thisModel$nodes$name,
code = thisModel$nodes$code,
layer = thisModel$nodes$layer,
range = c(
apply(sampleDists, 2, min),
means - 2*stdDev,
means - stdDev,
means,
means + stdDev,
means + 2*stdDev,
apply(sampleDists, 2, max)
),
stringsAsFactors=FALSE
))
name = thisModel$nodes$name,
code = thisModel$nodes$code,
layer = thisModel$nodes$layer,
range = c(
apply(sampleDists, 2, min),
means - 2*stdDev,
means - stdDev,
means,
means + stdDev,
means + 2*stdDev,
apply(sampleDists, 2, max)
),
stringsAsFactors = FALSE
))
}
observeEvent(input$modelSelect, {
.selections$model <<- match(input$modelSelect, models)
})
observeEvent(reactiveValuesToList(input), {
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]]]
newStatus <- data.frame(code=pressures$code, status=status, stringsAsFactors = FALSE)
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')
print("Running calc")
#.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')
#write.xlsx(.likelihoods$p_es, "tmp.xlsx")
.selections$pressStatus <<- newStatus
}
}
})
makeRadioButtons <- function(row) {
radioButtons(row['code'], row['name'], choices=c('Off', 'On'), selected='Off', inline=TRUE)
radioButtons(row["code"], row["name"], choices = c("Off", "On"), selected = "Off", inline = TRUE)
}
output$pressureList <- renderUI({
#isolate({
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)
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)
}
})
observeEvent(input$bbnImpactSelect, {
#filter nodes and edges to
#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$bbnDisplayEdges, {
.selections$bbnEdges <- input$bbnDisplayEdges
})
observeEvent(input$layer1Slider, {
showModal(
modalDialog({
tagList(
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)
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',
footer=tagList(
},
title = "Layer 1 controls",
footer = tagList(
modalButton("Cancel"),
actionButton("modalOK", "OK")
),
size='s')
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')
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)
@@ -439,46 +437,60 @@ server <- function(input, output, session) {
removeModal()
})
output$nodeTable <- DT::renderDataTable(
modelList[[.selections$model]]$nodes,
selection = 'single',options = list(searching = TRUE, pageLength = 10, editable=TRUE),server = TRUE, escape = FALSE,rownames= TRUE
)
selection = "single",
server = TRUE,
escape = FALSE,
rownames = TRUE,
options = list(searching = TRUE, pageLength = 10, editable = TRUE)
)
output$edgeTable <- DT::renderDataTable(
modelList[[.selections$model]]$edges,
selection = 'single',options = list(searching = TRUE, pageLength = 10, editable=TRUE),server = TRUE, escape = FALSE,rownames= TRUE
selection = "single",
server = TRUE,
escape = FALSE,
rownames = TRUE,
options = list(searching = TRUE, pageLength = 10, editable = TRUE)
)
getLabel <- function(value) {
sign <- ifelse(value<0, "-", "+")
idx <- min(which((abs(value)>=thresholds)==TRUE))
sign <- ifelse(value < 0, "-", "+")
idx <- min(which((abs(value) >= thresholds) == TRUE))
return(paste0(sign, impLabels[idx]))
}
makeBbnGraph <- function(model) {
nodes <- model$nodes
if (.selections$bbnEdges) {labels <- sapply(model$edges$values, getLabel)} else {labels <- rep("", nrow(model$edges))}
if (.selections$bbnEdges) {
labels <- sapply(model$edges$values, getLabel)
} else {
labels <- rep("", nrow(model$edges))
}
edges <- data.frame(
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}
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,
@@ -486,135 +498,132 @@ server <- function(input, output, session) {
group = nodes$layer,
color = palette[as.integer(nodes$layer)],
code = nodes$code,
stringsAsFactors=FALSE
)
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
stringsAsFactors = FALSE
)
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
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
if ((idx > 20) || ((nrow(nodesToAdd) == 0) && (nrow(edgesToAdd) == 0))) break
nodeNet <- rbind(nodeNet, nodesToAdd)
edgeNet <- rbind(edgeNet, edgesToAdd)
} #until finished
} else edgeNet <- edges
} else {
edgeNet <- edges
}
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) %>%
visNetwork(nodeNet, edgeNet, width = "100%", main = "Bayesian Belief Network", submain = input$modelSelect) %>%
visExport() %>%
visLegend(useGroups=FALSE, addNodes=legendDF) %>%
visHierarchicalLayout(nodeSpacing=nodeSpacing, direction='LR') %>%
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)
# visStabilize(iterations = 10)
#})
getModelName <- function() {
paste0('data/', input$modelSelect, '.xlsx')
paste0("data/", input$modelSelect, ".xlsx")
}
genPlot <- function(boxPlot, title) {
if (nrow(boxPlot)>0) {
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)))
names(palette) <- 1:length(legends)
#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)
}
zerolinewidth = 10)
#
plot_ly(boxPlot, x = boxPlot[,1], y = ~Range, color = as.character(boxPlot$Group), colors = palette, type = "box") %>%
layout(xaxis = xform, showlegend = FALSE, title = title)
}
}
prepPlot <- function(code="ba", name="Bio-Assemblage") {
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')
title <- paste(input$modelSelect, name, "Box Plot")
genPlot(thisPlot, title)
}
}
output$layer1 <- renderPlotly({
prepPlot("ba", "Bio-Assemblage")
})
output$layer2 <- renderPlotly({
prepPlot("op", "Output Processes")
})
output$layer3 <- renderPlotly({
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')
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,
pressures = .selections$pressStatus,
nodes = model$nodes,
edges = model$edges,
settings = as.data.frame(cbind(names(.resistanceScores), .resistanceScores), stringsAsFactors=FALSE)
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('tmp/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))
xl <- write.xlsx(l, "tmp/dataset.xlsx")
print("saving xlsx file export tmp/dataset.xlsx")
zipFile <- zipr(paste0("tmp/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) {
@@ -622,9 +631,9 @@ server <- function(input, output, session) {
},
contentType = "application/xlsx"
)
output$download <-downloadHandler(
filename = paste0('MESO-', format(Sys.time(), "%m%d_%H%M"), '.zip'),
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)
@@ -632,7 +641,7 @@ server <- function(input, output, session) {
contentType = "application/zip"
)
}
shinyApp(ui, server)
shinyApp(ui, server)