267 lines
8.9 KiB
R
267 lines
8.9 KiB
R
modules::import(DT)
|
|
modules::import(shiny)
|
|
modules::import(shinyBS)
|
|
modules::import(shinyjs)
|
|
modules::import(shinydashboard)
|
|
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(Rgraphviz)
|
|
modules::import(bnlearn)
|
|
|
|
parser <- modules::use('Parses.R')
|
|
|
|
layers <- c("Pressures to Bio-Assemblages", "Bio-Assemblages to Output Processes", "Output Processes to Eco-system services")
|
|
transitions <- c("Pressures to Bio-Assemblages", "Pressures to Output Processes", "Pressures to Eco-system services")
|
|
addResourcePath("js", "./www/js")
|
|
|
|
ui<-dashboardPage(
|
|
dashboardHeader(title = "JNCC MESO online"),
|
|
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")),
|
|
selectInput("modelSelect", "Select MESO model", choices=c(""), selected=NULL, multiple=FALSE),
|
|
selectInput("layerSelect", "Select Transition",
|
|
choices=transitions,
|
|
selected=NULL, multiple=FALSE)
|
|
)
|
|
),
|
|
dashboardBody(
|
|
tabItems(
|
|
tabItem(tabName = "1",
|
|
fluidRow(
|
|
column(width=2,
|
|
h4('Pressure Test'),
|
|
radioButtons("pressure1", 'Sediment type', choices=c('On', 'Off'), inline=TRUE),
|
|
radioButtons("pressure2", 'Seabed type', choices=c('On', 'Off'), inline=TRUE),
|
|
radioButtons("pressure3", 'Material extraction', choices=c('On', 'Off'), inline=TRUE),
|
|
radioButtons("pressure4", 'Abrasion of seabed', choices=c('On', 'Off'), inline=TRUE),
|
|
radioButtons("pressure5", 'Penetration of seabed', choices=c('On', 'Off'), inline=TRUE),
|
|
radioButtons("pressure6", 'Siltation', choices=c('On', 'Off'), inline=TRUE),
|
|
radioButtons("pressure7", 'Wave exposure', choices=c('On', 'Off'), inline=TRUE),
|
|
radioButtons("pressure8", 'Suspended sediment', choices=c('On', 'Off'), inline=TRUE),
|
|
radioButtons("pressure9", 'Generic contamination', choices=c('On', 'Off'), inline=TRUE),
|
|
radioButtons("pressure10", 'Deoxygenation', choices=c('On', 'Off'), inline=TRUE),
|
|
radioButtons("pressure11", 'Removal of target species', choices=c('On', 'Off'), inline=TRUE),
|
|
actionButton("calcAB", "Calc")
|
|
),
|
|
column(width=10,
|
|
h4('Effect on bio-assemblage'),
|
|
plotlyOutput("layer1", height="270px") %>% withSpinner(),
|
|
h4('Effect on Output Processes'),
|
|
plotlyOutput("layer2", height="270px") %>% withSpinner(),
|
|
h4('Effect on Eco-system services'),
|
|
plotlyOutput("layer3", height="270px") %>% withSpinner()
|
|
)
|
|
)
|
|
),
|
|
tabItem(tabName = "2",h4("Bayesian Network"),
|
|
fluidPage(
|
|
fluidRow(
|
|
plotOutput("bbnGraphPlot")
|
|
),
|
|
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")
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
server <- function(input, output, session) {
|
|
#SERVER Constants
|
|
|
|
print('Loading data')
|
|
|
|
set_key("AIzaSyAw8_btgGN1drf8qhCxNcotP6r11qEXA_M")
|
|
dataStorage <- 'data/'
|
|
|
|
models<-NULL
|
|
|
|
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]))
|
|
|
|
if (!is.null(tmp)) {
|
|
modelList[[cnt]] <- tmp
|
|
|
|
#tidy up the list for displaying
|
|
|
|
models <<- c(models, substr(fileList[idx], 1, (nchar(fileList[idx])-5)))
|
|
print(paste('Model file successfully loaded', fileList[idx]))
|
|
cnt=cnt+1
|
|
|
|
|
|
}
|
|
}
|
|
|
|
updateSelectInput(session, "modelSelect", choices=models)
|
|
|
|
return(modelList)
|
|
}
|
|
|
|
|
|
.selections <- reactiveValues(model=1, layer=1)
|
|
|
|
#parse on load sheets in the input sheet folder
|
|
modelList <- getAvailableModels()
|
|
|
|
calcLikelihood <- function(layer) {
|
|
|
|
isolate({
|
|
if (layer==1) layerStr='ba' else if (layer==2) layerStr='op' else layerStr ='es'
|
|
nodeList <- modelList[[.selections$model]][[.selections$layer]]$nodes
|
|
str(nodeList)
|
|
nodeNames <- nodeList$name[startsWith(nodeList$code, layerStr)]
|
|
mean = runif(length(nodeNames), min=-1, max=1)
|
|
sd = runif(length(nodeNames), min=-0.25, max=0.25)
|
|
|
|
df <- data.frame(
|
|
nodeNames = nodeNames,
|
|
range = c((mean - (3*sd)), (mean - (2*sd)), (mean - sd), mean,
|
|
(mean + sd), (mean + (2*sd)), (mean + (3*sd))),
|
|
stringsAsFactors=FALSE
|
|
)
|
|
print(df)
|
|
})
|
|
return(
|
|
df
|
|
)
|
|
# isolate({
|
|
#
|
|
# if (layer==1) layerStr='ba' else if (layer==2) layerStr='op' else if (layer==3) layerStr='es'
|
|
#
|
|
# layerRange <- which(startsWith(modelList[[.selections$model]][[layer]]$nodes, layerStr))
|
|
# distList <- modelList[[.selections$model]][[layer]]$summDist[,layerRange]
|
|
# nodeNames <- modelList[[.selections$model]][[layer]]$nodes$name[layerRange]
|
|
#
|
|
# }
|
|
|
|
# print(paste('Length of layer & node names',layer, length(nodeNames)))
|
|
#
|
|
# distList <- modelList[[.selections$model]][[layer]]$summDist
|
|
# colNames <- c('min', 'q1', 'q1', 'mean', 'q3', 'q3', 'max')
|
|
# distM <- matrix(data=NA, nrow=ncol(distList), ncol=length(colNames))
|
|
#
|
|
# print(paste('Length of distributions',nrow(distM)))
|
|
|
|
# for (col in 1:ncol(distList)) {
|
|
# valsAsStrs <- unlist(strsplit(distList[,col], ":"))
|
|
# valIdxs <- seq(from=2, to=length(valsAsStrs), by=2)
|
|
# distVals <- as.numeric(valsAsStrs[valIdxs])
|
|
# distM[col,] <- c(distVals[1], distVals[2], distVals[2], distVals[4], distVals[5], distVals[5], distVals[6])
|
|
# }
|
|
# })
|
|
#
|
|
# df <- data.frame(
|
|
# nodeNames = nodeNames,
|
|
# dist = distM,
|
|
# stringsAsFactors=FALSE
|
|
# )
|
|
# print(df)
|
|
#
|
|
# return(
|
|
# df
|
|
# )
|
|
}
|
|
|
|
|
|
.likelihoods <-reactiveValues(
|
|
p_ba = calcLikelihood(1),
|
|
ba_os = calcLikelihood(2),
|
|
os_es = calcLikelihood(3)
|
|
)
|
|
|
|
observeEvent(input$modelSelect, {
|
|
.selections$model <<- match(input$modelSelect, models)
|
|
#print(.selections$model)
|
|
})
|
|
|
|
observeEvent(input$layerSelect, {
|
|
.selections$layer <<- match(input$layerSelect, transitions)
|
|
#print(.selections$layer)
|
|
})
|
|
|
|
observeEvent(input$calcAB, {
|
|
#print(paste('Action button pressed', input$calcAB))
|
|
|
|
.likelihoods$p_ba <<- calcLikelihood(1)
|
|
.likelihoods$ba_os <<- calcLikelihood(2)
|
|
.likelihoods$os_es <<- calcLikelihood(3)
|
|
|
|
})
|
|
|
|
output$map <- renderGoogle_map({
|
|
google_map(location = c(55, 0), zoom = 7)
|
|
})
|
|
|
|
|
|
|
|
|
|
output$nodeTable <- DT::renderDataTable(
|
|
|
|
modelList[[.selections$model]][[.selections$layer]]$nodes,
|
|
selection = 'single',options = list(searching = TRUE, pageLength = 10),server = TRUE, escape = FALSE,rownames= TRUE
|
|
)
|
|
|
|
output$edgeTable <- DT::renderDataTable(
|
|
|
|
modelList[[.selections$model]][[.selections$layer]]$edges,
|
|
selection = 'single',options = list(searching = TRUE, pageLength = 10),server = TRUE, escape = FALSE,rownames= TRUE
|
|
)
|
|
|
|
output$bbnGraphPlot <- renderPlot({
|
|
graphviz.plot(modelList[[.selections$model]][[.selections$layer]]$net)
|
|
})
|
|
|
|
output$layer1 <- renderPlotly({
|
|
plot_ly(.likelihoods$p_ba, y = ~range, color = ~nodeNames, type = "box")
|
|
})
|
|
|
|
output$layer2 <- renderPlotly({
|
|
#print(.likelihoods)
|
|
|
|
if (.selections$layer>1) {
|
|
plot_ly(.likelihoods$ba_os, y = ~range, color = ~nodeNames, type = "box")
|
|
}
|
|
})
|
|
|
|
output$layer3 <- renderPlotly({
|
|
|
|
if (.selections$layer>2) {
|
|
plot_ly(.likelihoods$os_es, y = ~range, color = ~nodeNames, type = "box")
|
|
}
|
|
})
|
|
}
|
|
|
|
shinyApp(ui, server) |