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) 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") addResourcePath("js", "./www/js") ui<-dashboardPage( dashboardHeader(title = "JNCC MESO online"), #tags$style(.times-circle {color:800000 }), #tags$style(.check-square {color:008000 }), 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 = "4", icon = icon("utensils")), 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'), actionButton("calcAB", "Calc"), uiOutput("pressureList") ), 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 Ecosystem 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") ) ), tabItem(tabName = "4",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 #disable(input$loadAb) .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 ) setPressures <- function(newPressures) { pressures <<- newPressures } validateSheets <- function() { req(inputs$selectFile) ##TO DO - run parser on it and output the errors to } 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 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 - replace with R Data modelList <- getAvailableModels() calcLikelihood <- function(layer, pressStatus) { # 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$code, layerStr)) nodeCodes <- modelList[[.selections$model]][[layer]]$nodes$code[layerRange] nodeNames <- modelList[[.selections$model]][[layer]]$nodes$name[layerRange] MEANPOS=1 MEANNEG=0 # expr <- "(" # 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, ')') # # print(expr) 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, ')') print(expr) #txtStringWkg = "((\"p1\">=0.5) & (\"p10\">=0.5) & (\"p2\">=0.5))" print(bnlearn::nodes(modelList[[.selections$model]][[layer]]$cfit)) sampleDists <- cpdist( fitted = modelList[[.selections$model]][[layer]]$cfit, nodes = bnlearn::nodes(modelList[[.selections$model]][[layer]]$cfit), evidence = eval(parse(text = expr)), method = "lw", n = 10000, debug=TRUE ) }) #print (sum(res[, 1] * attr(res, "weights")) / sum(attr(res, "weights"))) print("Sample dists") print(sampleDists) print("Weights") print(unique(attr(sampleDists, "weights"))) displayCols <- match(nodeCodes, colnames(sampleDists)) sampleDists <- sampleDists[,displayCols] means <- apply(sampleDists, 2, mean) stdDev <- apply(sampleDists, 2, sd) print(modelList[[.selections$model]][[layer]]$nodes$name) return(data.frame( nodeNames = nodeNames, range = c( apply(sampleDists, 2, min), means - 2*stdDev, means - stdDev, means, means + stdDev, means + 2*stdDev, apply(sampleDists, 2, max) ), stringsAsFactors=FALSE )) } renderStatus <- function(layer) { isolate({ if (.loadStatus$valid[layer]) return('check-square') else return('times-circle') }) } output$status <- renderUI({ tagList( fluidRow( column(width=3, h4('Pressures')), column(width=3, h4('Bio-assemblages')), column(width=3, h4('Output processes')), column(width=3, h4('Ecosystem services')) ), fluidRow( column(width=3, icon(renderStatus(1))), column(width=3, icon(renderStatus(2))), column(width=3, icon(renderStatus(3))), column(width=3, icon(renderStatus(4))) )#, #fluidRow( # verbatimTextOutput("msgBoard", .loadStatus$msg, placeholder=TRUE) #) ) }) observeEvent(input$loadAB, { #TO DO get spreadsheet #copy validated sheet into the data folder and either add or replace the sheet in the RData file #reload the RData file print('Load button pressed') }) observeEvent(input$modelSelect, { .selections$model <<- match(input$modelSelect, models) }) observeEvent(input$layerSelect, { .selections$layer <<- match(input$layerSelect, transitions) }) observeEvent(input$calcAB, { #get the status of action buttons isolate(myList <- reactiveValuesToList(input)) matches <- match(pressures$code, names(myList)) status <-NULL for (n in 1:length(matches)) status[n] = myList[[matches[n]]] pressStatus <- data.frame(code=pressures$code, status=status, stringsAsFactors = FALSE) .likelihoods$p_ba <<- calcLikelihood(1, pressStatus) .likelihoods$ba_os <<- calcLikelihood(2, pressStatus) .likelihoods$os_es <<- calcLikelihood(3, pressStatus) }) output$map <- renderGoogle_map({ google_map(location = c(55, 0), zoom = 7) }) 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]][[1]]$nodes)) { pressCodes <- which(startsWith(modelList[[.selections$model]][[1]]$nodes$code, 'p')) pressures <- data.frame(code = modelList[[.selections$model]][[1]]$nodes$code[pressCodes], name = modelList[[.selections$model]][[1]]$nodes$name[pressCodes], stringsAsFactors=FALSE) setPressures(pressures) btnList <- apply(pressures, 1, makeRadioButtons) } }) output$nodeTable <- DT::renderDataTable( modelList[[.selections$model]][[.selections$layer]]$nodes, selection = 'single',options = list(searching = TRUE, pageLength = 10, editable=TRUE),server = TRUE, escape = FALSE,rownames= TRUE ) output$edgeTable <- DT::renderDataTable( modelList[[.selections$model]][[.selections$layer]]$edges, selection = 'single',options = list(searching = TRUE, pageLength = 10, editable=TRUE),server = TRUE, escape = FALSE,rownames= TRUE ) output$bbnGraphPlot <- renderPlot({ graphviz.plot(modelList[[.selections$model]][[.selections$layer]]$net) }) output$layer1 <- renderPlotly({ if (length(.likelihoods$p_ba)>0) { plot_ly(.likelihoods$p_ba, y = ~range, color = ~nodeNames, type = "box") %>% layout(xaxis = list(zerolinewidth=2)) } }) output$layer2 <- renderPlotly({ if (.selections$layer>1) { plot_ly(.likelihoods$ba_os, y = ~range, color = ~nodeNames, type = "box") %>% layout(xaxis = list(zerolinewidth=2)) } }) output$layer3 <- renderPlotly({ if (.selections$layer>2) { plot_ly(.likelihoods$os_es, y = ~range, color = ~nodeNames, type = "box") %>% layout(xaxis = list(zerolinewidth=2)) } }) } shinyApp(ui, server)