Fixes to weights and improve display readability
This commit is contained in:
Binary file not shown.
24
app.R
24
app.R
@@ -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({
|
||||||
|
|||||||
@@ -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)
|
||||||
|
|||||||
Reference in New Issue
Block a user