modules::import(shiny)
modules::import(shinydashboard)
modules::import(shinydashboardPlus)
modules::import(shinycssloaders)
modules::import(shinyjs)

modules::import(bnlearn)
modules::import(visNetwork)
modules::import(RColorBrewer)
modules::import(plotly)
modules::import(openxlsx)
modules::import(zip)
modules::import(DT)

parser <- modules::use("Parses.R")


addResourcePath("js", "./www/js")


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",
          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",
    server = TRUE,
    escape = FALSE,
    rownames = TRUE,
    options = list(searching = TRUE, pageLength = 10, editable = TRUE)
  )

  output$edgeTable <- DT::renderDataTable(
    modelList[[.selections$model]]$edges,
    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))
    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("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) {
      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)