MESO/app.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)

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"),
      
      #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 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")
              )
          ), 
          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('Eco-system 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({
    plot_ly(.likelihoods$p_ba, y = ~range, color = ~nodeNames, type = "box") %>%
      layout(xaxis = list(zerolinewidth=2)) #%>%
      #withSpinner()
      
  })

  output$layer2 <- renderPlotly({
    if (.selections$layer>1) {
      plot_ly(.likelihoods$ba_os, y = ~range, color = ~nodeNames, type = "box") %>%
        layout(xaxis = list(zerolinewidth=2)) #%>%
        #withSpinner()
    }
  })

  output$layer3 <- renderPlotly({
    
    if (.selections$layer>2) {
      plot_ly(.likelihoods$os_es, y = ~range, color = ~nodeNames, type = "box") %>%
        layout(xaxis = list(zerolinewidth=2)) #%>%
        #withSpinner()
    }
  })
}

shinyApp(ui, server)