638 lines
20 KiB
R
638 lines
20 KiB
R
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(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.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",
|
|
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 tab"
|
|
)
|
|
)
|
|
),
|
|
tags$li(
|
|
tags$div(
|
|
style = "margin-left: auto; margin-right: auto; width: 90%;",
|
|
tags$a(
|
|
href = "Report.pdf",
|
|
target = "_BLANK",
|
|
"Open Final Report in tab"
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
),
|
|
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 = "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,
|
|
# selected=NULL, multiple=FALSE)
|
|
)
|
|
),
|
|
dashboardBody(
|
|
tabItems(
|
|
tabItem(tabName = "1", h2('Impact Distribution'),
|
|
fluidRow(
|
|
column(
|
|
width=6,
|
|
h4('Effect on bio-assemblage')
|
|
),
|
|
column(
|
|
width=1,
|
|
actionButton("layer1Slider", "1", icon=icon("sliders-h"))
|
|
),
|
|
column(
|
|
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()
|
|
),
|
|
tabItem(tabName = "2",h2("Bayesian Network"),
|
|
fluidPage(
|
|
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", width = "100%", height = "1000px")
|
|
),
|
|
fluidRow(
|
|
column(
|
|
width=6,
|
|
h4('Ecoservice nodes'),
|
|
DT::dataTableOutput('nodeTable')
|
|
),
|
|
column(
|
|
width=6,
|
|
h4('Ecoservice influences'),
|
|
DT::dataTableOutput('edgeTable')
|
|
)
|
|
)
|
|
)
|
|
),
|
|
#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"),
|
|
fluidRow(renderUI('status')),
|
|
actionButton('loadAB', 'Load') # icon='upload')
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
server <- function(input, output, session) {
|
|
#SERVER Constants
|
|
|
|
print('Loading data')
|
|
|
|
#set_key("AIzaSyAw8_btgGN1drf8qhCxNcotP6r11qEXA_M")
|
|
dataStorage <- 'data/'
|
|
|
|
models<-NULL
|
|
pressures <- NULL
|
|
|
|
.loadStatus <- reactiveValues(
|
|
valid = c(p=FALSE, ba=FALSE, op=FALSE, es=FALSE),
|
|
msgs = NULL
|
|
)
|
|
|
|
.likelihoods <-reactiveValues(
|
|
p_ba = NULL,
|
|
ba_os = 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
|
|
)
|
|
|
|
.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')
|
|
|
|
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)
|
|
}
|
|
|
|
#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'
|
|
|
|
|
|
|
|
#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
|
|
|
|
expr <- "list("
|
|
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, ')')
|
|
|
|
thisNet <- parser$buildGraph(thisModel, desc=list(inputCode='p', outputCodes=c('ba', 'op', 'es')))
|
|
|
|
sampleDists <- cpdist(
|
|
fitted = thisNet$cfit,
|
|
nodes = bnlearn::nodes(thisNet$cfit),
|
|
evidence = eval(parse(text = expr)),
|
|
method = "lw",
|
|
n = 10000,
|
|
debug=TRUE
|
|
)
|
|
})
|
|
|
|
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(
|
|
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 (!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_es <<- calcLikelihood(0, newStatus)
|
|
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)
|
|
}
|
|
|
|
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)
|
|
setPressures(pressures)
|
|
btnList <- apply(pressures, 1, makeRadioButtons)
|
|
}
|
|
})
|
|
|
|
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$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)
|
|
)
|
|
},
|
|
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]]$nodes,
|
|
selection = 'single',options = list(searching = TRUE, pageLength = 10, editable=TRUE),server = TRUE, escape = FALSE,rownames= 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
|
|
)
|
|
|
|
getLabel <- function(value) {
|
|
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))}
|
|
|
|
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}
|
|
|
|
nodeSpacing <- ifelse(.selections$bbnNames, 600, 150)
|
|
|
|
palette <- brewer.pal(length(legends), "RdYlGn")
|
|
|
|
nodes <- data.frame(
|
|
id = rownames(nodes),
|
|
label = labels,
|
|
level = nodes$layer,
|
|
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
|
|
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
|
|
|
|
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)
|
|
#})
|
|
|
|
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({
|
|
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')
|
|
|
|
#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) |