JNCC/MESO
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Implement changes as requested by JNCC

Browse Source
This commit is contained in:
Steve Pegg
2022-03-30 17:51:19 +01:00
parent eec5f07cfc
commit 5fc290e832
5 changed files with 369 additions and 44 deletions
Download Patch File Download Diff File Expand all files Collapse all files

142
app.R
View File

@@ -3,6 +3,7 @@ modules::import(shinydashboard)
modules::import(shinydashboardPlus)
modules::import(shinycssloaders)
modules::import(shinyjs)
modules::import(shinyBS)
modules::import(bnlearn)
modules::import(visNetwork)
@@ -12,21 +13,25 @@ modules::import(openxlsx)
modules::import(zip)
modules::import(DT)
modules::import(plyr)
modules::import(magrittr)
parser <- modules::use("Parses.R")
rw <- modules::use("reWeight.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")
layers <- c("Pressures to Functional Groups", "Functional Groups to Output Processes", "Output Processes to Ecosystem services")
transitions <- c("Pressures to Functional Groups", "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")
ui <- dashboardPage(
dashboardHeader(title = "JNCC MESO online",
tags$li(
id = "dropdownHelp",
@@ -82,6 +87,7 @@ ui <- dashboardPage(
#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")
)
@@ -143,7 +149,7 @@ ui <- dashboardPage(
fluidRow(
column(
width = 6,
h4("Effect on bio-assemblage")
h4("Effect on Functional Groups")
),
column(
width = 1,
@@ -155,7 +161,8 @@ ui <- dashboardPage(
),
column(
width = 1,
downloadButton("download", "", icon = icon("download"))
downloadButton("download", "", icon = icon("download")),
shinyBS::bsTooltip("download", "Template provides for decimal values in degs column OR degs:mins:secs. Longitude west of meridian must be negative.")
),
column(
width = 2,
@@ -174,11 +181,13 @@ ui <- dashboardPage(
fluidRow(
column(
width = 4,
checkboxInput("bbnDisplayNames", "Display Node names", value = FALSE)
checkboxInput("bbnDisplayNames", "Display Node names", value = FALSE),
shinyBS::bsTooltip("bbnDisplayNames", "Four MESO models have been defined thus far")
),
column(
width = 4,
checkboxInput("bbnDisplayEdges", "Display edge status", value = FALSE)
checkboxInput("bbnDisplayEdges", "Display edge status", value = FALSE),
shinyBS::bsTooltip("bbnDisplayEdges", "Edges are removed")
),
column(
width = 4,
@@ -261,6 +270,42 @@ server <- function(input, output, session) {
as.numeric(v)
}
newNameMap <- openxlsx::read.xlsx("MBA_MESO_Nodes.xlsx") %>%
dplyr::select(hab, nodeType, Suggestion, node, newname)
#save(newNameMap, file="nameMap.RData")
stripStr <- function(nodeStr) {
nodeStr %>% stringr::str_replace_all("\\.", "") %>%
stringr::str_replace_all(" ", "") %>%
stringr::str_replace_all("\\(", "") %>%
stringr::str_replace_all("\\)", "") %>%
stringr::str_replace_all("\\/", "") %>%
tolower()
}
setNewNames <- function(wb, habName) {
#habName <- substr(fileList[idx], 1, (nchar(fileList[idx])-5))
print(habName)
possNames <- newNameMap %>%
dplyr::filter(hab==habName) %>%
dplyr::mutate(node=stripStr(node))
newNodes <- wb$p_es$nodes %>% dplyr::mutate(node=stripStr(name))
print(possNames$node)
print(newNodes$node)
newNames <- apply(newNodes, 1, function(row) {
id <- match(row["node"], possNames$node)
print(paste(id, row["node"]))
possNames$newname[id]
})
print(newNames)
wb$p_es$nodes$name <- newNames
return(wb)
}
getAvailableModels <- function() {
fileList <- list.files(dataStorage, pattern = ".xlsx")
@@ -276,13 +321,20 @@ server <- function(input, output, session) {
wb$p_es$edges$values <- sapply(wb$p_es$edges$impact, getImpact)
if (!is.null(wb)) {
modelList[[cnt]] <- wb
models <<- c(models, substr(fileList[idx], 1, (nchar(fileList[idx])-5)))
habName <- substr(fileList[idx], 1, (nchar(fileList[idx])-5))
wb2 <- setNewNames(wb, habName)
modelList[[cnt]] <- wb2
models <<- c(models, habName)
print(paste("Model file successfully loaded", fileList[idx]))
#save(tmp, file = "tmp.RData")
cnt <- cnt+1
}
}
#save(modelList, file="models.RData")
updateSelectInput(session, "modelSelect", choices = models)
return(modelList)
}
@@ -290,6 +342,10 @@ server <- function(input, output, session) {
#parse on load sheets in the input sheet folder - replace with R Data
modelList <- getAvailableModels()
save(modelList, file="model.RData")
#print(load("modelList.RData"))
calcLikelihood <- function(layer, pressStatus, forPlotly) {
@@ -301,7 +357,6 @@ server <- function(input, output, session) {
thisModel <- modelList[[.selections$model]]
MEANPOS <- 1
MEANNEG <- 0
@@ -318,6 +373,25 @@ server <- function(input, output, session) {
expr <- substr(expr, 1, nchar(expr)-2)
expr <- paste0(expr, ")")
print(names(thisModel))
#Now do it in stages with one assessment per stage
thisModel$p_es$nodes$confidence <- 0.1 * thisModel$p_es$nodes$confidence
#save(pressStatus, thisModel, file="beforeWeight.RData")
if (sum(pressStatus$status=="On")>0) {
thisModel$p_es <- rw$reWeightModel(thisModel$p_es, pressStatus)
} #else nothing to do
#save(pressStatus, thisModel, file="afterWeight.RData")
thisNet <- parser$buildGraph(thisModel$p_es, desc = list(inputCode = "p", outputCodes = c("ba", "op", "es")))
sampleDists <- cpdist(
@@ -333,7 +407,7 @@ server <- function(input, output, session) {
#print(sampleDists)
#displayCols <- match(nodeCodes, colnames(sampleDists))
sampleDists <- sampleDists[,match(thisModel$p_es$nodes$code, colnames(sampleDists))]
sampleDists <- round(sampleDists[,match(thisModel$p_es$nodes$code, colnames(sampleDists))], digits=2)
means <- apply(sampleDists, 2, mean)
stdDev <- apply(sampleDists, 2, sd)
@@ -341,7 +415,7 @@ server <- function(input, output, session) {
quantiles <- t(apply(sampleDists, 2, quantile, c(0.01, 0.25, 0.5, 0.75, 0.99)))
print(paste("Building likelihoods from model, sample dists", length(thisModel$p_es$nodes$name), length(sampleDists)))
#str(quantiles)
if (forPlotly) {
return(data.frame(
name = thisModel$p_es$nodes$name,
@@ -371,7 +445,7 @@ server <- function(input, output, session) {
maxes = apply(sampleDists, 2, max),
stringsAsFactors = FALSE
))
}
}
@@ -397,7 +471,7 @@ server <- function(input, output, session) {
#.selections$runOnce = FALSE
print("Running calc")
.likelihoods$p_es <<- calcLikelihood(0, newStatus, TRUE)
.selections$pressStatus <<- newStatus
}
@@ -420,7 +494,7 @@ server <- function(input, output, session) {
#status = status,
stringsAsFactors = FALSE
)
#This assumes all pressures are the same...
setPressures(pressures)
@@ -466,7 +540,7 @@ server <- function(input, output, session) {
})
observeEvent(input$modalOK, {
.resistanceScores["nr"] <<- -input$l1VH
.resistanceScores["lr"] <<- -input$l1H
@@ -476,7 +550,7 @@ server <- function(input, output, session) {
.resistanceScores["ssgr"] <<- input$ssgr
.resistanceScores["pressSD"] <<- input$l1PressSD
.likelihoods$p_es <<- calcLikelihood(0, .selections$pressStatus, TRUE)
removeModal()
@@ -570,7 +644,7 @@ server <- function(input, output, session) {
} else {
edgeNet <- edges
}
print(paste(nrow(model$legend), length(palette)))
legendDF <- data.frame(
@@ -619,7 +693,7 @@ server <- function(input, output, session) {
zerolinewidth = 10)
#
plot_ly(boxPlot, x = boxPlot[,1], y = ~Range, color = as.character(boxPlot$Group), colors = palette, type = "box") %>%
layout(xaxis = xform, showlegend = FALSE, title = title)
layout(xaxis = xform, yaxis=list(range=c(-1.2, 1.2)), showlegend = FALSE, title = title)
}
}
@@ -668,10 +742,10 @@ server <- function(input, output, session) {
},
contentType = "application/xlsx"
)
makeLikelihoods <- function() {
likeliTab <- as.data.frame(
cbind(
.likelihoods$p_es, codeVal = sapply(
@@ -682,15 +756,15 @@ server <- function(input, output, session) {
)),
stringsAsFactors=FALSE
)
likeliTab <- arrange(likeliTab, layer, codeVal)
outputRows <- trunc(nrow(likeliTab)/7)
outputTab <- NULL
for (idx in 1:outputRows) {
elementRow <- (idx - 1) * 7 + 1
tabRow <-c(
name = likeliTab$name[elementRow],
code = likeliTab$code[elementRow],
@@ -702,9 +776,9 @@ server <- function(input, output, session) {
max =likeliTab$range[elementRow+6]
)
outputTab <- rbind(outputTab, tabRow)
}
likelihoods <- data.frame(
name = outputTab[,1],
code = outputTab[,2],
@@ -720,10 +794,10 @@ server <- function(input, output, session) {
}
output$download <- downloadHandler(
filename = function() { paste0("MESO-", format(Sys.time(), "%m%d_%H%M"), ".xlsx") },
content = function(file) {
showModal(
modalDialog(
fluidRow(
@@ -734,13 +808,13 @@ server <- function(input, output, session) {
)
oldDir <- getwd()
tmp <- tempfile("")
dir.create(tmp)
setwd(tmp)
l <- list(
pressures = .selections$pressStatus,
nodes = modelList[[.selections$model]]$p_es$nodes,
@@ -751,7 +825,7 @@ server <- function(input, output, session) {
xl <- write.xlsx(l, "dataset.xlsx")
#zipFile <- zipr(file, c("dataset.xlsx"))
file.copy("dataset.xlsx", file)
#print(paste("zip file complete", zipFile))