Fixes to weights and improve display readability

This commit is contained in:
2022-04-01 13:02:40 +01:00
parent 5fc290e832
commit 8089efc153
3 changed files with 18 additions and 14 deletions

Binary file not shown.

24
app.R
View File

@@ -23,8 +23,8 @@ rw <- modules::use("reWeight.R")
addResourcePath("js", "./www/js") addResourcePath("js", "./www/js")
layers <- c("Pressures to Functional Groups", "Functional Groups to Output Processes", "Output Processes to Ecosystem services") layers <- c("Pressures to Functional Groups", "Functional Groups to Ecosystem Processes", "Ecosystem Processes to Ecosystem services")
transitions <- c("Pressures to Functional Groups", "Pressures to Output Processes", "Pressures to Ecosystem services") transitions <- c("Pressures to Functional Groups", "Pressures to Ecosystem Processes", "Pressures to Ecosystem services")
impacts <- c("Very High", ">= High", ">= Medium", ">= Low", "All") impacts <- c("Very High", ">= High", ">= Medium", ">= Low", "All")
thresholds <- c(0.97, 0.9, 0.45, 0.17, 0) thresholds <- c(0.97, 0.9, 0.45, 0.17, 0)
impLabels <- c("Very High", "High", "Medium", "Low", "Very Low") impLabels <- c("Very High", "High", "Medium", "Low", "Very Low")
@@ -111,7 +111,7 @@ ui <- dashboardPage(
tags$p( tags$p(
style = "font-size: 12pt", style = "font-size: 12pt",
"The tool provides a mapping using a Continuous Gaussian Bayesian Belief Network from the "The tool provides a mapping using a Continuous Gaussian Bayesian Belief Network from the
Anthropogenic Pressures through the biotopes and to the output processes and ultimately the Anthropogenic Pressures through the biotopes and to the Ecosystem processes and ultimately the
Ecosystem services, to which the habitat supports." Ecosystem services, to which the habitat supports."
), ),
tags$p( tags$p(
@@ -170,9 +170,9 @@ ui <- dashboardPage(
) )
), ),
plotlyOutput("layer1", height = "270px") %>% withSpinner(), plotlyOutput("layer1", height = "270px") %>% withSpinner(),
h4("Effect on Output Processes"), h4("Effect on Ecosystem Processes"),
plotlyOutput("layer2", height = "270px") %>% withSpinner(), plotlyOutput("layer2", height = "270px") %>% withSpinner(),
h4("Effect on Ecosystem services"), h4("Effect on Ecosystem Services"),
plotlyOutput("layer3", height = "270px") %>% withSpinner() plotlyOutput("layer3", height = "270px") %>% withSpinner()
), ),
tabItem(tabName = "3",h2("Bayesian Network"), tabItem(tabName = "3",h2("Bayesian Network"),
@@ -272,6 +272,8 @@ server <- function(input, output, session) {
newNameMap <- openxlsx::read.xlsx("MBA_MESO_Nodes.xlsx") %>% newNameMap <- openxlsx::read.xlsx("MBA_MESO_Nodes.xlsx") %>%
dplyr::select(hab, nodeType, Suggestion, node, newname) dplyr::select(hab, nodeType, Suggestion, node, newname)
newNameMap$hab <- stringr::str_replace_all(newNameMap$hab, "_", " ")
#save(newNameMap, file="nameMap.RData") #save(newNameMap, file="nameMap.RData")
stripStr <- function(nodeStr) { stripStr <- function(nodeStr) {
@@ -322,7 +324,9 @@ server <- function(input, output, session) {
if (!is.null(wb)) { if (!is.null(wb)) {
habName <- substr(fileList[idx], 1, (nchar(fileList[idx])-5)) habName <- substr(fileList[idx], 1, (nchar(fileList[idx])-5)) %>%
stringr::str_replace_all("_", " ")
print(habName)
wb2 <- setNewNames(wb, habName) wb2 <- setNewNames(wb, habName)
@@ -693,12 +697,12 @@ server <- function(input, output, session) {
zerolinewidth = 10) zerolinewidth = 10)
# #
plot_ly(boxPlot, x = boxPlot[,1], y = ~Range, color = as.character(boxPlot$Group), colors = palette, type = "box") %>% plot_ly(boxPlot, x = boxPlot[,1], y = ~Range, color = as.character(boxPlot$Group), colors = palette, type = "box") %>%
layout(xaxis = xform, yaxis=list(range=c(-1.2, 1.2)), showlegend = FALSE, title = title) layout(xaxis = xform, yaxis=list(dtick=0.25, range=c(-1.25, 1.25)), showlegend = FALSE, title = title)
} }
} }
prepPlot <- function(code = "ba", name = "Bio-Assemblage") { prepPlot <- function(code = "ba", name = "Functional Group") {
if (!is.null(.likelihoods$p_es)) { if (!is.null(.likelihoods$p_es)) {
inScope <- startsWith(.likelihoods$p_es$code, code) inScope <- startsWith(.likelihoods$p_es$code, code)
thisPlot <- .likelihoods$p_es[inScope, c(1,3,4)] thisPlot <- .likelihoods$p_es[inScope, c(1,3,4)]
@@ -711,11 +715,11 @@ server <- function(input, output, session) {
} }
output$layer1 <- renderPlotly({ output$layer1 <- renderPlotly({
prepPlot("ba", "Bio-Assemblage") prepPlot("ba", "Functional Groups")
}) })
output$layer2 <- renderPlotly({ output$layer2 <- renderPlotly({
prepPlot("op", "Output Processes") prepPlot("op", "Ecosystem Processes")
}) })
output$layer3 <- renderPlotly({ output$layer3 <- renderPlotly({

View File

@@ -69,7 +69,7 @@ reWeightModel <- function(thisNet, pressStatus) {
dplyr::select(presscode, layer, ba_code, values) %>% dplyr::select(presscode, layer, ba_code, values) %>%
tidyr::nest(data=c(presscode, values)) tidyr::nest(data=c(presscode, values))
newP <- reWeightLayer(p_on, fudge=1) newP <- reWeightLayer(p_on, fudge=2)
@@ -86,7 +86,7 @@ reWeightModel <- function(thisNet, pressStatus) {
dplyr::rename(op_code=output) %>% dplyr::rename(op_code=output) %>%
tidyr::nest(data=c(ba_code, values)) tidyr::nest(data=c(ba_code, values))
newBA <- reWeightLayer(ba_impacted, fudge=4) newBA <- reWeightLayer(ba_impacted, fudge=2)
print("About to recalc op - es") print("About to recalc op - es")
@@ -101,7 +101,7 @@ reWeightModel <- function(thisNet, pressStatus) {
dplyr::rename(es_code=output) %>% dplyr::rename(es_code=output) %>%
tidyr::nest(data=c(op_code, values)) tidyr::nest(data=c(op_code, values))
newOP <- reWeightLayer(op_impacted, fudge=4) newOP <- reWeightLayer(op_impacted, fudge=2)
#Check for any more links through the system #Check for any more links through the system
print("About to recalc es - es") print("About to recalc es - es")
@@ -117,7 +117,7 @@ reWeightModel <- function(thisNet, pressStatus) {
dplyr::rename(lo_code=output) %>% dplyr::rename(lo_code=output) %>%
tidyr::nest(data=c(lo_code, values)) tidyr::nest(data=c(lo_code, values))
newES <- reWeightLayer(es_impacted, fudge=2) newES <- reWeightLayer(es_impacted, fudge=8)
incode <- c(newP$presscode, newBA$ba_code, newOP$op_code, newES$es_code) incode <- c(newP$presscode, newBA$ba_code, newOP$op_code, newES$es_code)
outcode <- c(newP$ba_code, newBA$op_code, newOP$es_code, newES$lo_code) outcode <- c(newP$ba_code, newBA$op_code, newOP$es_code, newES$lo_code)